texlive[74255] Master/tlpkg/tltcl: New tcl/tk
commits+siepo at tug.org
commits+siepo at tug.org
Mon Feb 24 14:59:26 CET 2025
Revision: 74255
https://tug.org/svn/texlive?view=revision&revision=74255
Author: siepo
Date: 2025-02-24 14:59:26 +0100 (Mon, 24 Feb 2025)
Log Message:
-----------
New tcl/tk
Modified Paths:
--------------
trunk/Master/tlpkg/tltcl/README.TEXLIVE
trunk/Master/tlpkg/tltcl/bin/tclsh.exe
trunk/Master/tlpkg/tltcl/bin/wish.exe
trunk/Master/tlpkg/tltcl/bin/zlib1.dll
trunk/Master/tlpkg/tltcl/lib/dde1.4/libtcldde14.dll.a
trunk/Master/tlpkg/tltcl/lib/dde1.4/pkgIndex.tcl
trunk/Master/tlpkg/tltcl/lib/dde1.4/tcldde14.dll
trunk/Master/tlpkg/tltcl/lib/tclConfig.sh
trunk/Master/tlpkg/tltcl/lib/tclooConfig.sh
trunk/Master/tlpkg/tltcl/lib/tkConfig.sh
Added Paths:
-----------
trunk/Master/tlpkg/tltcl/bin/libtommath.dll
trunk/Master/tlpkg/tltcl/bin/sqlite3_analyzer
trunk/Master/tlpkg/tltcl/bin/tcl90.dll
trunk/Master/tlpkg/tltcl/bin/tcl9tk90.dll
trunk/Master/tlpkg/tltcl/bin/tclsh90.exe
trunk/Master/tlpkg/tltcl/bin/wish90.exe
trunk/Master/tlpkg/tltcl/lib/dde1.4/tcl9dde14.dll
trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/
trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/itcl.tcl
trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/itclConfig.sh
trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/itclHullCmds.tcl
trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/itclWidget.tcl
trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/libitclstub.a
trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/pkgIndex.tcl
trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/tcl9itcl432.dll
trunk/Master/tlpkg/tltcl/lib/libtcl90.dll.a
trunk/Master/tlpkg/tltcl/lib/libtcl9tk90.dll.a
trunk/Master/tlpkg/tltcl/lib/libtclstub.a
trunk/Master/tlpkg/tltcl/lib/libtkstub.a
trunk/Master/tlpkg/tltcl/lib/libtommath.dll.a
trunk/Master/tlpkg/tltcl/lib/libz.dll.a
trunk/Master/tlpkg/tltcl/lib/registry1.3/
trunk/Master/tlpkg/tltcl/lib/registry1.3/libtclregistry13.dll.a
trunk/Master/tlpkg/tltcl/lib/registry1.3/pkgIndex.tcl
trunk/Master/tlpkg/tltcl/lib/registry1.3/tcl9registry13.dll
trunk/Master/tlpkg/tltcl/lib/registry1.3/tclregistry13.dll
trunk/Master/tlpkg/tltcl/lib/sqlite3.47.2/
trunk/Master/tlpkg/tltcl/lib/sqlite3.47.2/pkgIndex.tcl
trunk/Master/tlpkg/tltcl/lib/sqlite3.47.2/tcl9sqlite3472.dll
trunk/Master/tlpkg/tltcl/lib/tcl9/
trunk/Master/tlpkg/tltcl/lib/tcl9/9.0/
trunk/Master/tlpkg/tltcl/lib/tcl9/9.0/tdbc/
trunk/Master/tlpkg/tltcl/lib/tcl9/9.0/tdbc/sqlite3-1.1.10.tm
trunk/Master/tlpkg/tltcl/lib/tcl9/9.0/tdbc/sqlite3-1.1.10.uuid
trunk/Master/tlpkg/tltcl/lib/tdbc1.1.10/
trunk/Master/tlpkg/tltcl/lib/tdbc1.1.10/libtdbcstub.a
trunk/Master/tlpkg/tltcl/lib/tdbc1.1.10/pkgIndex.tcl
trunk/Master/tlpkg/tltcl/lib/tdbc1.1.10/tcl9tdbc1110.dll
trunk/Master/tlpkg/tltcl/lib/tdbc1.1.10/tdbc.tcl
trunk/Master/tlpkg/tltcl/lib/tdbc1.1.10/tdbcConfig.sh
trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.10/
trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.10/pkgIndex.tcl
trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.10/tcl9tdbcmysql1110.dll
trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.10/tdbcmysql.tcl
trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.10/
trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.10/pkgIndex.tcl
trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.10/tcl9tdbcodbc1110.dll
trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.10/tdbcodbc.tcl
trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.10/
trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.10/pkgIndex.tcl
trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.10/tcl9tdbcpostgres1110.dll
trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.10/tdbcpostgres.tcl
trunk/Master/tlpkg/tltcl/lib/thread3.0.1/
trunk/Master/tlpkg/tltcl/lib/thread3.0.1/pkgIndex.tcl
trunk/Master/tlpkg/tltcl/lib/thread3.0.1/tcl9thread301.dll
trunk/Master/tlpkg/tltcl/lib/tk9.0/
trunk/Master/tlpkg/tltcl/lib/tk9.0/bgerror.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/button.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/choosedir.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/clrpick.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/comdlg.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/console.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/README
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/anilabel.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/aniwave.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/arrow.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/bind.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/bitmap.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/browse
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/button.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/check.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/clrpick.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/colors.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/combo.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/cscroll.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ctext.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/dialog1.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/dialog2.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/en.msg
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/entry1.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/entry2.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/entry3.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/filebox.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/floor.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/fontchoose.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/form.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/goldberg.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/hello
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/hscale.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/icon.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/image1.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/image2.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/Tcl.svg
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/Tk_feather.png
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/earth.gif
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/earthmenu.png
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/earthris.gif
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/flagdown.xbm
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/flagup.xbm
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/gray25.xbm
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/letters.xbm
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/noletter.xbm
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/ouster.png
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/pattern.xbm
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/plowed_field.png
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/starry_night.png
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/tcllogo.gif
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/teapot.ppm
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/items.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ixset
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/knightstour.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/label.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/labelframe.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/license.terms
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/mac_styles.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/mac_tabs.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/mac_wm.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/mclist.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/menu.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/menubu.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/msgbox.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/nl.msg
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/paned1.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/paned2.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/pendulum.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/plot.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/print.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/puzzle.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/radio.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/rmt
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/rolodex
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ruler.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/sayings.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/search.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/spin.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/states.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/style.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/systray.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/tclIndex
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/tcolor
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/text.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/textpeer.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/timer
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/toolbar.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/tree.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ttkbut.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ttkmenu.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ttknote.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ttkpane.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ttkprogress.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ttkscale.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ttkspin.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/twind.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/unicodeout.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/vscale.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/widget
trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/windowicons.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/dialog.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/entry.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/focus.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/fontchooser.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/iconbadges.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/iconlist.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/icons.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/images/
trunk/Master/tlpkg/tltcl/lib/tk9.0/images/README
trunk/Master/tlpkg/tltcl/lib/tk9.0/images/logo.eps
trunk/Master/tlpkg/tltcl/lib/tk9.0/images/logo100.gif
trunk/Master/tlpkg/tltcl/lib/tk9.0/images/logo64.gif
trunk/Master/tlpkg/tltcl/lib/tk9.0/images/logoLarge.gif
trunk/Master/tlpkg/tltcl/lib/tk9.0/images/logoMed.gif
trunk/Master/tlpkg/tltcl/lib/tk9.0/images/pwrdLogo.eps
trunk/Master/tlpkg/tltcl/lib/tk9.0/images/pwrdLogo100.gif
trunk/Master/tlpkg/tltcl/lib/tk9.0/images/pwrdLogo150.gif
trunk/Master/tlpkg/tltcl/lib/tk9.0/images/pwrdLogo175.gif
trunk/Master/tlpkg/tltcl/lib/tk9.0/images/pwrdLogo200.gif
trunk/Master/tlpkg/tltcl/lib/tk9.0/images/pwrdLogo75.gif
trunk/Master/tlpkg/tltcl/lib/tk9.0/images/tai-ku.gif
trunk/Master/tlpkg/tltcl/lib/tk9.0/listbox.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/megawidget.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/menu.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/mkpsenc.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/msgbox.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/
trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/cs.msg
trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/da.msg
trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/de.msg
trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/el.msg
trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/en.msg
trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/en_gb.msg
trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/eo.msg
trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/es.msg
trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/fi.msg
trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/fr.msg
trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/hu.msg
trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/it.msg
trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/nl.msg
trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/pl.msg
trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/pt.msg
trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/ru.msg
trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/sv.msg
trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/zh_cn.msg
trunk/Master/tlpkg/tltcl/lib/tk9.0/optMenu.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/palette.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/panedwindow.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/pkgIndex.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/print.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/safetk.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/scale.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/scaling.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/scrlbar.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/spinbox.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/systray.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/tclIndex
trunk/Master/tlpkg/tltcl/lib/tk9.0/tearoff.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/text.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/tk.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/tkAppInit.c
trunk/Master/tlpkg/tltcl/lib/tk9.0/tkfbox.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/ttk/
trunk/Master/tlpkg/tltcl/lib/tk9.0/ttk/altTheme.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/ttk/aquaTheme.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/ttk/button.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/ttk/clamTheme.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/ttk/classicTheme.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/ttk/combobox.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/ttk/cursors.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/ttk/defaults.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/ttk/entry.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/ttk/fonts.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/ttk/menubutton.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/ttk/notebook.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/ttk/panedwindow.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/ttk/progress.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/ttk/scale.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/ttk/scrollbar.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/ttk/sizegrip.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/ttk/spinbox.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/ttk/treeview.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/ttk/ttk.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/ttk/utils.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/ttk/vistaTheme.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/ttk/winTheme.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/ttk/xpTheme.tcl
trunk/Master/tlpkg/tltcl/lib/tk9.0/xmfbox.tcl
Removed Paths:
-------------
trunk/Master/tlpkg/tltcl/bin/tcl86.dll
trunk/Master/tlpkg/tltcl/bin/tclsh86.exe
trunk/Master/tlpkg/tltcl/bin/tk86.dll
trunk/Master/tlpkg/tltcl/bin/wish86.exe
trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/
trunk/Master/tlpkg/tltcl/lib/libtcl86.dll.a
trunk/Master/tlpkg/tltcl/lib/libtclstub86.a
trunk/Master/tlpkg/tltcl/lib/libtk86.dll.a
trunk/Master/tlpkg/tltcl/lib/libtkstub86.a
trunk/Master/tlpkg/tltcl/lib/reg1.3/
trunk/Master/tlpkg/tltcl/lib/sqlite3.40.0/
trunk/Master/tlpkg/tltcl/lib/tcl8/
trunk/Master/tlpkg/tltcl/lib/tcl8.6/
trunk/Master/tlpkg/tltcl/lib/tdbc1.1.5/
trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.5/
trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.5/
trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.5/
trunk/Master/tlpkg/tltcl/lib/thread2.8.8/
trunk/Master/tlpkg/tltcl/lib/tk8.6/
Modified: trunk/Master/tlpkg/tltcl/README.TEXLIVE
===================================================================
--- trunk/Master/tlpkg/tltcl/README.TEXLIVE 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/README.TEXLIVE 2025-02-24 13:59:26 UTC (rev 74255)
@@ -1,6 +1,6 @@
(This file public domain.)
-This directory contains Tcl/Tk 8.6.12 compiled for Windows.
+This directory contains Tcl/Tk 9.0.1 compiled for Windows.
The only purpose of this Tcl/Tk is to provide support on Windows for
Tcl scripts shipped with TeX Live. It is not intended for general use.
Added: trunk/Master/tlpkg/tltcl/bin/libtommath.dll
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/bin/libtommath.dll
===================================================================
--- trunk/Master/tlpkg/tltcl/bin/libtommath.dll 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/bin/libtommath.dll 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/bin/libtommath.dll
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+application/vnd.microsoft.portable-executable
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/bin/sqlite3_analyzer
===================================================================
--- trunk/Master/tlpkg/tltcl/bin/sqlite3_analyzer (rev 0)
+++ trunk/Master/tlpkg/tltcl/bin/sqlite3_analyzer 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,899 @@
+#! /bin/sh
+# restart with tclsh \
+exec tclsh "$0" ${1+"$@"}
+package require sqlite3
+
+# Run this TCL script using an SQLite-enabled TCL interpreter to get a report
+# on how much disk space is used by a particular data to actually store data
+# versus how much space is unused.
+#
+# The dbstat virtual table is required.
+#
+
+if {[catch {
+
+# Argument $tname is the name of a table within the database opened by
+# database handle [db]. Return true if it is a WITHOUT ROWID table, or
+# false otherwise.
+#
+proc is_without_rowid {tname} {
+ set t [string map {' ''} $tname]
+ db eval "PRAGMA index_list = '$t'" o {
+ if {$o(origin) == "pk"} {
+ set n $o(name)
+ if {0==[db one { SELECT count(*) FROM sqlite_schema WHERE name=$n }]} {
+ return 1
+ }
+ }
+ }
+ return 0
+}
+
+# Read and run TCL commands from standard input. Used to implement
+# the --tclsh option.
+#
+proc tclsh {} {
+ set line {}
+ while {![eof stdin]} {
+ if {$line!=""} {
+ puts -nonewline "> "
+ } else {
+ puts -nonewline "% "
+ }
+ flush stdout
+ append line [gets stdin]
+ if {[info complete $line]} {
+ if {[catch {uplevel #0 $line} result]} {
+ puts stderr "Error: $result"
+ } elseif {$result!=""} {
+ puts $result
+ }
+ set line {}
+ } else {
+ append line \n
+ }
+ }
+}
+
+
+# Get the name of the database to analyze
+#
+proc usage {} {
+ set argv0 [file rootname [file tail [info script]]]
+ puts stderr "Usage: $argv0 ?--pageinfo? ?--stats? database-filename"
+ puts stderr {
+Analyze the SQLite3 database file specified by the "database-filename"
+argument and output a report detailing size and storage efficiency
+information for the database and its constituent tables and indexes.
+
+Options:
+
+ --pageinfo Show how each page of the database-file is used
+
+ --stats Output SQL text that creates a new database containing
+ statistics about the database that was analyzed
+
+ --tclsh Run the built-in TCL interpreter interactively (for debugging)
+
+ --version Show the version number of SQLite
+}
+ exit 1
+}
+set file_to_analyze {}
+set flags(-pageinfo) 0
+set flags(-stats) 0
+set flags(-debug) 0
+append argv {}
+foreach arg $argv {
+ if {[regexp {^-+pageinfo$} $arg]} {
+ set flags(-pageinfo) 1
+ } elseif {[regexp {^-+stats$} $arg]} {
+ set flags(-stats) 1
+ } elseif {[regexp {^-+debug$} $arg]} {
+ set flags(-debug) 1
+ } elseif {[regexp {^-+tclsh$} $arg]} {
+ tclsh
+ exit 0
+ } elseif {[regexp {^-+version$} $arg]} {
+ sqlite3 mem :memory:
+ puts [mem one {SELECT sqlite_version()||' '||sqlite_source_id()}]
+ mem close
+ exit 0
+ } elseif {[regexp {^-} $arg]} {
+ puts stderr "Unknown option: $arg"
+ usage
+ } elseif {$file_to_analyze!=""} {
+ usage
+ } else {
+ set file_to_analyze $arg
+ }
+}
+if {$file_to_analyze==""} usage
+set root_filename $file_to_analyze
+regexp {^file:(//)?([^?]*)} $file_to_analyze all x1 root_filename
+if {![file exists $root_filename]} {
+ puts stderr "No such file: $root_filename"
+ exit 1
+}
+if {![file readable $root_filename]} {
+ puts stderr "File is not readable: $root_filename"
+ exit 1
+}
+set true_file_size [file size $root_filename]
+if {$true_file_size<512} {
+ puts stderr "Empty or malformed database: $root_filename"
+ exit 1
+}
+
+# Compute the total file size assuming test_multiplexor is being used.
+# Assume that SQLITE_ENABLE_8_3_NAMES might be enabled
+#
+set extension [file extension $root_filename]
+set pattern $root_filename
+append pattern {[0-3][0-9][0-9]}
+foreach f [glob -nocomplain $pattern] {
+ incr true_file_size [file size $f]
+ set extension {}
+}
+if {[string length $extension]>=2 && [string length $extension]<=4} {
+ set pattern [file rootname $root_filename]
+ append pattern {.[0-3][0-9][0-9]}
+ foreach f [glob -nocomplain $pattern] {
+ incr true_file_size [file size $f]
+ }
+}
+
+# Open the database
+#
+if {[catch {sqlite3 db $file_to_analyze -uri 1} msg]} {
+ puts stderr "error trying to open $file_to_analyze: $msg"
+ exit 1
+}
+if {$flags(-debug)} {
+ proc dbtrace {txt} {puts $txt; flush stdout;}
+ db trace ::dbtrace
+}
+
+# Make sure all required compile-time options are available
+#
+if {![db exists {SELECT 1 FROM pragma_compile_options
+ WHERE compile_options='ENABLE_DBSTAT_VTAB'}]} {
+ puts "The SQLite database engine linked with this application\
+ lacks required capabilities. Recompile using the\
+ -DSQLITE_ENABLE_DBSTAT_VTAB compile-time option to fix\
+ this problem."
+ exit 1
+}
+
+db eval {SELECT count(*) FROM sqlite_schema}
+set pageSize [expr {wide([db one {PRAGMA page_size}])}]
+
+if {$flags(-pageinfo)} {
+ db eval {CREATE VIRTUAL TABLE temp.stat USING dbstat}
+ db eval {SELECT name, path, pageno FROM temp.stat ORDER BY pageno} {
+ puts "$pageno $name $path"
+ }
+ exit 0
+}
+if {$flags(-stats)} {
+ db eval {CREATE VIRTUAL TABLE temp.stat USING dbstat}
+ puts "BEGIN;"
+ puts "CREATE TABLE stats("
+ puts " name STRING, /* Name of table or index */"
+ puts " path INTEGER, /* Path to page from root */"
+ puts " pageno INTEGER, /* Page number */"
+ puts " pagetype STRING, /* 'internal', 'leaf' or 'overflow' */"
+ puts " ncell INTEGER, /* Cells on page (0 for overflow) */"
+ puts " payload INTEGER, /* Bytes of payload on this page */"
+ puts " unused INTEGER, /* Bytes of unused space on this page */"
+ puts " mx_payload INTEGER, /* Largest payload size of all cells */"
+ puts " pgoffset INTEGER, /* Offset of page in file */"
+ puts " pgsize INTEGER /* Size of the page */"
+ puts ");"
+ db eval {SELECT quote(name) || ',' ||
+ quote(path) || ',' ||
+ quote(pageno) || ',' ||
+ quote(pagetype) || ',' ||
+ quote(ncell) || ',' ||
+ quote(payload) || ',' ||
+ quote(unused) || ',' ||
+ quote(mx_payload) || ',' ||
+ quote(pgoffset) || ',' ||
+ quote(pgsize) AS x FROM stat} {
+ puts "INSERT INTO stats VALUES($x);"
+ }
+ puts "COMMIT;"
+ exit 0
+}
+
+
+# In-memory database for collecting statistics. This script loops through
+# the tables and indices in the database being analyzed, adding a row for each
+# to an in-memory database (for which the schema is shown below). It then
+# queries the in-memory db to produce the space-analysis report.
+#
+sqlite3 mem :memory:
+if {$flags(-debug)} {
+ proc dbtrace {txt} {puts $txt; flush stdout;}
+ mem trace ::dbtrace
+}
+set tabledef {CREATE TABLE space_used(
+ name clob, -- Name of a table or index in the database file
+ tblname clob, -- Name of associated table
+ is_index boolean, -- TRUE if it is an index, false for a table
+ is_without_rowid boolean, -- TRUE if WITHOUT ROWID table
+ nentry int, -- Number of entries in the BTree
+ leaf_entries int, -- Number of leaf entries
+ depth int, -- Depth of the b-tree
+ payload int, -- Total amount of data stored in this table or index
+ ovfl_payload int, -- Total amount of data stored on overflow pages
+ ovfl_cnt int, -- Number of entries that use overflow
+ mx_payload int, -- Maximum payload size
+ int_pages int, -- Number of interior pages used
+ leaf_pages int, -- Number of leaf pages used
+ ovfl_pages int, -- Number of overflow pages used
+ int_unused int, -- Number of unused bytes on interior pages
+ leaf_unused int, -- Number of unused bytes on primary pages
+ ovfl_unused int, -- Number of unused bytes on overflow pages
+ gap_cnt int, -- Number of gaps in the page layout
+ compressed_size int -- Total bytes stored on disk
+);}
+mem eval $tabledef
+
+# Create a temporary "dbstat" virtual table.
+#
+db eval {CREATE VIRTUAL TABLE temp.stat USING dbstat}
+db eval {CREATE TEMP TABLE dbstat AS SELECT * FROM temp.stat
+ ORDER BY name, path}
+db eval {DROP TABLE temp.stat}
+
+set isCompressed 0
+set compressOverhead 0
+set depth 0
+set sql { SELECT name, tbl_name FROM sqlite_schema WHERE rootpage>0 }
+foreach {name tblname} [concat sqlite_schema sqlite_schema [db eval $sql]] {
+
+ set is_index [expr {$name!=$tblname}]
+ set is_without_rowid [is_without_rowid $name]
+ db eval {
+ SELECT
+ sum(ncell) AS nentry,
+ sum((pagetype=='leaf')*ncell) AS leaf_entries,
+ sum(payload) AS payload,
+ sum((pagetype=='overflow') * payload) AS ovfl_payload,
+ sum(path LIKE '%+000000') AS ovfl_cnt,
+ max(mx_payload) AS mx_payload,
+ sum(pagetype=='internal') AS int_pages,
+ sum(pagetype=='leaf') AS leaf_pages,
+ sum(pagetype=='overflow') AS ovfl_pages,
+ sum((pagetype=='internal') * unused) AS int_unused,
+ sum((pagetype=='leaf') * unused) AS leaf_unused,
+ sum((pagetype=='overflow') * unused) AS ovfl_unused,
+ sum(pgsize) AS compressed_size,
+ max((length(CASE WHEN path LIKE '%+%' THEN '' ELSE path END)+3)/4)
+ AS depth
+ FROM temp.dbstat WHERE name = $name
+ } break
+
+ set total_pages [expr {$leaf_pages+$int_pages+$ovfl_pages}]
+ set storage [expr {$total_pages*$pageSize}]
+ if {!$isCompressed && $storage>$compressed_size} {
+ set isCompressed 1
+ set compressOverhead 14
+ }
+
+ # Column 'gap_cnt' is set to the number of non-contiguous entries in the
+ # list of pages visited if the b-tree structure is traversed in a top-down
+ # fashion (each node visited before its child-tree is passed). Any overflow
+ # chains present are traversed from start to finish before any child-tree
+ # is.
+ #
+ set gap_cnt 0
+ set prev 0
+ db eval {
+ SELECT pageno, pagetype FROM temp.dbstat
+ WHERE name=$name
+ ORDER BY pageno
+ } {
+ if {$prev>0 && $pagetype=="leaf" && $pageno!=$prev+1} {
+ incr gap_cnt
+ }
+ set prev $pageno
+ }
+ mem eval {
+ INSERT INTO space_used VALUES(
+ $name,
+ $tblname,
+ $is_index,
+ $is_without_rowid,
+ $nentry,
+ $leaf_entries,
+ $depth,
+ $payload,
+ $ovfl_payload,
+ $ovfl_cnt,
+ $mx_payload,
+ $int_pages,
+ $leaf_pages,
+ $ovfl_pages,
+ $int_unused,
+ $leaf_unused,
+ $ovfl_unused,
+ $gap_cnt,
+ $compressed_size
+ );
+ }
+}
+
+proc integerify {real} {
+ if {[string is double -strict $real]} {
+ return [expr {wide($real)}]
+ } else {
+ return 0
+ }
+}
+mem function int integerify
+
+# Quote a string for use in an SQL query. Examples:
+#
+# [quote {hello world}] == {'hello world'}
+# [quote {hello world's}] == {'hello world''s'}
+#
+proc quote {txt} {
+ return [string map {' ''} $txt]
+}
+
+# Output a title line
+#
+proc titleline {title} {
+ if {$title==""} {
+ puts [string repeat * 79]
+ } else {
+ set len [string length $title]
+ set stars [string repeat * [expr {79-$len-5}]]
+ puts "*** $title $stars"
+ }
+}
+
+# Generate a single line of output in the statistics section of the
+# report.
+#
+proc statline {title value {extra {}}} {
+ set len [string length $title]
+ set dots [string repeat . [expr {50-$len}]]
+ set len [string length $value]
+ set sp2 [string range { } $len end]
+ if {$extra ne ""} {
+ set extra " $extra"
+ }
+ puts "$title$dots $value$sp2$extra"
+}
+
+# Generate a formatted percentage value for $num/$denom
+#
+proc percent {num denom {of {}}} {
+ if {$denom==0.0} {return ""}
+ set v [expr {$num*100.0/$denom}]
+ set of {}
+ if {$v==100.0 || $v<0.001 || ($v>1.0 && $v<99.0)} {
+ return [format {%5.1f%% %s} $v $of]
+ } elseif {$v<0.1 || $v>99.9} {
+ return [format {%7.3f%% %s} $v $of]
+ } else {
+ return [format {%6.2f%% %s} $v $of]
+ }
+}
+
+proc divide {num denom} {
+ if {$denom==0} {return 0.0}
+ return [format %.2f [expr {double($num)/double($denom)}]]
+}
+
+# Generate a subreport that covers some subset of the database.
+# the $where clause determines which subset to analyze.
+#
+proc subreport {title where showFrag} {
+ global pageSize file_pgcnt compressOverhead
+
+ # Query the in-memory database for the sum of various statistics
+ # for the subset of tables/indices identified by the WHERE clause in
+ # $where. Note that even if the WHERE clause matches no rows, the
+ # following query returns exactly one row (because it is an aggregate).
+ #
+ # The results of the query are stored directly by SQLite into local
+ # variables (i.e. $nentry, $payload etc.).
+ #
+ mem eval "
+ SELECT
+ int(sum(
+ CASE WHEN (is_without_rowid OR is_index) THEN nentry
+ ELSE leaf_entries
+ END
+ )) AS nentry,
+ int(sum(payload)) AS payload,
+ int(sum(ovfl_payload)) AS ovfl_payload,
+ max(mx_payload) AS mx_payload,
+ int(sum(ovfl_cnt)) as ovfl_cnt,
+ int(sum(leaf_pages)) AS leaf_pages,
+ int(sum(int_pages)) AS int_pages,
+ int(sum(ovfl_pages)) AS ovfl_pages,
+ int(sum(leaf_unused)) AS leaf_unused,
+ int(sum(int_unused)) AS int_unused,
+ int(sum(ovfl_unused)) AS ovfl_unused,
+ int(sum(gap_cnt)) AS gap_cnt,
+ int(sum(compressed_size)) AS compressed_size,
+ int(max(depth)) AS depth,
+ count(*) AS cnt
+ FROM space_used WHERE $where" {} {}
+
+ # Output the sub-report title, nicely decorated with * characters.
+ #
+ puts ""
+ titleline $title
+ puts ""
+
+ # Calculate statistics and store the results in TCL variables, as follows:
+ #
+ # total_pages: Database pages consumed.
+ # total_pages_percent: Pages consumed as a percentage of the file.
+ # storage: Bytes consumed.
+ # payload_percent: Payload bytes used as a percentage of $storage.
+ # total_unused: Unused bytes on pages.
+ # avg_payload: Average payload per btree entry.
+ # avg_fanout: Average fanout for internal pages.
+ # avg_unused: Average unused bytes per btree entry.
+ # avg_meta: Average metadata overhead per entry.
+ # ovfl_cnt_percent: Percentage of btree entries that use overflow pages.
+ #
+ set total_pages [expr {$leaf_pages+$int_pages+$ovfl_pages}]
+ set total_pages_percent [percent $total_pages $file_pgcnt]
+ set storage [expr {$total_pages*$pageSize}]
+ set payload_percent [percent $payload $storage {of storage consumed}]
+ set total_unused [expr {$ovfl_unused+$int_unused+$leaf_unused}]
+ set avg_payload [divide $payload $nentry]
+ set avg_unused [divide $total_unused $nentry]
+ set total_meta [expr {$storage - $payload - $total_unused}]
+ set total_meta [expr {$total_meta + 4*($ovfl_pages - $ovfl_cnt)}]
+ set meta_percent [percent $total_meta $storage {of metadata}]
+ set avg_meta [divide $total_meta $nentry]
+ if {$int_pages>0} {
+ # TODO: Is this formula correct?
+ set nTab [mem eval "
+ SELECT count(*) FROM (
+ SELECT DISTINCT tblname FROM space_used WHERE $where AND is_index=0
+ )
+ "]
+ set avg_fanout [mem eval "
+ SELECT (sum(leaf_pages+int_pages)-$nTab)/sum(int_pages) FROM space_used
+ WHERE $where
+ "]
+ set avg_fanout [format %.2f $avg_fanout]
+ }
+ set ovfl_cnt_percent [percent $ovfl_cnt $nentry {of all entries}]
+
+ # Print out the sub-report statistics.
+ #
+ statline {Percentage of total database} $total_pages_percent
+ statline {Number of entries} $nentry
+ statline {Bytes of storage consumed} $storage
+ if {$compressed_size!=$storage} {
+ set compressed_size [expr {$compressed_size+$compressOverhead*$total_pages}]
+ set pct [expr {$compressed_size*100.0/$storage}]
+ set pct [format {%5.1f%%} $pct]
+ statline {Bytes used after compression} $compressed_size $pct
+ }
+ statline {Bytes of payload} $payload $payload_percent
+ statline {Bytes of metadata} $total_meta $meta_percent
+ if {$cnt==1} {statline {B-tree depth} $depth}
+ statline {Average payload per entry} $avg_payload
+ statline {Average unused bytes per entry} $avg_unused
+ statline {Average metadata per entry} $avg_meta
+ if {[info exists avg_fanout]} {
+ statline {Average fanout} $avg_fanout
+ }
+ if {$showFrag && $total_pages>1} {
+ set fragmentation [percent $gap_cnt [expr {$total_pages-1}]]
+ statline {Non-sequential pages} $gap_cnt $fragmentation
+ }
+ statline {Maximum payload per entry} $mx_payload
+ statline {Entries that use overflow} $ovfl_cnt $ovfl_cnt_percent
+ if {$int_pages>0} {
+ statline {Index pages used} $int_pages
+ }
+ statline {Primary pages used} $leaf_pages
+ statline {Overflow pages used} $ovfl_pages
+ statline {Total pages used} $total_pages
+ if {$int_unused>0} {
+ set int_unused_percent [
+ percent $int_unused [expr {$int_pages*$pageSize}] {of index space}]
+ statline "Unused bytes on index pages" $int_unused $int_unused_percent
+ }
+ statline "Unused bytes on primary pages" $leaf_unused [
+ percent $leaf_unused [expr {$leaf_pages*$pageSize}] {of primary space}]
+ statline "Unused bytes on overflow pages" $ovfl_unused [
+ percent $ovfl_unused [expr {$ovfl_pages*$pageSize}] {of overflow space}]
+ statline "Unused bytes on all pages" $total_unused [
+ percent $total_unused $storage {of all space}]
+ return 1
+}
+
+# Calculate the overhead in pages caused by auto-vacuum.
+#
+# This procedure calculates and returns the number of pages used by the
+# auto-vacuum 'pointer-map'. If the database does not support auto-vacuum,
+# then 0 is returned. The two arguments are the size of the database file in
+# pages and the page size used by the database (in bytes).
+proc autovacuum_overhead {filePages pageSize} {
+
+ # Set $autovacuum to non-zero for databases that support auto-vacuum.
+ set autovacuum [db one {PRAGMA auto_vacuum}]
+
+ # If the database is not an auto-vacuum database or the file consists
+ # of one page only then there is no overhead for auto-vacuum. Return zero.
+ if {0==$autovacuum || $filePages==1} {
+ return 0
+ }
+
+ # The number of entries on each pointer map page. The layout of the
+ # database file is one pointer-map page, followed by $ptrsPerPage other
+ # pages, followed by a pointer-map page etc. The first pointer-map page
+ # is the second page of the file overall.
+ set ptrsPerPage [expr {double($pageSize/5)}]
+
+ # Return the number of pointer map pages in the database.
+ return [expr {wide(ceil(($filePages-1.0)/($ptrsPerPage+1.0)))}]
+}
+
+
+# Calculate the summary statistics for the database and store the results
+# in TCL variables. They are output below. Variables are as follows:
+#
+# pageSize: Size of each page in bytes.
+# file_bytes: File size in bytes.
+# file_pgcnt: Number of pages in the file.
+# file_pgcnt2: Number of pages in the file (calculated).
+# av_pgcnt: Pages consumed by the auto-vacuum pointer-map.
+# av_percent: Percentage of the file consumed by auto-vacuum pointer-map.
+# inuse_pgcnt: Data pages in the file.
+# inuse_percent: Percentage of pages used to store data.
+# free_pgcnt: Free pages calculated as (<total pages> - <in-use pages>)
+# free_pgcnt2: Free pages in the file according to the file header.
+# free_percent: Percentage of file consumed by free pages (calculated).
+# free_percent2: Percentage of file consumed by free pages (header).
+# ntable: Number of tables in the db.
+# nindex: Number of indices in the db.
+# nautoindex: Number of indices created automatically.
+# nmanindex: Number of indices created manually.
+# user_payload: Number of bytes of payload in table btrees
+# (not including sqlite_schema)
+# user_percent: $user_payload as a percentage of total file size.
+
+### The following, setting $file_bytes based on the actual size of the file
+### on disk, causes this tool to choke on zipvfs databases. So set it based
+### on the return of [PRAGMA page_count] instead.
+if 0 {
+ set file_bytes [file size $file_to_analyze]
+ set file_pgcnt [expr {$file_bytes/$pageSize}]
+}
+set file_pgcnt [db one {PRAGMA page_count}]
+set file_bytes [expr {$file_pgcnt * $pageSize}]
+
+set av_pgcnt [autovacuum_overhead $file_pgcnt $pageSize]
+set av_percent [percent $av_pgcnt $file_pgcnt]
+
+set sql {SELECT sum(leaf_pages+int_pages+ovfl_pages) FROM space_used}
+set inuse_pgcnt [expr {wide([mem eval $sql])}]
+set inuse_percent [percent $inuse_pgcnt $file_pgcnt]
+
+set free_pgcnt [expr {$file_pgcnt-$inuse_pgcnt-$av_pgcnt}]
+set free_percent [percent $free_pgcnt $file_pgcnt]
+set free_pgcnt2 [db one {PRAGMA freelist_count}]
+set free_percent2 [percent $free_pgcnt2 $file_pgcnt]
+
+set file_pgcnt2 [expr {$inuse_pgcnt+$free_pgcnt2+$av_pgcnt}]
+
+# Account for the lockbyte page
+if {$file_pgcnt2*$pageSize>1073742335} {incr file_pgcnt2}
+
+set ntable [db eval {SELECT count(*)+1 FROM sqlite_schema WHERE type='table'}]
+set nindex [db eval {SELECT count(*) FROM sqlite_schema WHERE type='index'}]
+set sql {SELECT count(*) FROM sqlite_schema WHERE name LIKE 'sqlite_autoindex%'}
+set nautoindex [db eval $sql]
+set nmanindex [expr {$nindex-$nautoindex}]
+
+# set total_payload [mem eval "SELECT sum(payload) FROM space_used"]
+set user_payload [mem one {SELECT int(sum(payload)) FROM space_used
+ WHERE NOT is_index AND name NOT LIKE 'sqlite_schema'}]
+set user_percent [percent $user_payload $file_bytes]
+
+# Output the summary statistics calculated above.
+#
+puts "/** Disk-Space Utilization Report For $root_filename"
+puts ""
+statline {Page size in bytes} $pageSize
+statline {Pages in the whole file (measured)} $file_pgcnt
+statline {Pages in the whole file (calculated)} $file_pgcnt2
+statline {Pages that store data} $inuse_pgcnt $inuse_percent
+statline {Pages on the freelist (per header)} $free_pgcnt2 $free_percent2
+statline {Pages on the freelist (calculated)} $free_pgcnt $free_percent
+statline {Pages of auto-vacuum overhead} $av_pgcnt $av_percent
+statline {Number of tables in the database} $ntable
+statline {Number of indices} $nindex
+statline {Number of defined indices} $nmanindex
+statline {Number of implied indices} $nautoindex
+if {$isCompressed} {
+ statline {Size of uncompressed content in bytes} $file_bytes
+ set efficiency [percent $true_file_size $file_bytes]
+ statline {Size of compressed file on disk} $true_file_size $efficiency
+} else {
+ statline {Size of the file in bytes} $file_bytes
+}
+statline {Bytes of user payload stored} $user_payload $user_percent
+
+# Output table rankings
+#
+puts ""
+titleline "Page counts for all tables with their indices"
+puts ""
+mem eval {SELECT tblname, count(*) AS cnt,
+ int(sum(int_pages+leaf_pages+ovfl_pages)) AS size
+ FROM space_used GROUP BY tblname ORDER BY size+0 DESC, tblname} {} {
+ statline [string toupper $tblname] $size [percent $size $file_pgcnt]
+}
+puts ""
+titleline "Page counts for all tables and indices separately"
+puts ""
+mem eval {
+ SELECT
+ upper(name) AS nm,
+ int(int_pages+leaf_pages+ovfl_pages) AS size
+ FROM space_used
+ ORDER BY size+0 DESC, name} {} {
+ statline $nm $size [percent $size $file_pgcnt]
+}
+if {$isCompressed} {
+ puts ""
+ titleline "Bytes of disk space used after compression"
+ puts ""
+ set csum 0
+ mem eval {SELECT tblname,
+ int(sum(compressed_size)) +
+ $compressOverhead*sum(int_pages+leaf_pages+ovfl_pages)
+ AS csize
+ FROM space_used GROUP BY tblname ORDER BY csize+0 DESC, tblname} {} {
+ incr csum $csize
+ statline [string toupper $tblname] $csize [percent $csize $true_file_size]
+ }
+ set overhead [expr {$true_file_size - $csum}]
+ if {$overhead>0} {
+ statline {Header and free space} $overhead [percent $overhead $true_file_size]
+ }
+}
+
+# Output subreports
+#
+if {$nindex>0} {
+ subreport {All tables and indices} 1 0
+}
+subreport {All tables} {NOT is_index} 0
+if {$nindex>0} {
+ subreport {All indices} {is_index} 0
+}
+foreach tbl [mem eval {SELECT DISTINCT tblname name FROM space_used
+ ORDER BY name}] {
+ set qn [quote $tbl]
+ set name [string toupper $tbl]
+ set n [mem eval {SELECT count(*) FROM space_used WHERE tblname=$tbl}]
+ if {$n>1} {
+ set idxlist [mem eval "SELECT name FROM space_used
+ WHERE tblname='$qn' AND is_index
+ ORDER BY 1"]
+ subreport "Table $name and all its indices" "tblname='$qn'" 0
+ subreport "Table $name w/o any indices" "name='$qn'" 1
+ if {[llength $idxlist]>1} {
+ subreport "Indices of table $name" "tblname='$qn' AND is_index" 0
+ }
+ foreach idx $idxlist {
+ set qidx [quote $idx]
+ subreport "Index [string toupper $idx] of table $name" "name='$qidx'" 1
+ }
+ } else {
+ subreport "Table $name" "name='$qn'" 1
+ }
+}
+
+# Output instructions on what the numbers above mean.
+#
+puts ""
+titleline Definitions
+puts {
+Page size in bytes
+
+ The number of bytes in a single page of the database file.
+ Usually 1024.
+
+Number of pages in the whole file
+}
+puts " The number of $pageSize-byte pages that go into forming the complete
+ database"
+puts {
+Pages that store data
+
+ The number of pages that store data, either as primary B*Tree pages or
+ as overflow pages. The number at the right is the data pages divided by
+ the total number of pages in the file.
+
+Pages on the freelist
+
+ The number of pages that are not currently in use but are reserved for
+ future use. The percentage at the right is the number of freelist pages
+ divided by the total number of pages in the file.
+
+Pages of auto-vacuum overhead
+
+ The number of pages that store data used by the database to facilitate
+ auto-vacuum. This is zero for databases that do not support auto-vacuum.
+
+Number of tables in the database
+
+ The number of tables in the database, including the SQLITE_SCHEMA table
+ used to store schema information.
+
+Number of indices
+
+ The total number of indices in the database.
+
+Number of defined indices
+
+ The number of indices created using an explicit CREATE INDEX statement.
+
+Number of implied indices
+
+ The number of indices used to implement PRIMARY KEY or UNIQUE constraints
+ on tables.
+
+Size of the file in bytes
+
+ The total amount of disk space used by the entire database files.
+
+Bytes of user payload stored
+
+ The total number of bytes of user payload stored in the database. The
+ schema information in the SQLITE_SCHEMA table is not counted when
+ computing this number. The percentage at the right shows the payload
+ divided by the total file size.
+
+Percentage of total database
+
+ The amount of the complete database file that is devoted to storing
+ information described by this category.
+
+Number of entries
+
+ The total number of B-Tree key/value pairs stored under this category.
+
+Bytes of storage consumed
+
+ The total amount of disk space required to store all B-Tree entries
+ under this category. The is the total number of pages used times
+ the pages size.
+
+Bytes of payload
+
+ The amount of payload stored under this category. Payload is the data
+ part of table entries and the key part of index entries. The percentage
+ at the right is the bytes of payload divided by the bytes of storage
+ consumed.
+
+Bytes of metadata
+
+ The amount of formatting and structural information stored in the
+ table or index. Metadata includes the btree page header, the cell pointer
+ array, the size field for each cell, the left child pointer or non-leaf
+ cells, the overflow pointers for overflow cells, and the rowid value for
+ rowid table cells. In other words, metadata is everything that is neither
+ unused space nor content. The record header in the payload is counted as
+ content, not metadata.
+
+Average payload per entry
+
+ The average amount of payload on each entry. This is just the bytes of
+ payload divided by the number of entries.
+
+Average unused bytes per entry
+
+ The average amount of free space remaining on all pages under this
+ category on a per-entry basis. This is the number of unused bytes on
+ all pages divided by the number of entries.
+
+Non-sequential pages
+
+ The number of pages in the table or index that are out of sequence.
+ Many filesystems are optimized for sequential file access so a small
+ number of non-sequential pages might result in faster queries,
+ especially for larger database files that do not fit in the disk cache.
+ Note that after running VACUUM, the root page of each table or index is
+ at the beginning of the database file and all other pages are in a
+ separate part of the database file, resulting in a single non-
+ sequential page.
+
+Maximum payload per entry
+
+ The largest payload size of any entry.
+
+Entries that use overflow
+
+ The number of entries that user one or more overflow pages.
+
+Total pages used
+
+ This is the number of pages used to hold all information in the current
+ category. This is the sum of index, primary, and overflow pages.
+
+Index pages used
+
+ This is the number of pages in a table B-tree that hold only key (rowid)
+ information and no data.
+
+Primary pages used
+
+ This is the number of B-tree pages that hold both key and data.
+
+Overflow pages used
+
+ The total number of overflow pages used for this category.
+
+Unused bytes on index pages
+
+ The total number of bytes of unused space on all index pages. The
+ percentage at the right is the number of unused bytes divided by the
+ total number of bytes on index pages.
+
+Unused bytes on primary pages
+
+ The total number of bytes of unused space on all primary pages. The
+ percentage at the right is the number of unused bytes divided by the
+ total number of bytes on primary pages.
+
+Unused bytes on overflow pages
+
+ The total number of bytes of unused space on all overflow pages. The
+ percentage at the right is the number of unused bytes divided by the
+ total number of bytes on overflow pages.
+
+Unused bytes on all pages
+
+ The total number of bytes of unused space on all primary and overflow
+ pages. The percentage at the right is the number of unused bytes
+ divided by the total number of bytes.
+}
+
+# Output a dump of the in-memory database. This can be used for more
+# complex offline analysis.
+#
+titleline {}
+puts "The entire text of this report can be sourced into any SQL database"
+puts "engine for further analysis. All of the text above is an SQL comment."
+puts "The data used to generate this report follows:"
+puts "*/"
+puts "BEGIN;"
+puts $tabledef
+unset -nocomplain x
+mem eval {SELECT * FROM space_used} x {
+ puts -nonewline "INSERT INTO space_used VALUES"
+ set sep (
+ foreach col $x(*) {
+ set v $x($col)
+ if {$v=="" || ![string is double $v]} {set v '[quote $v]'}
+ puts -nonewline $sep$v
+ set sep ,
+ }
+ puts ");"
+}
+puts "COMMIT;"
+
+} err]} {
+ puts "ERROR: $err"
+ puts $errorInfo
+ exit 1
+}
Property changes on: trunk/Master/tlpkg/tltcl/bin/sqlite3_analyzer
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Deleted: trunk/Master/tlpkg/tltcl/bin/tcl86.dll
===================================================================
(Binary files differ)
Added: trunk/Master/tlpkg/tltcl/bin/tcl90.dll
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/bin/tcl90.dll
===================================================================
--- trunk/Master/tlpkg/tltcl/bin/tcl90.dll 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/bin/tcl90.dll 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/bin/tcl90.dll
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+application/zip
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/bin/tcl9tk90.dll
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/bin/tcl9tk90.dll
===================================================================
--- trunk/Master/tlpkg/tltcl/bin/tcl9tk90.dll 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/bin/tcl9tk90.dll 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/bin/tcl9tk90.dll
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+application/zip
\ No newline at end of property
Modified: trunk/Master/tlpkg/tltcl/bin/tclsh.exe
===================================================================
(Binary files differ)
Deleted: trunk/Master/tlpkg/tltcl/bin/tclsh86.exe
===================================================================
(Binary files differ)
Added: trunk/Master/tlpkg/tltcl/bin/tclsh90.exe
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/bin/tclsh90.exe
===================================================================
--- trunk/Master/tlpkg/tltcl/bin/tclsh90.exe 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/bin/tclsh90.exe 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/bin/tclsh90.exe
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+application/vnd.microsoft.portable-executable
\ No newline at end of property
Deleted: trunk/Master/tlpkg/tltcl/bin/tk86.dll
===================================================================
(Binary files differ)
Modified: trunk/Master/tlpkg/tltcl/bin/wish.exe
===================================================================
(Binary files differ)
Deleted: trunk/Master/tlpkg/tltcl/bin/wish86.exe
===================================================================
(Binary files differ)
Added: trunk/Master/tlpkg/tltcl/bin/wish90.exe
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/bin/wish90.exe
===================================================================
--- trunk/Master/tlpkg/tltcl/bin/wish90.exe 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/bin/wish90.exe 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/bin/wish90.exe
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+application/vnd.microsoft.portable-executable
\ No newline at end of property
Modified: trunk/Master/tlpkg/tltcl/bin/zlib1.dll
===================================================================
(Binary files differ)
Modified: trunk/Master/tlpkg/tltcl/lib/dde1.4/libtcldde14.dll.a
===================================================================
(Binary files differ)
Modified: trunk/Master/tlpkg/tltcl/lib/dde1.4/pkgIndex.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/dde1.4/pkgIndex.tcl 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/dde1.4/pkgIndex.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -1,12 +1,12 @@
if {[info sharedlibextension] != ".dll"} return
if {[package vsatisfies [package provide Tcl] 9.0-]} {
- package ifneeded dde 1.4.4 \
+ package ifneeded dde 1.4.5 \
[list load [file join $dir tcl9dde14.dll] Dde]
} elseif {![package vsatisfies [package provide Tcl] 8.7]
&& [::tcl::pkgconfig get debug]} {
- package ifneeded dde 1.4.4 \
+ package ifneeded dde 1.4.5 \
[list load [file join $dir tcldde14g.dll] Dde]
} else {
- package ifneeded dde 1.4.4 \
+ package ifneeded dde 1.4.5 \
[list load [file join $dir tcldde14.dll] Dde]
}
Added: trunk/Master/tlpkg/tltcl/lib/dde1.4/tcl9dde14.dll
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/dde1.4/tcl9dde14.dll
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/dde1.4/tcl9dde14.dll 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/dde1.4/tcl9dde14.dll 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/dde1.4/tcl9dde14.dll
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+application/vnd.microsoft.portable-executable
\ No newline at end of property
Modified: trunk/Master/tlpkg/tltcl/lib/dde1.4/tcldde14.dll
===================================================================
(Binary files differ)
Added: trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/itcl.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/itcl.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/itcl.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,151 @@
+#
+# itcl.tcl
+# ----------------------------------------------------------------------
+# Invoked automatically upon startup to customize the interpreter
+# for [incr Tcl].
+# ----------------------------------------------------------------------
+# AUTHOR: Michael J. McLennan
+# Bell Labs Innovations for Lucent Technologies
+# mmclennan at lucent.com
+# http://www.tcltk.com/itcl
+# ----------------------------------------------------------------------
+# Copyright (c) 1993-1998 Lucent Technologies, Inc.
+# ======================================================================
+# See the file "license.terms" for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+proc ::itcl::delete_helper { name args } {
+ ::itcl::delete object $name
+}
+
+# ----------------------------------------------------------------------
+# USAGE: local <className> <objName> ?<arg> <arg>...?
+#
+# Creates a new object called <objName> in class <className>, passing
+# the remaining <arg>'s to the constructor. Unlike the usual
+# [incr Tcl] objects, however, an object created by this procedure
+# will be automatically deleted when the local call frame is destroyed.
+# This command is useful for creating objects that should only remain
+# alive until a procedure exits.
+# ----------------------------------------------------------------------
+proc ::itcl::local {class name args} {
+ set ptr [uplevel [list $class $name] $args]
+ uplevel [list set itcl-local-$ptr $ptr]
+ set cmd [uplevel namespace which -command $ptr]
+ uplevel [list trace add variable itcl-local-$ptr unset \
+ "::itcl::delete_helper $cmd"]
+ return $ptr
+}
+
+# ----------------------------------------------------------------------
+# auto_mkindex
+# ----------------------------------------------------------------------
+# Define Itcl commands that will be recognized by the auto_mkindex
+# parser in Tcl...
+#
+
+#
+# USAGE: itcl::class name body
+# Adds an entry for the given class declaration.
+#
+foreach __cmd {itcl::class class itcl::type type ictl::widget widget itcl::widgetadaptor widgetadaptor itcl::extendedclass extendedclass} {
+ auto_mkindex_parser::command $__cmd {name body} {
+ variable index
+ variable scriptFile
+ append index "set [list auto_index([fullname $name])]"
+ append index " \[list source -encoding utf-8 \[file join \$dir [list $scriptFile]\]\]\n"
+
+ variable parser
+ variable contextStack
+ set contextStack [linsert $contextStack 0 $name]
+ $parser eval $body
+ set contextStack [lrange $contextStack 1 end]
+ }
+}
+
+#
+# USAGE: itcl::body name arglist body
+# Adds an entry for the given method/proc body.
+#
+foreach __cmd {itcl::body body} {
+ auto_mkindex_parser::command $__cmd {name arglist body} {
+ variable index
+ variable scriptFile
+ append index "set [list auto_index([fullname $name])]"
+ append index " \[list source -encoding utf-8 \[file join \$dir [list $scriptFile]\]\]\n"
+ }
+}
+
+#
+# USAGE: itcl::configbody name arglist body
+# Adds an entry for the given method/proc body.
+#
+foreach __cmd {itcl::configbody configbody} {
+ auto_mkindex_parser::command $__cmd {name body} {
+ variable index
+ variable scriptFile
+ append index "set [list auto_index([fullname $name])]"
+ append index " \[list source -encoding utf-8 \[file join \$dir [list $scriptFile]\]\]\n"
+ }
+}
+
+#
+# USAGE: ensemble name ?body?
+# Adds an entry to the auto index list for the given ensemble name.
+#
+foreach __cmd {itcl::ensemble ensemble} {
+ auto_mkindex_parser::command $__cmd {name {body ""}} {
+ variable index
+ variable scriptFile
+ append index "set [list auto_index([fullname $name])]"
+ append index " \[list source -encoding utf-8 \[file join \$dir [list $scriptFile]\]\]\n"
+ }
+}
+
+#
+# USAGE: public arg ?arg arg...?
+# protected arg ?arg arg...?
+# private arg ?arg arg...?
+#
+# Evaluates the arguments as commands, so we can recognize proc
+# declarations within classes.
+#
+foreach __cmd {public protected private} {
+ auto_mkindex_parser::command $__cmd {args} {
+ variable parser
+ $parser eval $args
+ }
+}
+
+# SF bug #246 unset variable __cmd to avoid problems in user programs!!
+unset __cmd
+
+# ----------------------------------------------------------------------
+# auto_import
+# ----------------------------------------------------------------------
+# This procedure overrides the usual "auto_import" function in the
+# Tcl library. It is invoked during "namespace import" to make see
+# if the imported commands reside in an autoloaded library. If so,
+# stubs are created to represent the commands. Executing a stub
+# later on causes the real implementation to be autoloaded.
+#
+# Arguments -
+# pattern The pattern of commands being imported (like "foo::*")
+# a canonical namespace as returned by [namespace current]
+
+proc auto_import {pattern} {
+ global auto_index
+
+ set ns [uplevel namespace current]
+ set patternList [auto_qualify $pattern $ns]
+
+ auto_load_index
+
+ foreach pattern $patternList {
+ foreach name [array names auto_index $pattern] {
+ if {"" == [info commands $name]} {
+ ::itcl::import::stub create $name
+ }
+ }
+ }
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/itcl.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/itclConfig.sh
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/itclConfig.sh (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/itclConfig.sh 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,67 @@
+# itclConfig.sh --
+#
+# This shell script (for sh) is generated automatically by Itcl's
+# configure script. It will create shell variables for most of
+# the configuration options discovered by the configure script.
+# This script is intended to be included by the configure scripts
+# for Itcl extensions so that they don't have to figure this all
+# out for themselves. This file does not duplicate information
+# already provided by tclConfig.sh, so you may need to use that
+# file in addition to this one.
+#
+# The information in this file is specific to a single platform.
+
+# Itcl's version number.
+itcl_VERSION='4.3.2'
+ITCL_VERSION='4.3.2'
+
+# The name of the Itcl library (may be either a .a file or a shared library):
+itcl_LIB_FILE=tcl9itcl432.dll
+ITCL_LIB_FILE=tcl9itcl432.dll
+
+# String to pass to linker to pick up the Itcl library from its
+# build directory.
+itcl_BUILD_LIB_SPEC='-LX:/tcltk/tcl9.0.1/win/pkgs/itcl4.3.2 -litcl432'
+ITCL_BUILD_LIB_SPEC='-LX:/tcltk/tcl9.0.1/win/pkgs/itcl4.3.2 -litcl432'
+
+# String to pass to linker to pick up the Itcl library from its
+# installed directory.
+itcl_LIB_SPEC='-LX:/tcltk/lib/itcl4.3.2 -litcl432'
+ITCL_LIB_SPEC='-LX:/tcltk/lib/itcl4.3.2 -litcl432'
+
+# The name of the Itcl stub library (a .a file):
+itcl_STUB_LIB_FILE=libitclstub.a
+ITCL_STUB_LIB_FILE=libitclstub.a
+
+# String to pass to linker to pick up the Itcl stub library from its
+# build directory.
+itcl_BUILD_STUB_LIB_SPEC='-LX:/tcltk/tcl9.0.1/win/pkgs/itcl4.3.2 -litclstub'
+ITCL_BUILD_STUB_LIB_SPEC='-LX:/tcltk/tcl9.0.1/win/pkgs/itcl4.3.2 -litclstub'
+
+# String to pass to linker to pick up the Itcl stub library from its
+# installed directory.
+itcl_STUB_LIB_SPEC='-LX:/tcltk/lib/itcl4.3.2 -litclstub'
+ITCL_STUB_LIB_SPEC='-LX:/tcltk/lib/itcl4.3.2 -litclstub'
+
+# String to pass to linker to pick up the Itcl stub library from its
+# build directory.
+itcl_BUILD_STUB_LIB_PATH='X:/tcltk/tcl9.0.1/win/pkgs/itcl4.3.2/libitclstub.a'
+ITCL_BUILD_STUB_LIB_PATH='X:/tcltk/tcl9.0.1/win/pkgs/itcl4.3.2/libitclstub.a'
+
+# String to pass to linker to pick up the Itcl stub library from its
+# installed directory.
+itcl_STUB_LIB_PATH='X:/tcltk/lib/itcl4.3.2/libitclstub.a'
+ITCL_STUB_LIB_PATH='X:/tcltk/lib/itcl4.3.2/libitclstub.a'
+
+# Location of the top-level source directories from which [incr Tcl]
+# was built. This is the directory that contains generic, unix, etc.
+# If [incr Tcl] was compiled in a different place than the directory
+# containing the source files, this points to the location of the sources,
+# not the location where [incr Tcl] was compiled.
+itcl_SRC_DIR='/x/tcltk/tcl9.0.1/pkgs/itcl4.3.2'
+ITCL_SRC_DIR='/x/tcltk/tcl9.0.1/pkgs/itcl4.3.2'
+
+# String to pass to the compiler so that an extension can
+# find installed Itcl headers.
+itcl_INCLUDE_SPEC=''
+ITCL_INCLUDE_SPEC=''
Property changes on: trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/itclConfig.sh
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/itclHullCmds.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/itclHullCmds.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/itclHullCmds.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,562 @@
+#
+# itclHullCmds.tcl
+# ----------------------------------------------------------------------
+# Invoked automatically upon startup to customize the interpreter
+# for [incr Tcl] when one of setupcomponent or createhull is called.
+# ----------------------------------------------------------------------
+# AUTHOR: Arnulf P. Wiedemann
+#
+# ----------------------------------------------------------------------
+# Copyright (c) 2008 Arnulf P. Wiedemann
+# ======================================================================
+# See the file "license.terms" for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package require Tk 8.6 9
+
+namespace eval ::itcl::internal::commands {
+
+# ======================= widgetDeleted ===========================
+
+proc widgetDeleted {oldName newName op} {
+ # The widget is beeing deleted, so we have to delete the object
+ # which had the widget as itcl_hull too!
+ # We have to get the real name from for example
+ # ::itcl::internal::widgets::hull1.lw
+ # we need only .lw here
+
+#puts stderr "widgetDeleted!$oldName!$newName!$op!"
+ set cmdName [namespace tail $oldName]
+ set flds [split $cmdName {.}]
+ set cmdName .[join [lrange $flds 1 end] {.}]
+#puts stderr "DELWIDGET![namespace current]!$cmdName![::info command $cmdName]!"
+ rename $cmdName {}
+}
+
+}
+
+namespace eval ::itcl::builtin {
+
+# ======================= createhull ===========================
+# the hull widget is a tk widget which is the (mega) widget handled behind the itcl
+# extendedclass/itcl widget.
+# It is created be renaming the itcl class object to a temporary name <itcl object name>_
+# creating the widget with the
+# appropriate options and the installing that as the "hull" widget (the container)
+# All the options in args and the options delegated to component itcl_hull are used
+# Then a unique name (hull_widget_name) in the itcl namespace is created for widget:
+# ::itcl::internal::widgets::hull<unique number><namespace tail path>
+# and widget is renamed to that name
+# Finally the <itcl object name>_ is renamed to the original <itcl object name> again
+# Component itcl_hull is created if not existent
+# itcl_hull is set to the hull_widget_name and the <itcl object name>
+# is returned to the caller
+# ==============================================================
+
+proc createhull {widget_type path args} {
+ variable hullCount
+ upvar this this
+ upvar win win
+
+
+#puts stderr "il-1![::info level -1]!$this!"
+#puts stderr "createhull!$widget_type!$path!$args!$this![::info command $this]!"
+#puts stderr "ns1![uplevel 1 namespace current]!"
+#puts stderr "ns2![uplevel 2 namespace current]!"
+#puts stderr "ns3![uplevel 3 namespace current]!"
+#puts stderr "level-1![::info level -1]!"
+#puts stderr "level-2![::info level -2]!"
+# set my_this [namespace tail $this]
+ set my_this $this
+ set tmp $my_this
+#puts stderr "II![::info command $this]![::info command $tmp]!"
+#puts stderr "rename1!rename $my_this ${tmp}_!"
+ rename ::$my_this ${tmp}_
+ set options [list]
+ foreach {option_name value} $args {
+ switch -glob -- $option_name {
+ -class {
+ lappend options $option_name [namespace tail $value]
+ }
+ -* {
+ lappend options $option_name $value
+ }
+ default {
+ return -code error "bad option name\"$option_name\" options must start with a \"-\""
+ }
+ }
+ }
+ set my_win [namespace tail $path]
+ set cmd [list $widget_type $my_win]
+#puts stderr "my_win!$my_win!cmd!$cmd!$path!"
+ if {[llength $options] > 0} {
+ lappend cmd {*}$options
+ }
+ set widget [uplevel 1 $cmd]
+#puts stderr "widget!$widget!"
+ trace add command $widget delete ::itcl::internal::commands::widgetDeleted
+ set opts [uplevel 1 info delegated options]
+ foreach entry $opts {
+ foreach {optName compName} $entry break
+ if {$compName eq "itcl_hull"} {
+ set optInfos [uplevel 1 info delegated option $optName]
+ set realOptName [lindex $optInfos 4]
+ # strip off the "-" at the beginning
+ set myOptName [string range $realOptName 1 end]
+ set my_opt_val [option get $my_win $myOptName *]
+ if {$my_opt_val ne ""} {
+ $my_win configure -$myOptName $my_opt_val
+ }
+ }
+ }
+ set idx 1
+ while {1} {
+ set widgetName ::itcl::internal::widgets::hull${idx}$my_win
+#puts stderr "widgetName!$widgetName!"
+ if {[string length [::info command $widgetName]] == 0} {
+ break
+ }
+ incr idx
+ }
+#puts stderr "rename2!rename $widget $widgetName!"
+ set dorename 0
+ rename $widget $widgetName
+#puts stderr "rename3!rename ${tmp}_ $tmp![::info command ${tmp}_]!my_this!$my_this!"
+ rename ${tmp}_ ::$tmp
+ set exists [uplevel 1 ::info exists itcl_hull]
+ if {!$exists} {
+ # that does not yet work, beacause of problems with resolving
+ ::itcl::addcomponent $my_this itcl_hull
+ }
+ upvar itcl_hull itcl_hull
+ ::itcl::setcomponent $my_this itcl_hull $widgetName
+#puts stderr "IC![::info command $my_win]!"
+ set exists [uplevel 1 ::info exists itcl_interior]
+ if {!$exists} {
+ # that does not yet work, beacause of problems with resolving
+ ::itcl::addcomponent $this itcl_interior
+ }
+ upvar itcl_interior itcl_interior
+ set itcl_interior $my_win
+#puts stderr "hull end!win!$win!itcl_hull!$itcl_hull!itcl_interior!$itcl_interior!"
+ return $my_win
+}
+
+# ======================= addToItclOptions ===========================
+
+proc addToItclOptions {my_class my_win myOptions argsDict} {
+ upvar win win
+ upvar itcl_hull itcl_hull
+
+ set opt_lst [list configure]
+ foreach opt [lsort $myOptions] {
+#puts stderr "IOPT!$opt!$my_class!$my_win![::itcl::is class $my_class]!"
+ set isClass [::itcl::is class $my_class]
+ set found 0
+ if {$isClass} {
+ if {[catch {
+ set resource [namespace eval $my_class info option $opt -resource]
+ set class [namespace eval $my_class info option $opt -class]
+ set default_val [uplevel 2 info option $opt -default]
+ set found 1
+ } msg]} {
+# puts stderr "MSG!$opt!$my_class!$msg!"
+ }
+ } else {
+ set tmp_win [uplevel #0 $my_class .___xx]
+
+ set my_info [$tmp_win configure $opt]
+ set resource [lindex $my_info 1]
+ set class [lindex $my_info 2]
+ set default_val [lindex $my_info 3]
+ uplevel #0 destroy $tmp_win
+ set found 1
+ }
+ if {$found} {
+ if {[catch {
+ set val [uplevel #0 ::option get $win $resource $class]
+ } msg]} {
+ set val ""
+ }
+ if {[::dict exists $argsDict $opt]} {
+ # we have an explicitly set option
+ set val [::dict get $argsDict $opt]
+ } else {
+ if {[string length $val] == 0} {
+ set val $default_val
+ }
+ }
+ set ::itcl::internal::variables::${my_win}::itcl_options($opt) $val
+ set ::itcl::internal::variables::${my_win}::__itcl_option_infos($opt) [list $resource $class $default_val]
+#puts stderr "OPT1!$opt!$val!"
+# uplevel 1 [list set itcl_options($opt) [list $val]]
+ if {[catch {uplevel 1 $win configure $opt [list $val]} msg]} {
+#puts stderr "addToItclOptions ERR!$msg!$my_class!$win!configure!$opt!$val!"
+ }
+ }
+ }
+}
+
+# ======================= setupcomponent ===========================
+
+proc setupcomponent {comp using widget_type path args} {
+ upvar this this
+ upvar win win
+ upvar itcl_hull itcl_hull
+
+#puts stderr "setupcomponent!$comp!$widget_type!$path!$args!$this!$win!$itcl_hull!"
+#puts stderr "CONT![uplevel 1 info context]!"
+#puts stderr "ns1![uplevel 1 namespace current]!"
+#puts stderr "ns2![uplevel 2 namespace current]!"
+#puts stderr "ns3![uplevel 3 namespace current]!"
+ set my_comp_object [lindex [uplevel 1 info context] 1]
+ if {[::info exists ::itcl::internal::component_objects($my_comp_object)]} {
+ set my_comp_object [set ::itcl::internal::component_objects($my_comp_object)]
+ } else {
+ set ::itcl::internal::component_objects($path) $my_comp_object
+ }
+ set options [list]
+ foreach {option_name value} $args {
+ switch -glob -- $option_name {
+ -* {
+ lappend options $option_name $value
+ }
+ default {
+ return -code error "bad option name\"$option_name\" options must start with a \"-\""
+ }
+ }
+ }
+ if {[llength $args]} {
+ set argsDict [dict create {*}$args]
+ } else {
+ set argsDict [dict create]
+ }
+ set cmd [list $widget_type $path]
+ if {[llength $options] > 0} {
+ lappend cmd {*}$options
+ }
+#puts stderr "cmd0![::info command $widget_type]!$path![::info command $path]!"
+#puts stderr "cmd1!$cmd!"
+# set my_comp [uplevel 3 $cmd]
+ set my_comp [uplevel #0 $cmd]
+#puts stderr 111![::info command $path]!
+ ::itcl::setcomponent $this $comp $my_comp
+ set opts [uplevel 1 info delegated options]
+ foreach entry $opts {
+ foreach {optName compName} $entry break
+ if {$compName eq $my_comp} {
+ set optInfos [uplevel 1 info delegated option $optName]
+ set realOptName [lindex $optInfos 4]
+ # strip off the "-" at the beginning
+ set myOptName [string range $realOptName 1 end]
+ set my_opt_val [option get $my_win $myOptName *]
+ if {$my_opt_val ne ""} {
+ $my_comp configure -$myOptName $my_opt_val
+ }
+ }
+ }
+ set my_class $widget_type
+ set my_parent_class [uplevel 1 namespace current]
+ if {[catch {
+ set myOptions [namespace eval $my_class {info classoptions}]
+ } msg]} {
+ set myOptions [list]
+ }
+ foreach entry [$path configure] {
+ foreach {opt dummy1 dummy2 dummy3} $entry break
+ lappend myOptions $opt
+ }
+#puts stderr "OPTS!$myOptions!"
+ addToItclOptions $widget_type $my_comp_object $myOptions $argsDict
+#puts stderr END!$path![::info command $path]!
+}
+
+proc itcl_initoptions {args} {
+puts stderr "ITCL_INITOPT!$args!"
+}
+
+# ======================= initoptions ===========================
+
+proc initoptions {args} {
+ upvar win win
+ upvar itcl_hull itcl_hull
+ upvar itcl_option_components itcl_option_components
+
+#puts stderr "INITOPT!!$win!"
+ if {[llength $args]} {
+ set argsDict [dict create {*}$args]
+ } else {
+ set argsDict [dict create]
+ }
+ set my_class [uplevel 1 namespace current]
+ set myOptions [namespace eval $my_class {info classoptions}]
+ if {[dict exists $::itcl::internal::dicts::classComponents $my_class]} {
+ set class_info_dict [dict get $::itcl::internal::dicts::classComponents $my_class]
+# set myOptions [lsort -unique [namespace eval $my_class {info options}]]
+ foreach comp [uplevel 1 info components] {
+ if {[dict exists $class_info_dict $comp -keptoptions]} {
+ foreach my_opt [dict get $class_info_dict $comp -keptoptions] {
+ if {[lsearch $myOptions $my_opt] < 0} {
+#puts stderr "KEOPT!$my_opt!"
+ lappend myOptions $my_opt
+ }
+ }
+ }
+ }
+ } else {
+ set class_info_dict [list]
+ }
+#puts stderr "OPTS!$win!$my_class![join [lsort $myOptions]] \n]!"
+ set opt_lst [list configure]
+ set my_win $win
+ foreach opt [lsort $myOptions] {
+ set found 0
+ if {[catch {
+ set resource [uplevel 1 info option $opt -resource]
+ set class [uplevel 1 info option $opt -class]
+ set default_val [uplevel 1 info option $opt -default]
+ set found 1
+ } msg]} {
+# puts stderr "MSG!$opt!$msg!"
+ }
+#puts stderr "OPT!$opt!$found!"
+ if {$found} {
+ if {[catch {
+ set val [uplevel #0 ::option get $my_win $resource $class]
+ } msg]} {
+ set val ""
+ }
+ if {[::dict exists $argsDict $opt]} {
+ # we have an explicitly set option
+ set val [::dict get $argsDict $opt]
+ } else {
+ if {[string length $val] == 0} {
+ set val $default_val
+ }
+ }
+ set ::itcl::internal::variables::${win}::itcl_options($opt) $val
+ set ::itcl::internal::variables::${win}::__itcl_option_infos($opt) [list $resource $class $default_val]
+#puts stderr "OPT1!$opt!$val!"
+# uplevel 1 [list set itcl_options($opt) [list $val]]
+ if {[catch {uplevel 1 $my_win configure $opt [list $val]} msg]} {
+puts stderr "initoptions ERR!$msg!$my_class!$my_win!configure!$opt!$val!"
+ }
+ }
+ foreach comp [dict keys $class_info_dict] {
+#puts stderr "OPT1!$opt!$comp![dict get $class_info_dict $comp]!"
+ if {[dict exists $class_info_dict $comp -keptoptions]} {
+ if {[lsearch [dict get $class_info_dict $comp -keptoptions] $opt] >= 0} {
+ if {$found == 0} {
+ # we use the option value of the first component for setting
+ # the option, as the components are traversed in the dict
+ # depending on the ordering of the component creation!!
+ set my_info [uplevel 1 \[set $comp\] configure $opt]
+ set resource [lindex $my_info 1]
+ set class [lindex $my_info 2]
+ set default_val [lindex $my_info 3]
+ set found 2
+ set val [uplevel #0 ::option get $my_win $resource $class]
+ if {[::dict exists $argsDict $opt]} {
+ # we have an explicitly set option
+ set val [::dict get $argsDict $opt]
+ } else {
+ if {[string length $val] == 0} {
+ set val $default_val
+ }
+ }
+#puts stderr "OPT2!$opt!$val!"
+ set ::itcl::internal::variables::${win}::itcl_options($opt) $val
+ set ::itcl::internal::variables::${win}::__itcl_option_infos($opt) [list $resource $class $default_val]
+# uplevel 1 [list set itcl_options($opt) [list $val]]
+ }
+ if {[catch {uplevel 1 \[set $comp\] configure $opt [list $val]} msg]} {
+puts stderr "initoptions ERR2!$msg!$my_class!$comp!configure!$opt!$val!"
+ }
+ if {![uplevel 1 info exists itcl_option_components($opt)]} {
+ set itcl_option_components($opt) [list]
+ }
+ if {[lsearch [set itcl_option_components($opt)] $comp] < 0} {
+ if {![catch {
+ set optval [uplevel 1 [list set itcl_options($opt)]]
+ } msg3]} {
+ uplevel 1 \[set $comp\] configure $opt $optval
+ }
+ lappend itcl_option_components($opt) $comp
+ }
+ }
+ }
+ }
+ }
+# uplevel 1 $opt_lst
+}
+
+# ======================= setoptions ===========================
+
+proc setoptions {args} {
+
+#puts stderr "setOPT!!$args!"
+ if {[llength $args]} {
+ set argsDict [dict create {*}$args]
+ } else {
+ set argsDict [dict create]
+ }
+ set my_class [uplevel 1 namespace current]
+ set myOptions [namespace eval $my_class {info options}]
+#puts stderr "OPTS!$win!$my_class![join [lsort $myOptions]] \n]!"
+ set opt_lst [list configure]
+ foreach opt [lsort $myOptions] {
+ set found 0
+ if {[catch {
+ set resource [uplevel 1 info option $opt -resource]
+ set class [uplevel 1 info option $opt -class]
+ set default_val [uplevel 1 info option $opt -default]
+ set found 1
+ } msg]} {
+# puts stderr "MSG!$opt!$msg!"
+ }
+#puts stderr "OPT!$opt!$found!"
+ if {$found} {
+ set val ""
+ if {[::dict exists $argsDict $opt]} {
+ # we have an explicitly set option
+ set val [::dict get $argsDict $opt]
+ } else {
+ if {[string length $val] == 0} {
+ set val $default_val
+ }
+ }
+ set myObj [uplevel 1 set this]
+#puts stderr "myObj!$myObj!"
+ set ::itcl::internal::variables::${myObj}::itcl_options($opt) $val
+ set ::itcl::internal::variables::${myObj}::__itcl_option_infos($opt) [list $resource $class $default_val]
+#puts stderr "OPT1!$opt!$val!"
+ uplevel 1 [list set itcl_options($opt) [list $val]]
+# if {[catch {uplevel 1 $myObj configure $opt [list $val]} msg]} {
+#puts stderr "initoptions ERR!$msg!$my_class!$my_win!configure!$opt!$val!"
+# }
+ }
+ }
+# uplevel 1 $opt_lst
+}
+
+# ========================= keepcomponentoption ======================
+# Invoked by Tcl during evaluating constructor whenever
+# the "keepcomponentoption" command is invoked to list the options
+# to be kept when an ::itcl::extendedclass component has been setup
+# for an object.
+#
+# It checks, for all arguments, if the opt is an option of that class
+# and of that component. If that is the case it adds the component name
+# to the list of components for that option.
+# The variable is the object variable: itcl_option_components($opt)
+#
+# Handles the following syntax:
+#
+# keepcomponentoption <componentName> <optionName> ?<optionName> ...?
+#
+# ======================================================================
+
+
+proc keepcomponentoption {args} {
+ upvar win win
+ upvar itcl_hull itcl_hull
+
+ set usage "wrong # args, should be: keepcomponentoption componentName optionName ?optionName ...?"
+
+#puts stderr "KEEP!$args![uplevel 1 namespace current]!"
+ if {[llength $args] < 2} {
+ puts stderr $usage
+ return -code error
+ }
+ set my_hull [uplevel 1 set itcl_hull]
+ set my_class [uplevel 1 namespace current]
+ set comp [lindex $args 0]
+ set args [lrange $args 1 end]
+ set class_info_dict [dict get $::itcl::internal::dicts::classComponents $my_class]
+ if {![dict exists $class_info_dict $comp]} {
+ puts stderr "keepcomponentoption cannot find component \"$comp\""
+ return -code error
+ }
+ set class_comp_dict [dict get $class_info_dict $comp]
+ if {![dict exists $class_comp_dict -keptoptions]} {
+ dict set class_comp_dict -keptoptions [list]
+ }
+ foreach opt $args {
+#puts stderr "KEEP!$opt!"
+ if {[string range $opt 0 0] ne "-"} {
+ puts stderr "keepcomponentoption: option must begin with a \"-\"!"
+ return -code error
+ }
+ if {[lsearch [dict get $class_comp_dict -keptoptions] $opt] < 0} {
+ dict lappend class_comp_dict -keptoptions $opt
+ }
+ }
+ if {![info exists ::itcl::internal::component_objects([lindex [uplevel 1 info context] 1])]} {
+ set comp_object $::itcl::internal::component_objects([lindex [uplevel 1 info context] 1])
+ } else {
+ set comp_object "unknown_comp_obj_$comp!"
+ }
+ dict set class_info_dict $comp $class_comp_dict
+ dict set ::itcl::internal::dicts::classComponents $my_class $class_info_dict
+puts stderr "CLDI!$class_comp_dict!"
+ addToItclOptions $my_class $comp_object $args [list]
+}
+
+proc ignorecomponentoption {args} {
+puts stderr "IGNORE_COMPONENT_OPTION!$args!"
+}
+
+proc renamecomponentoption {args} {
+puts stderr "rename_COMPONENT_OPTION!$args!"
+}
+
+proc addoptioncomponent {args} {
+puts stderr "ADD_OPTION_COMPONENT!$args!"
+}
+
+proc ignoreoptioncomponent {args} {
+puts stderr "IGNORE_OPTION_COMPONENT!$args!"
+}
+
+proc renameoptioncomponent {args} {
+puts stderr "RENAME_OPTION_COMPONENT!$args!"
+}
+
+proc getEclassOptions {args} {
+ upvar win win
+
+#puts stderr "getEclassOptions!$args!$win![uplevel 1 namespace current]!"
+#parray ::itcl::internal::variables::${win}::itcl_options
+ set result [list]
+ foreach opt [array names ::itcl::internal::variables::${win}::itcl_options] {
+ if {[catch {
+ foreach {res cls def} [set ::itcl::internal::variables::${win}::__itcl_option_infos($opt)] break
+ lappend result [list $opt $res $cls $def [set ::itcl::internal::variables::${win}::itcl_options($opt)]]
+ } msg]} {
+ }
+ }
+ return $result
+}
+
+proc eclassConfigure {args} {
+ upvar win win
+
+#puts stderr "+++ eclassConfigure!$args!"
+ if {[llength $args] > 1} {
+ foreach {opt val} $args break
+ if {[::info exists ::itcl::internal::variables::${win}::itcl_options($opt)]} {
+ set ::itcl::internal::variables::${win}::itcl_options($opt) $val
+ return
+ }
+ } else {
+ foreach {opt} $args break
+ if {[::info exists ::itcl::internal::variables::${win}::itcl_options($opt)]} {
+#puts stderr "OP![set ::itcl::internal::variables::${win}::itcl_options($opt)]!"
+ foreach {res cls def} [set ::itcl::internal::variables::${win}::__itcl_option_infos($opt)] break
+ return [list $opt $res $cls $def [set ::itcl::internal::variables::${win}::itcl_options($opt)]]
+ }
+ }
+ return -code error
+}
+
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/itclHullCmds.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/itclWidget.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/itclWidget.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/itclWidget.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,447 @@
+#
+# itclWidget.tcl
+# ----------------------------------------------------------------------
+# Invoked automatically upon startup to customize the interpreter
+# for [incr Tcl] when one of ::itcl::widget or ::itcl::widgetadaptor is called.
+# ----------------------------------------------------------------------
+# AUTHOR: Arnulf P. Wiedemann
+#
+# ----------------------------------------------------------------------
+# Copyright (c) 2008 Arnulf P. Wiedemann
+# ======================================================================
+# See the file "license.terms" for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package require Tk 8.6 9
+# package require itclwidget [set ::itcl::version]
+
+namespace eval ::itcl {
+
+proc widget {name args} {
+ set result [uplevel 1 ::itcl::internal::commands::genericclass widget $name $args]
+ # we handle create by owerselfs !! allow classunknown to handle that
+ oo::objdefine $result unexport create
+ return $result
+}
+
+proc widgetadaptor {name args} {
+ set result [uplevel 1 ::itcl::internal::commands::genericclass widgetadaptor $name $args]
+ # we handle create by owerselfs !! allow classunknown to handle that
+ oo::objdefine $result unexport create
+ return $result
+}
+
+} ; # end ::itcl
+
+
+namespace eval ::itcl::internal::commands {
+
+proc initWidgetOptions {varNsName widgetName className} {
+ set myDict [set ::itcl::internal::dicts::classOptions]
+ if {$myDict eq ""} {
+ return
+ }
+ if {![dict exists $myDict $className]} {
+ return
+ }
+ set myDict [dict get $myDict $className]
+ foreach option [dict keys $myDict] {
+ set infos [dict get $myDict $option]
+ set resource [dict get $infos -resource]
+ set class [dict get $infos -class]
+ set value [::option get $widgetName $resource $class]
+ if {$value eq ""} {
+ if {[dict exists $infos -default]} {
+ set defaultValue [dict get $infos -default]
+ uplevel 1 set ${varNsName}::itcl_options($option) $defaultValue
+ }
+ } else {
+ uplevel 1 set ${varNsName}::itcl_options($option) $value
+ }
+ }
+}
+
+proc initWidgetDelegatedOptions {varNsName widgetName className args} {
+ set myDict [set ::itcl::internal::dicts::classDelegatedOptions]
+ if {$myDict eq ""} {
+ return
+ }
+ if {![dict exists $myDict $className]} {
+ return
+ }
+ set myDict [dict get $myDict $className]
+ foreach option [dict keys $myDict] {
+ set infos [dict get $myDict $option]
+ if {![dict exists $infos -resource]} {
+ # this is the case when delegating "*"
+ continue
+ }
+ if {![dict exists $infos -component]} {
+ # nothing to do
+ continue
+ }
+ # check if not in the command line options
+ # these have higher priority
+ set myOption $option
+ if {[dict exists $infos -as]} {
+ set myOption [dict get $infos -as]
+ }
+ set noOptionSet 0
+ foreach {optName optVal} $args {
+ if {$optName eq $myOption} {
+ set noOptionSet 1
+ break
+ }
+ }
+ if {$noOptionSet} {
+ continue
+ }
+ set resource [dict get $infos -resource]
+ set class [dict get $infos -class]
+ set component [dict get $infos -component]
+ set value [::option get $widgetName $resource $class]
+ if {$component ne ""} {
+ if {$value ne ""} {
+ set compVar [namespace eval ${varNsName}${className} "set $component"]
+ if {$compVar ne ""} {
+ uplevel 1 $compVar configure $myOption $value
+ }
+ }
+ }
+ }
+}
+
+proc widgetinitobjectoptions {varNsName widgetName className} {
+#puts stderr "initWidgetObjectOptions!$varNsName!$widgetName!$className!"
+}
+
+proc deletehull {newName oldName what} {
+ if {$what eq "delete"} {
+ set name [namespace tail $newName]
+ regsub {hull[0-9]+} $name {} name
+ rename $name {}
+ }
+ if {$what eq "rename"} {
+ set name [namespace tail $newName]
+ regsub {hull[0-9]+} $name {} name
+ rename $name {}
+ }
+}
+
+proc hullandoptionsinstall {objectName className widgetClass hulltype args} {
+ if {$hulltype eq ""} {
+ set hulltype frame
+ }
+ set idx 0
+ set found 0
+ foreach {optName optValue} $args {
+ if {$optName eq "-class"} {
+ set found 1
+ set widgetClass $optValue
+ break
+ }
+ incr idx
+ }
+ if {$found} {
+ set args [lreplace $args $idx [expr {$idx + 1}]]
+ }
+ if {$widgetClass eq ""} {
+ set widgetClass $className
+ set widgetClass [string totitle $widgetClass]
+ }
+ set cmd "set win $objectName; ::itcl::builtin::installhull using $hulltype -class $widgetClass $args"
+ uplevel 2 $cmd
+}
+
+} ; # end ::itcl::internal::commands
+
+namespace eval ::itcl::builtin {
+
+proc installhull {args} {
+ set cmdPath ::itcl::internal::commands
+ set className [uplevel 1 info class]
+
+ set replace 0
+ switch -- [llength $args] {
+ 0 {
+ return -code error\
+ "wrong # args: should be \"[lindex [info level 0] 0]\
+ name|using <widgetType> ?arg ...?\""
+ }
+ 1 {
+ set widgetName [lindex $args 0]
+ set varNsName $::itcl::internal::varNsName($widgetName)
+ }
+ default {
+ upvar win win
+ set widgetName $win
+
+ set varNsName $::itcl::internal::varNsName($widgetName)
+ set widgetType [lindex $args 1]
+ incr replace
+ if {[llength $args] > 3 && [lindex $args 2] eq "-class"} {
+ set classNam [lindex $args 3]
+ incr replace 2
+ } else {
+ set classNam [string totitle $widgetType]
+ }
+ uplevel 1 [lreplace $args 0 $replace $widgetType $widgetName -class $classNam]
+ uplevel 1 [list ${cmdPath}::initWidgetOptions $varNsName $widgetName $className]
+ }
+ }
+
+ # initialize the itcl_hull variable
+ set i 0
+ set nam ::itcl::internal::widgets::hull
+ while {1} {
+ incr i
+ set hullNam ${nam}${i}$widgetName
+ if {[::info command $hullNam] eq ""} {
+ break
+ }
+ }
+ uplevel 1 [list ${cmdPath}::sethullwindowname $widgetName]
+ uplevel 1 [list ::rename $widgetName $hullNam]
+ uplevel 1 [list ::trace add command $hullNam {delete rename} ::itcl::internal::commands::deletehull]
+ catch {${cmdPath}::checksetitclhull [list] 0}
+ namespace eval ${varNsName}${className} "set itcl_hull $hullNam"
+ catch {${cmdPath}::checksetitclhull [list] 2}
+ uplevel 1 [lreplace $args 0 $replace ${cmdPath}::initWidgetDelegatedOptions $varNsName $widgetName $className]
+}
+
+proc installcomponent {args} {
+ upvar win win
+
+ set className [uplevel 1 info class]
+ set myType [${className}::info types [namespace tail $className]]
+ set isType 0
+ if {$myType ne ""} {
+ set isType 1
+ }
+ set numArgs [llength $args]
+ set usage "usage: installcomponent <componentName> using <widgetType> <widgetPath> ?-option value ...?"
+ if {$numArgs < 4} {
+ error $usage
+ }
+ foreach {componentName using widgetType widgetPath} $args break
+ set opts [lrange $args 4 end]
+ if {$using ne "using"} {
+ error $usage
+ }
+ if {!$isType} {
+ set hullExists [uplevel 1 ::info exists itcl_hull]
+ if {!$hullExists} {
+ error "cannot install \"$componentName\" before \"itcl_hull\" exists"
+ }
+ set hullVal [uplevel 1 set itcl_hull]
+ if {$hullVal eq ""} {
+ error "cannot install \"$componentName\" before \"itcl_hull\" exists"
+ }
+ }
+ # check for delegated option and ask the option database for the values
+ # first check for number of delegated options
+ set numOpts 0
+ set starOption 0
+ set myDict [set ::itcl::internal::dicts::classDelegatedOptions]
+ if {[dict exists $myDict $className]} {
+ set myDict [dict get $myDict $className]
+ foreach option [dict keys $myDict] {
+ if {$option eq "*"} {
+ set starOption 1
+ }
+ incr numOpts
+ }
+ }
+ set myOptionDict [set ::itcl::internal::dicts::classOptions]
+ if {[dict exists $myOptionDict $className]} {
+ set myOptionDict [dict get $myOptionDict $className]
+ }
+ set cmd [list $widgetPath configure]
+ set cmd1 "set $componentName \[$widgetType $widgetPath\]"
+ uplevel 1 $cmd1
+ if {$starOption} {
+ upvar $componentName compName
+ set cmd1 [list $compName configure]
+ set configInfos [uplevel 1 $cmd1]
+ foreach entry $configInfos {
+ if {[llength $entry] > 2} {
+ foreach {optName resource class defaultValue} $entry break
+ set val ""
+ catch {
+ set val [::option get $win $resource $class]
+ }
+ if {$val ne ""} {
+ set addOpt 1
+ if {[dict exists $myDict $$optName]} {
+ set addOpt 0
+ } else {
+ set starDict [dict get $myDict "*"]
+ if {[dict exists $starDict -except]} {
+ set exceptions [dict get $starDict -except]
+ if {[lsearch $exceptions $optName] >= 0} {
+ set addOpt 0
+ }
+
+ }
+ if {[dict exists $myOptionDict $optName]} {
+ set addOpt 0
+ }
+ }
+ if {$addOpt} {
+ lappend cmd $optName $val
+ }
+
+ }
+
+ }
+ }
+ } else {
+ foreach optName [dict keys $myDict] {
+ set optInfos [dict get $myDict $optName]
+ set resource [dict get $optInfos -resource]
+ set class [namespace tail $className]
+ set class [string totitle $class]
+ set val ""
+ catch {
+ set val [::option get $win $resource $class]
+ }
+ if {$val ne ""} {
+ if {[dict exists $optInfos -as] } {
+ set optName [dict get $optInfos -as]
+ }
+ lappend cmd $optName $val
+ }
+ }
+ }
+ lappend cmd {*}$opts
+ uplevel 1 $cmd
+}
+
+} ; # end ::itcl::builtin
+
+set ::itcl::internal::dicts::hullTypes [list \
+ frame \
+ toplevel \
+ labelframe \
+ ttk:frame \
+ ttk:toplevel \
+ ttk:labelframe \
+ ]
+
+namespace eval ::itcl::builtin::Info {
+
+proc hulltypes {args} {
+ namespace upvar ::itcl::internal::dicts hullTypes hullTypes
+
+ set numArgs [llength $args]
+ if {$numArgs > 1} {
+ error "wrong # args should be: info hulltypes ?<pattern>?"
+ }
+ set pattern ""
+ if {$numArgs > 0} {
+ set pattern [lindex $args 0]
+ }
+ if {$pattern ne ""} {
+ return [lsearch -all -inline -glob $hullTypes $pattern]
+ }
+ return $hullTypes
+
+}
+
+proc widgetclasses {args} {
+ set numArgs [llength $args]
+ if {$numArgs > 1} {
+ error "wrong # args should be: info widgetclasses ?<pattern>?"
+ }
+ set pattern ""
+ if {$numArgs > 0} {
+ set pattern [lindex $args 0]
+ }
+ set myDict [set ::itcl::internal::dicts::classes]
+ if {![dict exists $myDict widget]} {
+ return [list]
+ }
+ set myDict [dict get $myDict widget]
+ set result [list]
+ if {$pattern ne ""} {
+ foreach key [dict keys $myDict] {
+ set myInfo [dict get $myDict $key]
+ set value [dict get $myInfo -widget]
+ if {[string match $pattern $value]} {
+ lappend result $value
+ }
+ }
+ } else {
+ foreach key [dict keys $myDict] {
+ set myInfo [dict get $myDict $key]
+ lappend result [dict get $myInfo -widget]
+ }
+ }
+ return $result
+}
+
+proc widgets {args} {
+ set numArgs [llength $args]
+ if {$numArgs > 1} {
+ error "wrong # args should be: info widgets ?<pattern>?"
+ }
+ set pattern ""
+ if {$numArgs > 0} {
+ set pattern [lindex $args 0]
+ }
+ set myDict [set ::itcl::internal::dicts::classes]
+ if {![dict exists $myDict widget]} {
+ return [list]
+ }
+ set myDict [dict get $myDict widget]
+ set result [list]
+ if {$pattern ne ""} {
+ foreach key [dict keys $myDict] {
+ set myInfo [dict get $myDict $key]
+ set value [dict get $myInfo -name]
+ if {[string match $pattern $value]} {
+ lappend result $value
+ }
+ }
+ } else {
+ foreach key [dict keys $myDict] {
+ set myInfo [dict get $myDict $key]
+ lappend result [dict get $myInfo -name]
+ }
+ }
+ return $result
+}
+
+proc widgetadaptors {args} {
+ set numArgs [llength $args]
+ if {$numArgs > 1} {
+ error "wrong # args should be: info widgetadaptors ?<pattern>?"
+ }
+ set pattern ""
+ if {$numArgs > 0} {
+ set pattern [lindex $args 0]
+ }
+ set myDict [set ::itcl::internal::dicts::classes]
+ if {![dict exists $myDict widgetadaptor]} {
+ return [list]
+ }
+ set myDict [dict get $myDict widgetadaptor]
+ set result [list]
+ if {$pattern ne ""} {
+ foreach key [dict keys $myDict] {
+ set myInfo [dict get $myDict $key]
+ set value [dict get $myInfo -name]
+ if {[string match $pattern $value]} {
+ lappend result $value
+ }
+ }
+ } else {
+ foreach key [dict keys $myDict] {
+ set myInfo [dict get $myDict $key]
+ lappend result [dict get $myInfo -name]
+ }
+ }
+ return $result
+}
+
+} ; # end ::itcl::builtin::Info
Property changes on: trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/itclWidget.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/libitclstub.a
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/libitclstub.a
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/libitclstub.a 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/libitclstub.a 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/libitclstub.a
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+application/x-archive
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/pkgIndex.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/pkgIndex.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/pkgIndex.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,14 @@
+# -*- tcl -*-
+# Tcl package index file, version 1.1
+#
+
+if {![package vsatisfies [package provide Tcl] 8.6-]} {return}
+
+if {[package vsatisfies [package provide Tcl] 9.0-]} {
+ package ifneeded itcl 4.3.2 \
+ [list load [file join $dir tcl9itcl432.dll] Itcl]
+} else {
+ package ifneeded itcl 4.3.2 \
+ [list load [file join $dir itcl432.dll] Itcl]
+}
+package ifneeded Itcl 4.3.2 [list package require -exact itcl 4.3.2]
Property changes on: trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/pkgIndex.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/tcl9itcl432.dll
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/tcl9itcl432.dll
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/tcl9itcl432.dll 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/tcl9itcl432.dll 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/itcl4.3.2/tcl9itcl432.dll
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+application/vnd.microsoft.portable-executable
\ No newline at end of property
Deleted: trunk/Master/tlpkg/tltcl/lib/libtcl86.dll.a
===================================================================
(Binary files differ)
Added: trunk/Master/tlpkg/tltcl/lib/libtcl90.dll.a
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/libtcl90.dll.a
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/libtcl90.dll.a 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/libtcl90.dll.a 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/libtcl90.dll.a
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+application/x-archive
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/libtcl9tk90.dll.a
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/libtcl9tk90.dll.a
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/libtcl9tk90.dll.a 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/libtcl9tk90.dll.a 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/libtcl9tk90.dll.a
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+application/x-archive
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/libtclstub.a
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/libtclstub.a
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/libtclstub.a 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/libtclstub.a 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/libtclstub.a
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+application/x-archive
\ No newline at end of property
Deleted: trunk/Master/tlpkg/tltcl/lib/libtclstub86.a
===================================================================
(Binary files differ)
Deleted: trunk/Master/tlpkg/tltcl/lib/libtk86.dll.a
===================================================================
(Binary files differ)
Added: trunk/Master/tlpkg/tltcl/lib/libtkstub.a
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/libtkstub.a
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/libtkstub.a 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/libtkstub.a 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/libtkstub.a
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+application/x-archive
\ No newline at end of property
Deleted: trunk/Master/tlpkg/tltcl/lib/libtkstub86.a
===================================================================
(Binary files differ)
Added: trunk/Master/tlpkg/tltcl/lib/libtommath.dll.a
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/libtommath.dll.a
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/libtommath.dll.a 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/libtommath.dll.a 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/libtommath.dll.a
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+application/x-archive
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/libz.dll.a
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/libz.dll.a
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/libz.dll.a 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/libz.dll.a 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/libz.dll.a
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+application/x-archive
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/registry1.3/libtclregistry13.dll.a
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/registry1.3/libtclregistry13.dll.a
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/registry1.3/libtclregistry13.dll.a 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/registry1.3/libtclregistry13.dll.a 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/registry1.3/libtclregistry13.dll.a
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+application/x-archive
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/registry1.3/pkgIndex.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/registry1.3/pkgIndex.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/registry1.3/pkgIndex.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,9 @@
+if {![package vsatisfies [package provide Tcl] 8.5-]} return
+if {[info sharedlibextension] != ".dll"} return
+if {[package vsatisfies [package provide Tcl] 9.0-]} {
+ package ifneeded registry 1.3.7 \
+ [list load [file join $dir tcl9registry13.dll] Registry]
+} else {
+ package ifneeded registry 1.3.7 \
+ [list load [file join $dir tclregistry13.dll] Registry]
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/registry1.3/pkgIndex.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/registry1.3/tcl9registry13.dll
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/registry1.3/tcl9registry13.dll
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/registry1.3/tcl9registry13.dll 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/registry1.3/tcl9registry13.dll 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/registry1.3/tcl9registry13.dll
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+application/vnd.microsoft.portable-executable
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/registry1.3/tclregistry13.dll
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/registry1.3/tclregistry13.dll
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/registry1.3/tclregistry13.dll 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/registry1.3/tclregistry13.dll 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/registry1.3/tclregistry13.dll
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+application/vnd.microsoft.portable-executable
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/sqlite3.47.2/pkgIndex.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/sqlite3.47.2/pkgIndex.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/sqlite3.47.2/pkgIndex.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,12 @@
+# -*- tcl -*-
+# Tcl package index file, version 1.1
+#
+# Note sqlite*3* init specifically
+#
+if {[package vsatisfies [package provide Tcl] 9.0-]} {
+ package ifneeded sqlite3 3.47.2 \
+ [list load [file join $dir tcl9sqlite3472.dll] Sqlite3]
+} else {
+ package ifneeded sqlite3 3.47.2 \
+ [list load [file join $dir sqlite3472.dll] Sqlite3]
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/sqlite3.47.2/pkgIndex.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/sqlite3.47.2/tcl9sqlite3472.dll
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/sqlite3.47.2/tcl9sqlite3472.dll
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/sqlite3.47.2/tcl9sqlite3472.dll 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/sqlite3.47.2/tcl9sqlite3472.dll 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/sqlite3.47.2/tcl9sqlite3472.dll
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+application/vnd.microsoft.portable-executable
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tcl9/9.0/tdbc/sqlite3-1.1.10.tm
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl9/9.0/tdbc/sqlite3-1.1.10.tm (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tcl9/9.0/tdbc/sqlite3-1.1.10.tm 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,751 @@
+# tdbcsqlite3.tcl --
+#
+# SQLite3 database driver for TDBC
+#
+# Copyright (c) 2008 by Kevin B. Kenny.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: tdbcodbc.tcl,v 1.47 2008/02/27 02:08:27 kennykb Exp $
+#
+#------------------------------------------------------------------------------
+
+package require tdbc
+package require sqlite3
+
+package provide tdbc::sqlite3 1.1.10
+
+namespace eval tdbc::sqlite3 {
+ namespace export connection
+ variable script [info script]
+
+ proc build-info args {
+ if {[llength $args] > 0} {
+ if {[llength $args] > 1} {
+ return -code error "wrong # args: should be \"[lrange [info level 0] 0 end-[llength $args]]\""
+ }
+ switch -exact -- [lindex $args 0] {
+ commit {}
+ compiler {return none}
+ patchlevel {return [package provide tdbc::sqlite3]}
+ version {return [join [lrange [split [package provide tdbc::sqlite3] .] 0 1] .]}
+ default {return 0}
+ }
+ }
+ variable script
+ set id unknown
+ catch {
+ set f [open [file rootname $script].uuid]
+ set id [string trim [read $f]]
+ close $f
+ }
+ if {[llength $args] > 0} {
+ return $id
+ } else {
+ return [package provide tdbc::sqlite3]+$id
+ }
+ }
+}
+
+#------------------------------------------------------------------------------
+#
+# tdbc::sqlite3::connection --
+#
+# Class representing a SQLite3 database connection
+#
+#------------------------------------------------------------------------------
+
+::oo::class create ::tdbc::sqlite3::connection {
+
+ superclass ::tdbc::connection
+
+ variable timeout
+ variable keepcase
+
+ # The constructor accepts a database name and opens the database.
+
+ constructor {databaseName args} {
+ set timeout 0
+ set keepcase 0
+ if {[llength $args] % 2 != 0} {
+ set cmd [lrange [info level 0] 0 end-[llength $args]]
+ return -code error \
+ -errorcode {TDBC GENERAL_ERROR HY000 SQLITE3 WRONGNUMARGS} \
+ "wrong # args, should be \"$cmd ?-option value?...\""
+ }
+ next
+ sqlite3 [namespace current]::db $databaseName
+ if {[llength $args] > 0} {
+ my configure {*}$args
+ }
+ db nullvalue \ufffd
+ }
+
+ # The 'statementCreate' method forwards to the constructor of the
+ # statement class
+
+ forward statementCreate ::tdbc::sqlite3::statement create
+
+ # The 'configure' method queries and sets options to the database
+
+ method configure args {
+ if {[llength $args] == 0} {
+
+ # Query all configuration options
+
+ set result {-encoding utf-8}
+ lappend result -isolation
+ if {[db onecolumn {PRAGMA read_uncommitted}]} {
+ lappend result readuncommitted
+ } else {
+ lappend result serializable
+ }
+ lappend result -keepcase $keepcase
+ lappend result -readonly 0
+ lappend result -timeout $timeout
+ return $result
+
+ } elseif {[llength $args] == 1} {
+
+ # Query a single option
+
+ set option [lindex $args 0]
+ if {[catch {::tcl::prefix match -message "option" {
+ -encoding -isolation -keepcase -readonly -timeout
+ } $option} opt]} {
+ return -code error \
+ -errorcode [list TDBC GENERAL_ERROR HY000 SQLITE3 \
+ BADOPTION $option] $opt
+ }
+ switch -exact -- $opt {
+ -encoding {
+ return utf-8
+ }
+ -isolation {
+ if {[db onecolumn {PRAGMA read_uncommitted}]} {
+ return readuncommitted
+ } else {
+ return serializable
+ }
+ }
+ -keepcase {
+ return $keepcase
+ }
+ -readonly {
+ return 0
+ }
+ -timeout {
+ return $timeout
+ }
+ }
+
+ } elseif {[llength $args] % 2 != 0} {
+
+ # Syntax error
+
+ set cmd [lrange [info level 0] 0 end-[llength $args]]
+ return -code error \
+ -errorcode [list TDBC GENERAL_ERROR HY000 \
+ SQLITE3 WRONGNUMARGS] \
+ "wrong # args, should be \" $cmd ?-option value?...\""
+ }
+
+ # Set one or more options
+
+ foreach {option value} $args {
+ if {[catch {::tcl::prefix match -message "option" {
+ -encoding -isolation -keepcase -readonly -timeout
+ } $option} opt]} {
+ return -code error \
+ -errorcode [list TDBC GENERAL_ERROR HY000 SQLITE3 \
+ BADOPTION $option] $opt
+ }
+
+ switch -exact -- $opt {
+ -encoding {
+ if {$value ne {utf-8}} {
+ return -code error \
+ -errorcode [list TDBC FEATURE_NOT_SUPPORTED 0A000 \
+ SQLITE3 ENCODING] \
+ "-encoding not supported. SQLite3 is always\
+ Unicode."
+ }
+ }
+ -isolation {
+ if {[catch {::tcl::prefix match -message "isolation level" {
+ readuncommitted readcommitted repeatableread
+ serializable readonly
+ } $value} val]} {
+ return -code error \
+ -errorcode [list TDBC GENERAL_ERROR HY000 \
+ SQLITE3 BADISOLATION $value] \
+ $val
+ }
+ switch -exact -- $val {
+ readuncommitted {
+ db eval {PRAGMA read_uncommitted = 1}
+ }
+ readcommitted -
+ repeatableread -
+ serializable -
+ readonly {
+ db eval {PRAGMA read_uncommitted = 0}
+ }
+ }
+ }
+ -keepcase {
+ if {![string is boolean -strict $value]} {
+ return -code error \
+ -errorcode [list TDBC DATA_EXCEPTION 22018 \
+ SQLITE3 $value] \
+ "expected boolean but got \"$value\""
+ }
+ # Normalize boolean value to 0/1
+ set keepcase [expr {bool($value)}]
+ }
+ -readonly {
+ if {$value} {
+ return -code error \
+ -errorcode [list TDBC FEATURE_NOT_SUPPORTED 0A000 \
+ SQLITE3 READONLY] \
+ "SQLite3's Tcl API does not support read-only\
+ access"
+ }
+ }
+ -timeout {
+ if {![string is integer -strict $value]} {
+ return -code error \
+ -errorcode [list TDBC DATA_EXCEPTION 22018 \
+ SQLITE3 $value] \
+ "expected integer but got \"$value\""
+ }
+ db timeout $value
+ set timeout $value
+ }
+ }
+ }
+ return
+ }
+
+ # The 'tables' method introspects on the tables in the database.
+
+ method tables {{pattern %}} {
+ set retval {}
+ my foreach row {
+ SELECT * from sqlite_master
+ WHERE type IN ('table', 'view')
+ AND name LIKE :pattern
+ } {
+ if {!$keepcase} {
+ dict set row name [string tolower [dict get $row name]]
+ }
+ dict set retval [dict get $row name] $row
+ }
+ return $retval
+ }
+
+ # The 'columns' method introspects on columns of a table.
+
+ method columns {table {pattern %}} {
+ regsub -all ' $table '' table
+ set retval {}
+ set pattern [string map [list \
+ * {[*]} \
+ ? {[?]} \
+ \[ \\\[ \
+ \] \\\[ \
+ _ ? \
+ % *] [string tolower $pattern]]
+ my foreach origrow "PRAGMA table_info('$table')" {
+ set row {}
+ dict for {key value} $origrow {
+ dict set row [string tolower $key] $value
+ }
+ if {!$keepcase} {
+ dict set row name [string tolower [dict get $row name]]
+ }
+ if {![string match $pattern \
+ [string tolower [dict get $row name]]]} {
+ continue
+ }
+ switch -regexp -matchvar info [dict get $row type] {
+ {^(.+)\(\s*([[:digit:]]+)\s*,\s*([[:digit:]]+)\s*\)\s*$} {
+ dict set row type \
+ [string trim [string tolower [lindex $info 1]]]
+ dict set row precision [lindex $info 2]
+ dict set row scale [lindex $info 3]
+ }
+ {^(.+)\(\s*([[:digit:]]+)\s*\)\s*$} {
+ dict set row type [string tolower [lindex $info 1]]
+ dict set row precision [lindex $info 2]
+ dict set row scale 0
+ }
+ default {
+ dict set row type [string tolower [dict get $row type]]
+ dict set row precision 0
+ dict set row scale 0
+ }
+ }
+ dict set row nullable [expr {![dict get $row notnull]}]
+ dict set retval [dict get $row name] $row
+ }
+ return $retval
+ }
+
+ # The 'primarykeys' method enumerates the primary keys on a table.
+
+ method primarykeys {table} {
+ set result {}
+ my foreach row "PRAGMA table_info($table)" {
+ if {[dict get $row pk]} {
+ lappend result [dict create ordinalPosition \
+ [expr {[dict get $row cid]+1}] \
+ columnName \
+ [dict get $row name]]
+ }
+ }
+ return $result
+ }
+
+ # The 'foreignkeys' method enumerates the foreign keys that are
+ # declared in a table or that refer to a given table.
+
+ method foreignkeys {args} {
+
+ variable ::tdbc::generalError
+
+ # Check arguments
+
+ set argdict {}
+ if {[llength $args] % 2 != 0} {
+ set errorcode $generalError
+ lappend errorcode wrongNumArgs
+ return -code error -errorcode $errorcode \
+ "wrong # args: should be [lrange [info level 0] 0 1]\
+ ?-option value?..."
+ }
+ foreach {key value} $args {
+ if {$key ni {-primary -foreign}} {
+ set errorcode $generalError
+ lappend errorcode badOption
+ return -code error -errorcode $errorcode \
+ "bad option \"$key\", must be -primary or -foreign"
+ }
+ set key [string range $key 1 end]
+ if {[dict exists $argdict $key]} {
+ set errorcode $generalError
+ lappend errorcode dupOption
+ return -code error -errorcode $errorcode \
+ "duplicate option \"$key\" supplied"
+ }
+ dict set argdict $key $value
+ }
+
+ # If we know the table with the foreign key, search just its
+ # foreign keys. Otherwise, iterate over all the tables in the
+ # database.
+
+ if {[dict exists $argdict foreign]} {
+ return [my ForeignKeysForTable [dict get $argdict foreign] \
+ $argdict]
+ } else {
+ set result {}
+ foreach foreignTable [dict keys [my tables]] {
+ lappend result {*}[my ForeignKeysForTable \
+ $foreignTable $argdict]
+ }
+ return $result
+ }
+
+ }
+
+ # The private ForeignKeysForTable method enumerates the foreign keys
+ # in a specific table.
+ #
+ # Parameters:
+ #
+ # foreignTable - Name of the table containing foreign keys.
+ # argdict - Dictionary that may or may not contain a key,
+ # 'primary', whose value is the name of a table that
+ # must hold the primary key corresponding to the foreign
+ # key. If the 'primary' key is absent, all tables are
+ # candidates.
+ # Results:
+ #
+ # Returns the list of foreign keys that meed the specified
+ # conditions, as a list of dictionaries, each containing the
+ # keys, foreignConstraintName, foreignTable, foreignColumn,
+ # primaryTable, primaryColumn, and ordinalPosition. Note that the
+ # foreign constraint name is constructed arbitrarily, since SQLite3
+ # does not report this information.
+
+ method ForeignKeysForTable {foreignTable argdict} {
+
+ set result {}
+ set n 0
+
+ # Go through the foreign keys in the given table, looking for
+ # ones that refer to the primary table (if one is given), or
+ # for any primary keys if none is given.
+ my foreach row "PRAGMA foreign_key_list($foreignTable)" {
+ if {(![dict exists $argdict primary])
+ || ([string tolower [dict get $row table]]
+ eq [string tolower [dict get $argdict primary]])} {
+
+ # Construct a dictionary for each key, translating
+ # SQLite names to TDBC ones and converting sequence
+ # numbers to 1-based indexing.
+
+ set rrow [dict create foreignTable $foreignTable \
+ foreignConstraintName \
+ ?$foreignTable?[dict get $row id]]
+ if {[dict exists $row seq]} {
+ dict set rrow ordinalPosition \
+ [expr {1 + [dict get $row seq]}]
+ }
+ foreach {to from} {
+ foreignColumn from
+ primaryTable table
+ primaryColumn to
+ deleteAction on_delete
+ updateAction on_update
+ } {
+ if {[dict exists $row $from]} {
+ dict set rrow $to [dict get $row $from]
+ }
+ }
+
+ # Add the newly-constucted dictionary to the result list
+
+ lappend result $rrow
+ }
+ }
+
+ return $result
+ }
+
+ # The 'preparecall' method prepares a call to a stored procedure.
+ # SQLite3 does not have stored procedures, since it's an in-process
+ # server.
+
+ method preparecall {call} {
+ return -code error \
+ -errorcode [list TDBC FEATURE_NOT_SUPPORTED 0A000 \
+ SQLITE3 PREPARECALL] \
+ {SQLite3 does not support stored procedures}
+ }
+
+ # The 'begintransaction' method launches a database transaction
+
+ method begintransaction {} {
+ db eval {BEGIN TRANSACTION}
+ }
+
+ # The 'commit' method commits a database transaction
+
+ method commit {} {
+ db eval {COMMIT}
+ }
+
+ # The 'rollback' method abandons a database transaction
+
+ method rollback {} {
+ db eval {ROLLBACK}
+ }
+
+ # The 'transaction' method executes a script as a single transaction.
+ # We override the 'transaction' method of the base class, since SQLite3
+ # has a faster implementation of the same thing. (The base class's generic
+ # method should also work.)
+ # (Don't overload the base class method, because 'break', 'continue'
+ # and 'return' in the transaction body don't work!)
+
+ #method transaction {script} {
+ # uplevel 1 [list {*}[namespace code db] transaction $script]
+ #}
+
+ method prepare {sqlCode} {
+ set result [next $sqlCode]
+ return $result
+ }
+
+ method getDBhandle {} {
+ return [namespace which db]
+ }
+}
+
+#------------------------------------------------------------------------------
+#
+# tdbc::sqlite3::statement --
+#
+# Class representing a statement to execute against a SQLite3 database
+#
+#------------------------------------------------------------------------------
+
+::oo::class create ::tdbc::sqlite3::statement {
+
+ superclass ::tdbc::statement
+
+ variable Params db sql
+
+ # The constructor accepts the handle to the connection and the SQL
+ # code for the statement to prepare. All that it does is to parse the
+ # statement and store it. The parse is used to support the
+ # 'params' and 'paramtype' methods.
+
+ constructor {connection sqlcode} {
+ next
+ set Params {}
+ set db [$connection getDBhandle]
+ set sql $sqlcode
+ foreach token [::tdbc::tokenize $sqlcode] {
+ if {[string index $token 0] in {$ : @}} {
+ dict set Params [string range $token 1 end] \
+ {type Tcl_Obj precision 0 scale 0 nullable 1 direction in}
+ }
+ }
+ }
+
+ # The 'resultSetCreate' method relays to the result set constructor
+
+ forward resultSetCreate ::tdbc::sqlite3::resultset create
+
+ # The 'params' method returns descriptions of the parameters accepted
+ # by the statement
+
+ method params {} {
+ return $Params
+ }
+
+ # The 'paramtype' method need do nothing; Sqlite3 uses manifest typing.
+
+ method paramtype args {;}
+
+ method getDBhandle {} {
+ return $db
+ }
+
+ method getSql {} {
+ return $sql
+ }
+
+}
+
+#-------------------------------------------------------------------------------
+#
+# tdbc::sqlite3::resultset --
+#
+# Class that represents a SQLlite result set in Tcl
+#
+#-------------------------------------------------------------------------------
+
+::oo::class create ::tdbc::sqlite3::resultset {
+
+ superclass ::tdbc::resultset
+
+ # The variables of this class all have peculiar names. The reason is
+ # that the RunQuery method needs to execute with an activation record
+ # that has no local variables whose names could conflict with names
+ # in the SQL query. We start the variable names with hyphens because
+ # they can't be bind variables.
+
+ variable -set {*}{
+ -columns -db -needcolumns -resultArray
+ -results -sql -Cursor -RowCount -END
+ }
+
+ constructor {statement args} {
+ next
+ set -db [$statement getDBhandle]
+ set -sql [$statement getSql]
+ set -columns {}
+ set -results {}
+ ${-db} trace [namespace code {my RecordStatement}]
+ if {[llength $args] == 0} {
+
+ # Variable substitutions are evaluated in caller's context
+
+ uplevel 1 [list ${-db} eval ${-sql} \
+ [namespace which -variable -resultArray] \
+ [namespace code {my RecordResult}]]
+
+ } elseif {[llength $args] == 1} {
+
+ # Variable substitutions are in the dictionary at [lindex $args 0].
+
+ set -paramDict [lindex $args 0]
+
+ # At this point, the activation record must contain no variables
+ # that might be bound within the query. All variables at this point
+ # begin with hyphens so that they are syntactically incorrect
+ # as bound variables in SQL.
+
+ unset args
+ unset statement
+
+ dict with -paramDict {
+ ${-db} eval ${-sql} -resultArray {
+ my RecordResult
+ }
+ }
+
+ } else {
+
+ ${-db} trace {}
+
+ # Too many args
+
+ return -code error \
+ -errorcode [list TDBC GENERAL_ERROR HY000 \
+ SQLITE3 WRONGNUMARGS] \
+ "wrong # args: should be\
+ [lrange [info level 0] 0 1] statement ?dictionary?"
+
+ }
+ ${-db} trace {}
+ set -Cursor 0
+ if {${-Cursor} < [llength ${-results}]
+ && [lindex ${-results} ${-Cursor}] eq {statement}} {
+ incr -Cursor 2
+ }
+ if {${-Cursor} < [llength ${-results}]
+ && [lindex ${-results} ${-Cursor}] eq {columns}} {
+ incr -Cursor
+ set -columns [lindex ${-results} ${-Cursor}]
+ incr -Cursor
+ }
+ set -RowCount [${-db} changes]
+ }
+
+ # Record the start of a SQL statement
+
+ method RecordStatement {stmt} {
+ set -needcolumns 1
+ lappend -results statement {}
+ }
+
+ # Record one row of results from a query by appending it as a dictionary
+ # to the 'results' list. As a side effect, set 'columns' to a list
+ # comprising the names of the columns of the result.
+
+ method RecordResult {} {
+ set columns ${-resultArray(*)}
+ if {[info exists -needcolumns]} {
+ lappend -results columns $columns
+ unset -needcolumns
+ }
+ set dict {}
+ foreach key $columns {
+ if {[set -resultArray($key)] ne "\ufffd"} {
+ dict set dict $key [set -resultArray($key)]
+ }
+ }
+ lappend -results row $dict
+ }
+
+ # Advance to the next result set
+
+ method nextresults {} {
+ set have 0
+ while {${-Cursor} < [llength ${-results}]} {
+ if {[lindex ${-results} ${-Cursor}] eq {statement}} {
+ set have 1
+ incr -Cursor 2
+ break
+ }
+ incr -Cursor 2
+ }
+ if {!$have} {
+ set -END {}
+ }
+ if {${-Cursor} >= [llength ${-results}]} {
+ set -columns {}
+ } elseif {[lindex ${-results} ${-Cursor}] eq {columns}} {
+ incr -Cursor
+ set -columns [lindex ${-results} ${-Cursor}]
+ incr -Cursor
+ } else {
+ set -columns {}
+ }
+ return $have
+ }
+
+ method getDBhandle {} {
+ return ${-db}
+ }
+
+ # Return a list of the columns
+
+ method columns {} {
+ if {[info exists -END]} {
+ return -code error \
+ -errorcode {TDBC GENERAL_ERROR HY010 SQLITE3 FUNCTIONSEQ} \
+ "Function sequence error: result set is exhausted."
+ }
+ return ${-columns}
+ }
+
+ # Return the next row of the result set as a list
+
+ method nextlist var {
+
+ upvar 1 $var row
+
+ if {[info exists -END]} {
+ return -code error \
+ -errorcode {TDBC GENERAL_ERROR HY010 SQLITE3 FUNCTIONSEQ} \
+ "Function sequence error: result set is exhausted."
+ }
+ if {${-Cursor} >= [llength ${-results}]
+ || [lindex ${-results} ${-Cursor}] ne {row}} {
+ return 0
+ } else {
+ set row {}
+ incr -Cursor
+ set d [lindex ${-results} ${-Cursor}]
+ incr -Cursor
+ foreach key ${-columns} {
+ if {[dict exists $d $key]} {
+ lappend row [dict get $d $key]
+ } else {
+ lappend row {}
+ }
+ }
+ }
+ return 1
+ }
+
+ # Return the next row of the result set as a dict
+
+ method nextdict var {
+
+ upvar 1 $var row
+
+ if {[info exists -END]} {
+ return -code error \
+ -errorcode {TDBC GENERAL_ERROR HY010 SQLITE3 FUNCTIONSEQ} \
+ "Function sequence error: result set is exhausted."
+ }
+ if {${-Cursor} >= [llength ${-results}]
+ || [lindex ${-results} ${-Cursor}] ne {row}} {
+ return 0
+ } else {
+ incr -Cursor
+ set row [lindex ${-results} ${-Cursor}]
+ incr -Cursor
+ }
+ return 1
+ }
+
+ # Return the number of rows affected by a statement
+
+ method rowcount {} {
+ if {[info exists -END]} {
+ return -code error \
+ -errorcode {TDBC GENERAL_ERROR HY010 SQLITE3 FUNCTIONSEQ} \
+ "Function sequence error: result set is exhausted."
+ }
+ return ${-RowCount}
+ }
+
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tcl9/9.0/tdbc/sqlite3-1.1.10.tm
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tcl9/9.0/tdbc/sqlite3-1.1.10.uuid
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl9/9.0/tdbc/sqlite3-1.1.10.uuid (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tcl9/9.0/tdbc/sqlite3-1.1.10.uuid 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1 @@
+a123346d9196a8db50d951cccc034b374c3705d7212be400113706ec52b681a2
Property changes on: trunk/Master/tlpkg/tltcl/lib/tcl9/9.0/tdbc/sqlite3-1.1.10.uuid
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Modified: trunk/Master/tlpkg/tltcl/lib/tclConfig.sh
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tclConfig.sh 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/tclConfig.sh 2025-02-24 13:59:26 UTC (rev 74255)
@@ -9,24 +9,20 @@
#
# The information in this file is specific to a single platform.
-TCL_DLL_FILE="tcl86.dll"
+TCL_DLL_FILE="tcl90.dll"
# Tcl's version number.
-TCL_VERSION='8.6'
-TCL_MAJOR_VERSION='8'
-TCL_MINOR_VERSION='6'
-TCL_PATCH_LEVEL='.13'
+TCL_VERSION='9.0'
+TCL_MAJOR_VERSION='9'
+TCL_MINOR_VERSION='0'
+TCL_PATCH_LEVEL='.1'
# C compiler to use for compilation.
-TCL_CC='x86_64-w64-mingw32-gcc'
+TCL_CC='gcc'
# -D flags for use with the C compiler.
-TCL_DEFS='-DPACKAGE_NAME=\"tcl\" -DPACKAGE_TARNAME=\"tcl\" -DPACKAGE_VERSION=\"8.6\" -DPACKAGE_STRING=\"tcl\ 8.6\" -DPACKAGE_BUGREPORT=\"\" -DSTDC_HEADERS=1 -DTCL_THREADS=1 -DUSE_THREAD_ALLOC=1 -DTCL_CFGVAL_ENCODING=\"cp1252\" -DMODULE_SCOPE=extern -DTCL_CFG_DO64BIT=1 -DHAVE_NO_SEH=1 -DHAVE_CAST_TO_UNION=1 -DHAVE_ZLIB=1 -DHAVE_SYS_TYPES_H=1 -DHAVE_SYS_STAT_H=1 -DHAVE_STDLIB_H=1 -DHAVE_STRING_H=1 -DHAVE_MEMORY_H=1 -DHAVE_STRINGS_H=1 -DHAVE_INTTYPES_H=1 -DHAVE_STDINT_H=1 -DHAVE_UNISTD_H=1 -DHAVE_INTPTR_T=1 -DHAVE_UINTPTR_T=1 -DHAVE_INTRIN_H=1 -DHAVE_WSPIAPI_H=1 -DNDEBUG=1 -DTCL_CFG_OPTIMIZED=1 '
+TCL_DEFS='-DPACKAGE_NAME=\"tcl\" -DPACKAGE_TARNAME=\"tcl\" -DPACKAGE_VERSION=\"9.0\" -DPACKAGE_STRING=\"tcl\ 9.0\" -DPACKAGE_BUGREPORT=\"\" -DPACKAGE_URL=\"\" -DTCL_CFGVAL_ENCODING=\"utf-8\" -DHAVE_STDIO_H=1 -DHAVE_STDLIB_H=1 -DHAVE_STRING_H=1 -DHAVE_INTTYPES_H=1 -DHAVE_STDINT_H=1 -DHAVE_STRINGS_H=1 -DHAVE_SYS_STAT_H=1 -DHAVE_SYS_TYPES_H=1 -DHAVE_UNISTD_H=1 -DSTDC_HEADERS=1 -DMODULE_SCOPE=extern -DTCL_CFG_DO64BIT=1 -DHAVE_NO_SEH=1 -DHAVE_STDBOOL_H=1 -DHAVE_CAST_TO_UNION=1 -DTCL_WITH_EXTERNAL_TOMMATH=1 -DMP_64BIT=1 -DHAVE_INTPTR_T=1 -DHAVE_UINTPTR_T=1 -DZIPFS_BUILD=1 -DHAVE_INTRIN_H=1 -DHAVE_WSPIAPI_H=1 -DNDEBUG=1 -DTCL_CFG_OPTIMIZED=1'
-# If TCL was built with debugging symbols, generated libraries contain
-# this string at the end of the library name (before the extension).
-TCL_DBGX=
-
# Default flags used in an optimized and debuggable build, respectively.
TCL_CFLAGS_DEBUG='-g'
TCL_CFLAGS_OPTIMIZE='-O2 -fomit-frame-pointer'
@@ -39,36 +35,33 @@
TCL_SHARED_BUILD=1
# The name of the Tcl library (may be either a .a file or a shared library):
-TCL_LIB_FILE='libtcl86.dll.a'
+TCL_LIB_FILE='libtcl90.dll.a'
+# The name of a zip containing the /library and /encodings (may be either a .zip file or a shared library):
+TCL_ZIP_FILE='libtcl9.0.1.zip'
+
# Flag to indicate whether shared libraries need export files.
-TCL_NEEDS_EXP_FILE=
+TCL_NEEDS_EXP_FILE=''
-# String that can be evaluated to generate the part of the export file
-# name that comes after the "libxxx" (includes version number, if any,
-# extension, and anything else needed). May depend on the variables
-# VERSION. On most UNIX systems this is ${VERSION}.exp.
-TCL_EXPORT_FILE_SUFFIX='${NODOT_VERSION}.a'
-
# Additional libraries to use when linking Tcl.
TCL_LIBS='-lnetapi32 -lkernel32 -luser32 -ladvapi32 -luserenv -lws2_32'
# Top-level directory in which Tcl's platform-independent files are
# installed.
-TCL_PREFIX='/home/siepo/tltcl'
+TCL_PREFIX='/x/tcltk'
# Top-level directory in which Tcl's platform-specific files (e.g.
# executables) are installed.
-TCL_EXEC_PREFIX='/home/siepo/tltcl'
+TCL_EXEC_PREFIX='/x/tcltk'
# Flags to pass to cc when compiling the components of a shared library:
TCL_SHLIB_CFLAGS=''
# Flags to pass to cc to get warning messages
-TCL_CFLAGS_WARNING='-Wall -Wpointer-arith -Wdeclaration-after-statement'
+TCL_CFLAGS_WARNING='-Wall -Wextra -Wshadow -Wundef -Wwrite-strings -Wpointer-arith -Wc++-compat -fextended-identifiers'
# Extra flags to pass to cc:
-TCL_EXTRA_CFLAGS='-pipe -DHAVE_CPUID=1'
+TCL_EXTRA_CFLAGS='-pipe -DHAVE_CPUID=1 -finput-charset=UTF-8'
# Base command to use for combining object files into a shared library:
TCL_SHLIB_LD='${CC} -shared'
@@ -77,7 +70,7 @@
TCL_STLIB_LD='${AR} cr'
# Either '$LIBS' (if dependent libraries should be included when linking
-# shared libraries) or an empty string. See Tcl's configure.in for more
+# shared libraries) or an empty string. See Tcl's configure.ac for more
# explanation.
TCL_SHLIB_LD_LIBS='${LIBS}'
@@ -104,28 +97,28 @@
TCL_COMPAT_OBJS=''
# Name of the ranlib program to use.
-TCL_RANLIB='x86_64-w64-mingw32-ranlib'
+TCL_RANLIB='ranlib'
# -l flag to pass to the linker to pick up the Tcl library
-TCL_LIB_FLAG=''
+TCL_LIB_FLAG='-ltcl90'
# String to pass to linker to pick up the Tcl library from its
# build directory.
-TCL_BUILD_LIB_SPEC='-L/tmp/siepo/tcl8.6.13/win -ltcl86'
+TCL_BUILD_LIB_SPEC='-LX:/tcltk/tcl9.0.1/win -ltcl90'
# String to pass to linker to pick up the Tcl library from its
# installed directory.
-TCL_LIB_SPEC='-L/home/siepo/tltcl/lib -ltcl86'
+TCL_LIB_SPEC='-L/x/tcltk/lib -ltcl90'
# String to pass to the compiler so that an extension can
# find installed Tcl headers.
-TCL_INCLUDE_SPEC='-I/home/siepo/tltcl/include'
+TCL_INCLUDE_SPEC='-I/x/tcltk/include'
# Indicates whether a version numbers should be used in -l switches
# ("ok" means it's safe to use switches like -ltcl7.5; "nodots" means
# use switches like -ltcl75). SunOS and FreeBSD require "nodots", for
# example.
-TCL_LIB_VERSIONS_OK=''
+TCL_LIB_VERSIONS_OK='nodots'
# String that can be evaluated to generate the part of a shared library
# name that comes after the "libxxx" (includes version number, if any,
@@ -146,36 +139,38 @@
# different place than the directory containing the source files, this
# points to the location of the sources, not the location where Tcl was
# compiled.
-TCL_SRC_DIR='/tmp/siepo/tcl8.6.13'
+TCL_SRC_DIR='X:/tcltk/tcl9.0.1'
# List of standard directories in which to look for packages during
# "package require" commands. Contains the "prefix" directory plus also
# the "exec_prefix" directory, if it is different.
-TCL_PACKAGE_PATH='{/home/siepo/tltcl/lib}'
+TCL_PACKAGE_PATH='/x/tcltk\lib'
# Tcl supports stub.
TCL_SUPPORTS_STUBS=1
# The name of the Tcl stub library (.a):
-TCL_STUB_LIB_FILE='libtclstub86.a'
+TCL_STUB_LIB_FILE='libtclstub.a'
# -l flag to pass to the linker to pick up the Tcl stub library
-TCL_STUB_LIB_FLAG='-ltclstub86'
+TCL_STUB_LIB_FLAG='-ltclstub'
# String to pass to linker to pick up the Tcl stub library from its
# build directory.
-TCL_BUILD_STUB_LIB_SPEC='-L/tmp/siepo/tcl8.6.13/win -ltclstub86'
+TCL_BUILD_STUB_LIB_SPEC='-LX:/tcltk/tcl9.0.1/win -ltclstub'
# String to pass to linker to pick up the Tcl stub library from its
# installed directory.
-TCL_STUB_LIB_SPEC='-L/home/siepo/tltcl/lib -ltclstub86'
+TCL_STUB_LIB_SPEC='-L/x/tcltk/lib -ltclstub'
# Path to the Tcl stub library in the build directory.
-TCL_BUILD_STUB_LIB_PATH='/tmp/siepo/tcl8.6.13/win/libtclstub86.a'
+TCL_BUILD_STUB_LIB_PATH='X:/tcltk/tcl9.0.1/win/libtclstub.a'
# Path to the Tcl stub library in the install directory.
-TCL_STUB_LIB_PATH='/home/siepo/tltcl/lib/libtclstub86.a'
+TCL_STUB_LIB_PATH='/x/tcltk/lib/libtclstub.a'
-# Flag, 1: we built Tcl with threads enabled, 0 we didn't
-TCL_THREADS=1
+# Name of the zlib library that extensions should use
+TCL_ZLIB_LIB_NAME='libz.dll.a'
+# Name of the tommath library that extensions should use
+TCL_TOMMATH_LIB_NAME='libtommath.dll.a'
Modified: trunk/Master/tlpkg/tltcl/lib/tclooConfig.sh
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tclooConfig.sh 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/tclooConfig.sh 2025-02-24 13:59:26 UTC (rev 74255)
@@ -16,4 +16,4 @@
TCLOO_INCLUDE_SPEC=""
TCLOO_PRIVATE_INCLUDE_SPEC=""
TCLOO_CFLAGS=""
-TCLOO_VERSION=1.1.0
+TCLOO_VERSION=1.3
Added: trunk/Master/tlpkg/tltcl/lib/tdbc1.1.10/libtdbcstub.a
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tdbc1.1.10/libtdbcstub.a
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbc1.1.10/libtdbcstub.a 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/tdbc1.1.10/libtdbcstub.a 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbc1.1.10/libtdbcstub.a
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+application/x-archive
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbc1.1.10/pkgIndex.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbc1.1.10/pkgIndex.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tdbc1.1.10/pkgIndex.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,26 @@
+# -*- tcl -*-
+# Tcl package index file, version 1.1
+#
+# Make sure that TDBC is running in a compatible version of Tcl, and
+# that TclOO is available.
+
+if {![package vsatisfies [package provide Tcl] 8.6-]} {
+ return
+}
+apply {{dir} {
+ set libraryfile [file join $dir tdbc.tcl]
+ if {![file exists $libraryfile] && [info exists ::env(TDBC_LIBRARY)]} {
+ set libraryfile [file join $::env(TDBC_LIBRARY) tdbc.tcl]
+ }
+ if {[package vsatisfies [package provide Tcl] 9.0-]} {
+ package ifneeded tdbc 1.1.10 \
+ "package require TclOO;\
+ [list load [file join $dir tcl9tdbc1110.dll] [string totitle tdbc]]\;\
+ [list source -encoding utf-8 $libraryfile]"
+ } else {
+ package ifneeded tdbc 1.1.10 \
+ "package require TclOO;\
+ [list load [file join $dir tdbc1110.dll] [string totitle tdbc]]\;\
+ [list source -encoding utf-8 $libraryfile]"
+ }
+}} $dir
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbc1.1.10/pkgIndex.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbc1.1.10/tcl9tdbc1110.dll
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tdbc1.1.10/tcl9tdbc1110.dll
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbc1.1.10/tcl9tdbc1110.dll 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/tdbc1.1.10/tcl9tdbc1110.dll 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbc1.1.10/tcl9tdbc1110.dll
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+application/vnd.microsoft.portable-executable
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbc1.1.10/tdbc.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbc1.1.10/tdbc.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tdbc1.1.10/tdbc.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,922 @@
+# tdbc.tcl --
+#
+# Definitions of base classes from which TDBC drivers' connections,
+# statements and result sets may inherit.
+#
+# Copyright (c) 2008 by Kevin B. Kenny
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id$
+#
+#------------------------------------------------------------------------------
+
+package require TclOO
+
+namespace eval ::tdbc {
+ namespace export connection statement resultset
+ variable generalError [list TDBC GENERAL_ERROR HY000 {}]
+}
+
+#------------------------------------------------------------------------------
+#
+# tdbc::ParseConvenienceArgs --
+#
+# Parse the convenience arguments to a TDBC 'execute',
+# 'executewithdictionary', or 'foreach' call.
+#
+# Parameters:
+# argv - Arguments to the call
+# optsVar -- Name of a variable in caller's scope that will receive
+# a dictionary of the supplied options
+#
+# Results:
+# Returns any args remaining after parsing the options.
+#
+# Side effects:
+# Sets the 'opts' dictionary to the options.
+#
+#------------------------------------------------------------------------------
+
+proc tdbc::ParseConvenienceArgs {argv optsVar} {
+
+ variable generalError
+ upvar 1 $optsVar opts
+
+ set opts [dict create -as dicts]
+ set i 0
+
+ # Munch keyword options off the front of the command arguments
+
+ foreach {key value} $argv {
+ if {[string index $key 0] eq {-}} {
+ switch -regexp -- $key {
+ -as? {
+ if {$value ne {dicts} && $value ne {lists}} {
+ set errorcode $generalError
+ lappend errorcode badVarType $value
+ return -code error \
+ -errorcode $errorcode \
+ "bad variable type \"$value\":\
+ must be lists or dicts"
+ }
+ dict set opts -as $value
+ }
+ -c(?:o(?:l(?:u(?:m(?:n(?:s(?:v(?:a(?:r(?:i(?:a(?:b(?:le?)?)?)?)?)?)?)?)?)?)?)?)?) {
+ dict set opts -columnsvariable $value
+ }
+ -- {
+ incr i
+ break
+ }
+ default {
+ set errorcode $generalError
+ lappend errorcode badOption $key
+ return -code error \
+ -errorcode $errorcode \
+ "bad option \"$key\":\
+ must be -as or -columnsvariable"
+ }
+ }
+ } else {
+ break
+ }
+ incr i 2
+ }
+
+ return [lrange $argv[set argv {}] $i end]
+
+}
+
+
+
+#------------------------------------------------------------------------------
+#
+# tdbc::connection --
+#
+# Class that represents a generic connection to a database.
+#
+#-----------------------------------------------------------------------------
+
+oo::class create ::tdbc::connection {
+
+ # statementSeq is the sequence number of the last statement created.
+ # statementClass is the name of the class that implements the
+ # 'statement' API.
+ # primaryKeysStatement is the statement that queries primary keys
+ # foreignKeysStatement is the statement that queries foreign keys
+
+ variable statementSeq primaryKeysStatement foreignKeysStatement
+
+ # The base class constructor accepts no arguments. It sets up the
+ # machinery to do the bookkeeping to keep track of what statements
+ # are associated with the connection. The derived class constructor
+ # is expected to set the variable, 'statementClass' to the name
+ # of the class that represents statements, so that the 'prepare'
+ # method can invoke it.
+
+ constructor {} {
+ set statementSeq 0
+ namespace eval Stmt {}
+ }
+
+ # The 'close' method is simply an alternative syntax for destroying
+ # the connection.
+
+ method close {} {
+ my destroy
+ }
+
+ # The 'prepare' method creates a new statement against the connection,
+ # giving its constructor the current statement and the SQL code to
+ # prepare. It uses the 'statementClass' variable set by the constructor
+ # to get the class to instantiate.
+
+ method prepare {sqlcode} {
+ return [my statementCreate Stmt::[incr statementSeq] [self] $sqlcode]
+ }
+
+ # The 'statementCreate' method delegates to the constructor
+ # of the class specified by the 'statementClass' variable. It's
+ # intended for drivers designed before tdbc 1.0b10. Current ones
+ # should forward this method to the constructor directly.
+
+ method statementCreate {name instance sqlcode} {
+ my variable statementClass
+ return [$statementClass create $name $instance $sqlcode]
+ }
+
+ # Derived classes are expected to implement the 'prepareCall' method,
+ # and have it call 'prepare' as needed (or do something else and
+ # install the resulting statement)
+
+ # The 'statements' method lists the statements active against this
+ # connection.
+
+ method statements {} {
+ info commands Stmt::*
+ }
+
+ # The 'resultsets' method lists the result sets active against this
+ # connection.
+
+ method resultsets {} {
+ set retval {}
+ foreach statement [my statements] {
+ foreach resultset [$statement resultsets] {
+ lappend retval $resultset
+ }
+ }
+ return $retval
+ }
+
+ # The 'transaction' method executes a block of Tcl code as an
+ # ACID transaction against the database.
+
+ method transaction {script} {
+ my begintransaction
+ set status [catch {uplevel 1 $script} result options]
+ if {$status in {0 2 3 4}} {
+ set status2 [catch {my commit} result2 options2]
+ if {$status2 == 1} {
+ set status 1
+ set result $result2
+ set options $options2
+ }
+ }
+ switch -exact -- $status {
+ 0 {
+ # do nothing
+ }
+ 2 - 3 - 4 {
+ set options [dict merge {-level 1} $options[set options {}]]
+ dict incr options -level
+ }
+ default {
+ my rollback
+ }
+ }
+ return -options $options $result
+ }
+
+ # The 'allrows' method prepares a statement, then executes it with
+ # a given set of substituents, returning a list of all the rows
+ # that the statement returns. Optionally, it stores the names of
+ # the columns in '-columnsvariable'.
+ # Usage:
+ # $db allrows ?-as lists|dicts? ?-columnsvariable varName? ?--?
+ # sql ?dictionary?
+
+ method allrows args {
+
+ variable ::tdbc::generalError
+
+ # Grab keyword-value parameters
+
+ set args [::tdbc::ParseConvenienceArgs $args[set args {}] opts]
+
+ # Check postitional parameters
+
+ set cmd [list [self] prepare]
+ if {[llength $args] == 1} {
+ set sqlcode [lindex $args 0]
+ } elseif {[llength $args] == 2} {
+ lassign $args sqlcode dict
+ } else {
+ set errorcode $generalError
+ lappend errorcode wrongNumArgs
+ return -code error -errorcode $errorcode \
+ "wrong # args: should be [lrange [info level 0] 0 1]\
+ ?-option value?... ?--? sqlcode ?dictionary?"
+ }
+ lappend cmd $sqlcode
+
+ # Prepare the statement
+
+ set stmt [uplevel 1 $cmd]
+
+ # Delegate to the statement to accumulate the results
+
+ set cmd [list $stmt allrows {*}$opts --]
+ if {[info exists dict]} {
+ lappend cmd $dict
+ }
+ set status [catch {
+ uplevel 1 $cmd
+ } result options]
+
+ # Destroy the statement
+
+ catch {
+ $stmt close
+ }
+
+ return -options $options $result
+ }
+
+ # The 'foreach' method prepares a statement, then executes it with
+ # a supplied set of substituents. For each row of the result,
+ # it sets a variable to the row and invokes a script in the caller's
+ # scope.
+ #
+ # Usage:
+ # $db foreach ?-as lists|dicts? ?-columnsVariable varName? ?--?
+ # varName sql ?dictionary? script
+
+ method foreach args {
+
+ variable ::tdbc::generalError
+
+ # Grab keyword-value parameters
+
+ set args [::tdbc::ParseConvenienceArgs $args[set args {}] opts]
+
+ # Check postitional parameters
+
+ set cmd [list [self] prepare]
+ if {[llength $args] == 3} {
+ lassign $args varname sqlcode script
+ } elseif {[llength $args] == 4} {
+ lassign $args varname sqlcode dict script
+ } else {
+ set errorcode $generalError
+ lappend errorcode wrongNumArgs
+ return -code error -errorcode $errorcode \
+ "wrong # args: should be [lrange [info level 0] 0 1]\
+ ?-option value?... ?--? varname sqlcode ?dictionary? script"
+ }
+ lappend cmd $sqlcode
+
+ # Prepare the statement
+
+ set stmt [uplevel 1 $cmd]
+
+ # Delegate to the statement to iterate over the results
+
+ set cmd [list $stmt foreach {*}$opts -- $varname]
+ if {[info exists dict]} {
+ lappend cmd $dict
+ }
+ lappend cmd $script
+ set status [catch {
+ uplevel 1 $cmd
+ } result options]
+
+ # Destroy the statement
+
+ catch {
+ $stmt close
+ }
+
+ # Adjust return level in the case that the script [return]s
+
+ if {$status == 2} {
+ set options [dict merge {-level 1} $options[set options {}]]
+ dict incr options -level
+ }
+ return -options $options $result
+ }
+
+ # The 'BuildPrimaryKeysStatement' method builds a SQL statement to
+ # retrieve the primary keys from a database. (It executes once the
+ # first time the 'primaryKeys' method is executed, and retains the
+ # prepared statement for reuse.)
+
+ method BuildPrimaryKeysStatement {} {
+
+ # On some databases, CONSTRAINT_CATALOG is always NULL and
+ # JOINing to it fails. Check for this case and include that
+ # JOIN only if catalog names are supplied.
+
+ set catalogClause {}
+ if {[lindex [set count [my allrows -as lists {
+ SELECT COUNT(*)
+ FROM INFORMATION_SCHEMA.TABLE_CONSTRAINTS
+ WHERE CONSTRAINT_CATALOG IS NOT NULL}]] 0 0] != 0} {
+ set catalogClause \
+ {AND xtable.CONSTRAINT_CATALOG = xcolumn.CONSTRAINT_CATALOG}
+ }
+ set primaryKeysStatement [my prepare "
+ SELECT xtable.TABLE_SCHEMA AS \"tableSchema\",
+ xtable.TABLE_NAME AS \"tableName\",
+ xtable.CONSTRAINT_CATALOG AS \"constraintCatalog\",
+ xtable.CONSTRAINT_SCHEMA AS \"constraintSchema\",
+ xtable.CONSTRAINT_NAME AS \"constraintName\",
+ xcolumn.COLUMN_NAME AS \"columnName\",
+ xcolumn.ORDINAL_POSITION AS \"ordinalPosition\"
+ FROM INFORMATION_SCHEMA.TABLE_CONSTRAINTS xtable
+ INNER JOIN INFORMATION_SCHEMA.KEY_COLUMN_USAGE xcolumn
+ ON xtable.CONSTRAINT_SCHEMA = xcolumn.CONSTRAINT_SCHEMA
+ AND xtable.TABLE_NAME = xcolumn.TABLE_NAME
+ AND xtable.CONSTRAINT_NAME = xcolumn.CONSTRAINT_NAME
+ $catalogClause
+ WHERE xtable.TABLE_NAME = :tableName
+ AND xtable.CONSTRAINT_TYPE = 'PRIMARY KEY'
+ "]
+ }
+
+ # The default implementation of the 'primarykeys' method uses the
+ # SQL INFORMATION_SCHEMA to retrieve primary key information. Databases
+ # that might not have INFORMATION_SCHEMA must overload this method.
+
+ method primarykeys {tableName} {
+ if {![info exists primaryKeysStatement]} {
+ my BuildPrimaryKeysStatement
+ }
+ tailcall $primaryKeysStatement allrows [list tableName $tableName]
+ }
+
+ # The 'BuildForeignKeysStatements' method builds a SQL statement to
+ # retrieve the foreign keys from a database. (It executes once the
+ # first time the 'foreignKeys' method is executed, and retains the
+ # prepared statements for reuse.)
+
+ method BuildForeignKeysStatement {} {
+
+ # On some databases, CONSTRAINT_CATALOG is always NULL and
+ # JOINing to it fails. Check for this case and include that
+ # JOIN only if catalog names are supplied.
+
+ set catalogClause1 {}
+ set catalogClause2 {}
+ if {[lindex [set count [my allrows -as lists {
+ SELECT COUNT(*)
+ FROM INFORMATION_SCHEMA.TABLE_CONSTRAINTS
+ WHERE CONSTRAINT_CATALOG IS NOT NULL}]] 0 0] != 0} {
+ set catalogClause1 \
+ {AND fkc.CONSTRAINT_CATALOG = rc.CONSTRAINT_CATALOG}
+ set catalogClause2 \
+ {AND pkc.CONSTRAINT_CATALOG = rc.CONSTRAINT_CATALOG}
+ }
+
+ foreach {exists1 clause1} {
+ 0 {}
+ 1 { AND pkc.TABLE_NAME = :primary}
+ } {
+ foreach {exists2 clause2} {
+ 0 {}
+ 1 { AND fkc.TABLE_NAME = :foreign}
+ } {
+ set stmt [my prepare "
+ SELECT rc.CONSTRAINT_CATALOG AS \"foreignConstraintCatalog\",
+ rc.CONSTRAINT_SCHEMA AS \"foreignConstraintSchema\",
+ rc.CONSTRAINT_NAME AS \"foreignConstraintName\",
+ rc.UNIQUE_CONSTRAINT_CATALOG
+ AS \"primaryConstraintCatalog\",
+ rc.UNIQUE_CONSTRAINT_SCHEMA AS \"primaryConstraintSchema\",
+ rc.UNIQUE_CONSTRAINT_NAME AS \"primaryConstraintName\",
+ rc.UPDATE_RULE AS \"updateAction\",
+ rc.DELETE_RULE AS \"deleteAction\",
+ pkc.TABLE_CATALOG AS \"primaryCatalog\",
+ pkc.TABLE_SCHEMA AS \"primarySchema\",
+ pkc.TABLE_NAME AS \"primaryTable\",
+ pkc.COLUMN_NAME AS \"primaryColumn\",
+ fkc.TABLE_CATALOG AS \"foreignCatalog\",
+ fkc.TABLE_SCHEMA AS \"foreignSchema\",
+ fkc.TABLE_NAME AS \"foreignTable\",
+ fkc.COLUMN_NAME AS \"foreignColumn\",
+ pkc.ORDINAL_POSITION AS \"ordinalPosition\"
+ FROM INFORMATION_SCHEMA.REFERENTIAL_CONSTRAINTS rc
+ INNER JOIN INFORMATION_SCHEMA.KEY_COLUMN_USAGE fkc
+ ON fkc.CONSTRAINT_NAME = rc.CONSTRAINT_NAME
+ AND fkc.CONSTRAINT_SCHEMA = rc.CONSTRAINT_SCHEMA
+ $catalogClause1
+ INNER JOIN INFORMATION_SCHEMA.KEY_COLUMN_USAGE pkc
+ ON pkc.CONSTRAINT_NAME = rc.UNIQUE_CONSTRAINT_NAME
+ AND pkc.CONSTRAINT_SCHEMA = rc.UNIQUE_CONSTRAINT_SCHEMA
+ $catalogClause2
+ AND pkc.ORDINAL_POSITION = fkc.ORDINAL_POSITION
+ WHERE 1=1
+ $clause1
+ $clause2
+ ORDER BY \"foreignConstraintCatalog\", \"foreignConstraintSchema\", \"foreignConstraintName\", \"ordinalPosition\"
+"]
+ dict set foreignKeysStatement $exists1 $exists2 $stmt
+ }
+ }
+ }
+
+ # The default implementation of the 'foreignkeys' method uses the
+ # SQL INFORMATION_SCHEMA to retrieve primary key information. Databases
+ # that might not have INFORMATION_SCHEMA must overload this method.
+
+ method foreignkeys {args} {
+
+ variable ::tdbc::generalError
+
+ # Check arguments
+
+ set argdict {}
+ if {[llength $args] % 2 != 0} {
+ set errorcode $generalError
+ lappend errorcode wrongNumArgs
+ return -code error -errorcode $errorcode \
+ "wrong # args: should be [lrange [info level 0] 0 1]\
+ ?-option value?..."
+ }
+ foreach {key value} $args {
+ if {$key ni {-primary -foreign}} {
+ set errorcode $generalError
+ lappend errorcode badOption
+ return -code error -errorcode $errorcode \
+ "bad option \"$key\", must be -primary or -foreign"
+ }
+ set key [string range $key 1 end]
+ if {[dict exists $argdict $key]} {
+ set errorcode $generalError
+ lappend errorcode dupOption
+ return -code error -errorcode $errorcode \
+ "duplicate option \"$key\" supplied"
+ }
+ dict set argdict $key $value
+ }
+
+ # Build the statements that query foreign keys. There are four
+ # of them, one for each combination of whether -primary
+ # and -foreign is specified.
+
+ if {![info exists foreignKeysStatement]} {
+ my BuildForeignKeysStatement
+ }
+ set stmt [dict get $foreignKeysStatement \
+ [dict exists $argdict primary] \
+ [dict exists $argdict foreign]]
+ tailcall $stmt allrows $argdict
+ }
+
+ # Derived classes are expected to implement the 'begintransaction',
+ # 'commit', and 'rollback' methods.
+
+ # Derived classes are expected to implement 'tables' and 'columns' method.
+
+}
+
+#------------------------------------------------------------------------------
+#
+# Class: tdbc::statement
+#
+# Class that represents a SQL statement in a generic database
+#
+#------------------------------------------------------------------------------
+
+oo::class create tdbc::statement {
+
+ # resultSetSeq is the sequence number of the last result set created.
+ # resultSetClass is the name of the class that implements the 'resultset'
+ # API.
+
+ variable resultSetClass resultSetSeq
+
+ # The base class constructor accepts no arguments. It initializes
+ # the machinery for tracking the ownership of result sets. The derived
+ # constructor is expected to invoke the base constructor, and to
+ # set a variable 'resultSetClass' to the fully-qualified name of the
+ # class that represents result sets.
+
+ constructor {} {
+ set resultSetSeq 0
+ namespace eval ResultSet {}
+ }
+
+ # The 'execute' method on a statement runs the statement with
+ # a particular set of substituted variables. It actually works
+ # by creating the result set object and letting that objects
+ # constructor do the work of running the statement. The creation
+ # is wrapped in an [uplevel] call because the substitution proces
+ # may need to access variables in the caller's scope.
+
+ # WORKAROUND: Take out the '0 &&' from the next line when
+ # Bug 2649975 is fixed
+ if {0 && [package vsatisfies [package provide Tcl] 8.6]} {
+ method execute args {
+ tailcall my resultSetCreate \
+ [namespace current]::ResultSet::[incr resultSetSeq] \
+ [self] {*}$args
+ }
+ } else {
+ method execute args {
+ return \
+ [uplevel 1 \
+ [list \
+ [self] resultSetCreate \
+ [namespace current]::ResultSet::[incr resultSetSeq] \
+ [self] {*}$args]]
+ }
+ }
+
+ # The 'ResultSetCreate' method is expected to be a forward to the
+ # appropriate result set constructor. If it's missing, the driver must
+ # have been designed for tdbc 1.0b9 and earlier, and the 'resultSetClass'
+ # variable holds the class name.
+
+ method resultSetCreate {name instance args} {
+ return [uplevel 1 [list $resultSetClass create \
+ $name $instance {*}$args]]
+ }
+
+ # The 'resultsets' method returns a list of result sets produced by
+ # the current statement
+
+ method resultsets {} {
+ info commands ResultSet::*
+ }
+
+ # The 'allrows' method executes a statement with a given set of
+ # substituents, and returns a list of all the rows that the statement
+ # returns. Optionally, it stores the names of columns in
+ # '-columnsvariable'.
+ #
+ # Usage:
+ # $statement allrows ?-as lists|dicts? ?-columnsvariable varName? ?--?
+ # ?dictionary?
+
+
+ method allrows args {
+
+ variable ::tdbc::generalError
+
+ # Grab keyword-value parameters
+
+ set args [::tdbc::ParseConvenienceArgs $args[set args {}] opts]
+
+ # Check postitional parameters
+
+ set cmd [list [self] execute]
+ if {[llength $args] == 0} {
+ # do nothing
+ } elseif {[llength $args] == 1} {
+ lappend cmd [lindex $args 0]
+ } else {
+ set errorcode $generalError
+ lappend errorcode wrongNumArgs
+ return -code error -errorcode $errorcode \
+ "wrong # args: should be [lrange [info level 0] 0 1]\
+ ?-option value?... ?--? ?dictionary?"
+ }
+
+ # Get the result set
+
+ set resultSet [uplevel 1 $cmd]
+
+ # Delegate to the result set's [allrows] method to accumulate
+ # the rows of the result.
+
+ set cmd [list $resultSet allrows {*}$opts]
+ set status [catch {
+ uplevel 1 $cmd
+ } result options]
+
+ # Destroy the result set
+
+ catch {
+ rename $resultSet {}
+ }
+
+ # Adjust return level in the case that the script [return]s
+
+ if {$status == 2} {
+ set options [dict merge {-level 1} $options[set options {}]]
+ dict incr options -level
+ }
+ return -options $options $result
+ }
+
+ # The 'foreach' method executes a statement with a given set of
+ # substituents. It runs the supplied script, substituting the supplied
+ # named variable. Optionally, it stores the names of columns in
+ # '-columnsvariable'.
+ #
+ # Usage:
+ # $statement foreach ?-as lists|dicts? ?-columnsvariable varName? ?--?
+ # variableName ?dictionary? script
+
+ method foreach args {
+
+ variable ::tdbc::generalError
+
+ # Grab keyword-value parameters
+
+ set args [::tdbc::ParseConvenienceArgs $args[set args {}] opts]
+
+ # Check positional parameters
+
+ set cmd [list [self] execute]
+ if {[llength $args] == 2} {
+ lassign $args varname script
+ } elseif {[llength $args] == 3} {
+ lassign $args varname dict script
+ lappend cmd $dict
+ } else {
+ set errorcode $generalError
+ lappend errorcode wrongNumArgs
+ return -code error -errorcode $errorcode \
+ "wrong # args: should be [lrange [info level 0] 0 1]\
+ ?-option value?... ?--? varName ?dictionary? script"
+ }
+
+ # Get the result set
+
+ set resultSet [uplevel 1 $cmd]
+
+ # Delegate to the result set's [foreach] method to evaluate
+ # the script for each row of the result.
+
+ set cmd [list $resultSet foreach {*}$opts -- $varname $script]
+ set status [catch {
+ uplevel 1 $cmd
+ } result options]
+
+ # Destroy the result set
+
+ catch {
+ rename $resultSet {}
+ }
+
+ # Adjust return level in the case that the script [return]s
+
+ if {$status == 2} {
+ set options [dict merge {-level 1} $options[set options {}]]
+ dict incr options -level
+ }
+ return -options $options $result
+ }
+
+ # The 'close' method is syntactic sugar for invoking the destructor
+
+ method close {} {
+ my destroy
+ }
+
+ # Derived classes are expected to implement their own constructors,
+ # plus the following methods:
+
+ # paramtype paramName ?direction? type ?scale ?precision??
+ # Declares the type of a parameter in the statement
+
+}
+
+#------------------------------------------------------------------------------
+#
+# Class: tdbc::resultset
+#
+# Class that represents a result set in a generic database.
+#
+#------------------------------------------------------------------------------
+
+oo::class create tdbc::resultset {
+
+ constructor {} { }
+
+ # The 'allrows' method returns a list of all rows that a given
+ # result set returns.
+
+ method allrows args {
+
+ variable ::tdbc::generalError
+
+ # Parse args
+
+ set args [::tdbc::ParseConvenienceArgs $args[set args {}] opts]
+ if {[llength $args] != 0} {
+ set errorcode $generalError
+ lappend errorcode wrongNumArgs
+ return -code error -errorcode $errorcode \
+ "wrong # args: should be [lrange [info level 0] 0 1]\
+ ?-option value?... ?--? varName script"
+ }
+
+ # Do -columnsvariable if requested
+
+ if {[dict exists $opts -columnsvariable]} {
+ upvar 1 [dict get $opts -columnsvariable] columns
+ }
+
+ # Assemble the results
+
+ if {[dict get $opts -as] eq {lists}} {
+ set delegate nextlist
+ } else {
+ set delegate nextdict
+ }
+ set results [list]
+ while {1} {
+ set columns [my columns]
+ while {[my $delegate row]} {
+ lappend results $row
+ }
+ if {![my nextresults]} break
+ }
+ return $results
+
+ }
+
+ # The 'foreach' method runs a script on each row from a result set.
+
+ method foreach args {
+
+ variable ::tdbc::generalError
+
+ # Grab keyword-value parameters
+
+ set args [::tdbc::ParseConvenienceArgs $args[set args {}] opts]
+
+ # Check positional parameters
+
+ if {[llength $args] != 2} {
+ set errorcode $generalError
+ lappend errorcode wrongNumArgs
+ return -code error -errorcode $errorcode \
+ "wrong # args: should be [lrange [info level 0] 0 1]\
+ ?-option value?... ?--? varName script"
+ }
+
+ # Do -columnsvariable if requested
+
+ if {[dict exists $opts -columnsvariable]} {
+ upvar 1 [dict get $opts -columnsvariable] columns
+ }
+
+ # Iterate over the groups of results
+ while {1} {
+
+ # Export column names to caller
+
+ set columns [my columns]
+
+ # Iterate over the rows of one group of results
+
+ upvar 1 [lindex $args 0] row
+ if {[dict get $opts -as] eq {lists}} {
+ set delegate nextlist
+ } else {
+ set delegate nextdict
+ }
+ while {[my $delegate row]} {
+ set status [catch {
+ uplevel 1 [lindex $args 1]
+ } result options]
+ switch -exact -- $status {
+ 0 - 4 { # OK or CONTINUE
+ }
+ 2 { # RETURN
+ set options \
+ [dict merge {-level 1} $options[set options {}]]
+ dict incr options -level
+ return -options $options $result
+ }
+ 3 { # BREAK
+ set broken 1
+ break
+ }
+ default { # ERROR or unknown status
+ return -options $options $result
+ }
+ }
+ }
+
+ # Advance to the next group of results if there is one
+
+ if {[info exists broken] || ![my nextresults]} {
+ break
+ }
+ }
+
+ return
+ }
+
+
+ # The 'nextrow' method retrieves a row in the form of either
+ # a list or a dictionary.
+
+ method nextrow {args} {
+
+ variable ::tdbc::generalError
+
+ set opts [dict create -as dicts]
+ set i 0
+
+ # Munch keyword options off the front of the command arguments
+
+ foreach {key value} $args {
+ if {[string index $key 0] eq {-}} {
+ switch -regexp -- $key {
+ -as? {
+ dict set opts -as $value
+ }
+ -- {
+ incr i
+ break
+ }
+ default {
+ set errorcode $generalError
+ lappend errorcode badOption $key
+ return -code error -errorcode $errorcode \
+ "bad option \"$key\":\
+ must be -as or -columnsvariable"
+ }
+ }
+ } else {
+ break
+ }
+ incr i 2
+ }
+
+ set args [lrange $args $i end]
+ if {[llength $args] != 1} {
+ set errorcode $generalError
+ lappend errorcode wrongNumArgs
+ return -code error -errorcode $errorcode \
+ "wrong # args: should be [lrange [info level 0] 0 1]\
+ ?-option value?... ?--? varName"
+ }
+ upvar 1 [lindex $args 0] row
+ if {[dict get $opts -as] eq {lists}} {
+ set delegate nextlist
+ } else {
+ set delegate nextdict
+ }
+ return [my $delegate row]
+ }
+
+ # Derived classes must override 'nextresults' if a single
+ # statement execution can yield multiple sets of results
+
+ method nextresults {} {
+ return 0
+ }
+
+ # Derived classes must override 'outputparams' if statements can
+ # have output parameters.
+
+ method outputparams {} {
+ return {}
+ }
+
+ # The 'close' method is syntactic sugar for destroying the result set.
+
+ method close {} {
+ my destroy
+ }
+
+ # Derived classes are expected to implement the following methods:
+
+ # constructor and destructor.
+ # Constructor accepts a statement and an optional
+ # a dictionary of substituted parameters and
+ # executes the statement against the database. If
+ # the dictionary is not supplied, then the default
+ # is to get params from variables in the caller's scope).
+ # columns
+ # -- Returns a list of the names of the columns in the result.
+ # nextdict variableName
+ # -- Stores the next row of the result set in the given variable
+ # in caller's scope, in the form of a dictionary that maps
+ # column names to values.
+ # nextlist variableName
+ # -- Stores the next row of the result set in the given variable
+ # in caller's scope, in the form of a list of cells.
+ # rowcount
+ # -- Returns a count of rows affected by the statement, or -1
+ # if the count of rows has not been determined.
+
+}
\ No newline at end of file
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbc1.1.10/tdbc.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbc1.1.10/tdbcConfig.sh
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbc1.1.10/tdbcConfig.sh (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tdbc1.1.10/tdbcConfig.sh 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,81 @@
+# tdbcConfig.sh --
+#
+# This shell script (for sh) is generated automatically by TDBC's configure
+# script. It will create shell variables for most of the configuration options
+# discovered by the configure script. This script is intended to be included
+# by the configure scripts for TDBC extensions so that they don't have to
+# figure this all out for themselves.
+#
+# The information in this file is specific to a single platform.
+#
+# RCS: @(#) $Id$
+
+# TDBC's version number
+tdbc_VERSION=1.1.10
+TDBC_VERSION=1.1.10
+
+# Name of the TDBC library - may be either a static or shared library
+tdbc_LIB_FILE=tcl9tdbc1110.dll
+TDBC_LIB_FILE=tcl9tdbc1110.dll
+
+# String to pass to the linker to pick up the TDBC library from its build dir
+tdbc_BUILD_LIB_SPEC="-LX:/tcltk/tcl9.0.1/win/pkgs/tdbc1.1.10 -ltdbc1110"
+TDBC_BUILD_LIB_SPEC="-LX:/tcltk/tcl9.0.1/win/pkgs/tdbc1.1.10 -ltdbc1110"
+
+# String to pass to the linker to pick up the TDBC library from its installed
+# dir.
+tdbc_LIB_SPEC="-LX:/tcltk/lib/tdbc1.1.10 -ltdbc1110"
+TDBC_LIB_SPEC="-LX:/tcltk/lib/tdbc1.1.10 -ltdbc1110"
+
+# Name of the TBDC stub library
+tdbc_STUB_LIB_FILE="libtdbcstub.a"
+TDBC_STUB_LIB_FILE="libtdbcstub.a"
+
+# String to pass to the linker to pick up the TDBC stub library from its
+# build directory
+tdbc_BUILD_STUB_LIB_SPEC="-LX:/tcltk/tcl9.0.1/win/pkgs/tdbc1.1.10 -ltdbcstub"
+TDBC_BUILD_STUB_LIB_SPEC="-LX:/tcltk/tcl9.0.1/win/pkgs/tdbc1.1.10 -ltdbcstub"
+
+# String to pass to the linker to pick up the TDBC stub library from its
+# installed directory
+tdbc_STUB_LIB_SPEC="-LX:/tcltk/lib/tdbc1.1.10 -ltdbcstub"
+TDBC_STUB_LIB_SPEC="-LX:/tcltk/lib/tdbc1.1.10 -ltdbcstub"
+
+# Path name of the TDBC stub library in its build directory
+tdbc_BUILD_STUB_LIB_PATH="X:/tcltk/tcl9.0.1/win/pkgs/tdbc1.1.10/libtdbcstub.a"
+TDBC_BUILD_STUB_LIB_PATH="X:/tcltk/tcl9.0.1/win/pkgs/tdbc1.1.10/libtdbcstub.a"
+
+# Path name of the TDBC stub library in its installed directory
+tdbc_STUB_LIB_PATH="X:/tcltk/lib/tdbc1.1.10/libtdbcstub.a"
+TDBC_STUB_LIB_PATH="X:/tcltk/lib/tdbc1.1.10/libtdbcstub.a"
+
+# Location of the top-level source directories from which TDBC was built.
+# This is the directory that contains doc/, generic/ and so on. If TDBC
+# was compiled in a directory other than the source directory, this still
+# points to the location of the sources, not the location where TDBC was
+# compiled.
+tdbc_SRC_DIR="X:/tcltk/tcl9.0.1/pkgs/tdbc1.1.10"
+TDBC_SRC_DIR="X:/tcltk/tcl9.0.1/pkgs/tdbc1.1.10"
+
+# String to pass to the compiler so that an extension can find installed TDBC
+# headers
+tdbc_INCLUDE_SPEC="-I/x/tcltk/include"
+TDBC_INCLUDE_SPEC="-I/x/tcltk/include"
+
+# String to pass to the compiler so that an extension can find TDBC headers
+# in the source directory
+tdbc_BUILD_INCLUDE_SPEC="-IX:/tcltk/tcl9.0.1/pkgs/tdbc1.1.10/generic"
+TDBC_BUILD_INCLUDE_SPEC="-IX:/tcltk/tcl9.0.1/pkgs/tdbc1.1.10/generic"
+
+# Path name where .tcl files in the tdbc package appear at run time.
+tdbc_LIBRARY_PATH="/x/tcltk/lib/tdbc1.1.10"
+TDBC_LIBRARY_PATH="/x/tcltk/lib/tdbc1.1.10"
+
+# Path name where .tcl files in the tdbc package appear at build time.
+tdbc_BUILD_LIBRARY_PATH="X:/tcltk/tcl9.0.1/pkgs/tdbc1.1.10/library"
+TDBC_BUILD_LIBRARY_PATH="X:/tcltk/tcl9.0.1/pkgs/tdbc1.1.10/library"
+
+# Additional flags that must be passed to the C compiler to use tdbc
+tdbc_CFLAGS=
+TDBC_CFLAGS=
+
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbc1.1.10/tdbcConfig.sh
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.10/pkgIndex.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.10/pkgIndex.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.10/pkgIndex.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,14 @@
+# Index file to load the TDBC MySQL package.
+
+if {![package vsatisfies [package provide Tcl] 8.6-]} {
+ return
+}
+if {[package vsatisfies [package provide Tcl] 9.0-]} {
+ package ifneeded tdbc::mysql 1.1.10 \
+ "[list source -encoding utf-8 [file join $dir tdbcmysql.tcl]]\;\
+ [list load [file join $dir tcl9tdbcmysql1110.dll] [string totitle tdbcmysql]]"
+} else {
+ package ifneeded tdbc::mysql 1.1.10 \
+ "[list source -encoding utf-8 [file join $dir tdbcmysql.tcl]]\;\
+ [list load [file join $dir tdbcmysql1110.dll] [string totitle tdbcmysql]]"
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.10/pkgIndex.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.10/tcl9tdbcmysql1110.dll
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.10/tcl9tdbcmysql1110.dll
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.10/tcl9tdbcmysql1110.dll 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.10/tcl9tdbcmysql1110.dll 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.10/tcl9tdbcmysql1110.dll
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+application/vnd.microsoft.portable-executable
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.10/tdbcmysql.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.10/tdbcmysql.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.10/tdbcmysql.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,193 @@
+# tdbcmysql.tcl --
+#
+# Class definitions and Tcl-level methods for the tdbc::mysql bridge.
+#
+# Copyright (c) 2008 by Kevin B. Kenny
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: tdbcmysql.tcl,v 1.47 2008/02/27 02:08:27 kennykb Exp $
+#
+#------------------------------------------------------------------------------
+
+package require tdbc
+
+::namespace eval ::tdbc::mysql {
+
+ namespace export connection datasources drivers
+
+}
+
+#------------------------------------------------------------------------------
+#
+# tdbc::mysql::connection --
+#
+# Class representing a connection to a database through MYSQL.
+#
+#-------------------------------------------------------------------------------
+
+::oo::class create ::tdbc::mysql::connection {
+
+ superclass ::tdbc::connection
+
+ # The constructor is written in C. It takes alternating keywords
+ # and values pairs as its argumenta. (See the manual page for the
+ # available options.)
+
+ variable foreignKeysStatement
+
+ # The 'statementCreate' method delegates to the constructor of the
+ # statement class
+
+ forward statementCreate ::tdbc::mysql::statement create
+
+ # The 'columns' method returns a dictionary describing the tables
+ # in the database
+
+ method columns {table {pattern %}} {
+
+ # To return correct lengths of CHARACTER and BINARY columns,
+ # we need to know the maximum lengths of characters in each
+ # collation. We cache this information only once, on the first
+ # call to 'columns'.
+
+ if {[my NeedCollationInfo]} {
+ my SetCollationInfo {*}[my allrows -as lists {
+ SELECT coll.id, cs.maxlen
+ FROM INFORMATION_SCHEMA.COLLATIONS coll,
+ INFORMATION_SCHEMA.CHARACTER_SETS cs
+ WHERE cs.CHARACTER_SET_NAME = coll.CHARACTER_SET_NAME
+ ORDER BY coll.id DESC
+ }]
+ }
+
+ return [my Columns $table $pattern]
+ }
+
+ # The 'preparecall' method gives a portable interface to prepare
+ # calls to stored procedures. It delegates to 'prepare' to do the
+ # actual work.
+
+ method preparecall {call} {
+ regexp {^[[:space:]]*(?:([A-Za-z_][A-Za-z_0-9]*)[[:space:]]*=)?(.*)} \
+ $call -> varName rest
+ if {$varName eq {}} {
+ my prepare "CALL $rest"
+ } else {
+ my prepare \\{:$varName=$rest\\}
+ }
+ }
+
+ # The 'init', 'begintransaction', 'commit, 'rollback', 'tables'
+ # 'NeedCollationInfo', 'SetCollationInfo', and 'Columns' methods
+ # are implemented in C.
+
+ # The 'BuildForeignKeysStatements' method builds a SQL statement to
+ # retrieve the foreign keys from a database. (It executes once the
+ # first time the 'foreignKeys' method is executed, and retains the
+ # prepared statements for reuse.) It is slightly nonstandard because
+ # MYSQL doesn't name the PRIMARY constraints uniquely.
+
+ method BuildForeignKeysStatement {} {
+
+ foreach {exists1 clause1} {
+ 0 {}
+ 1 { AND fkc.REFERENCED_TABLE_NAME = :primary}
+ } {
+ foreach {exists2 clause2} {
+ 0 {}
+ 1 { AND fkc.TABLE_NAME = :foreign}
+ } {
+ set stmt [my prepare "
+ SELECT rc.CONSTRAINT_SCHEMA AS \"foreignConstraintSchema\",
+ rc.CONSTRAINT_NAME AS \"foreignConstraintName\",
+ rc.UPDATE_RULE AS \"updateAction\",
+ rc.DELETE_RULE AS \"deleteAction\",
+ fkc.REFERENCED_TABLE_SCHEMA AS \"primarySchema\",
+ fkc.REFERENCED_TABLE_NAME AS \"primaryTable\",
+ fkc.REFERENCED_COLUMN_NAME AS \"primaryColumn\",
+ fkc.TABLE_SCHEMA AS \"foreignSchema\",
+ fkc.TABLE_NAME AS \"foreignTable\",
+ fkc.COLUMN_NAME AS \"foreignColumn\",
+ fkc.ORDINAL_POSITION AS \"ordinalPosition\"
+ FROM INFORMATION_SCHEMA.REFERENTIAL_CONSTRAINTS rc
+ INNER JOIN INFORMATION_SCHEMA.KEY_COLUMN_USAGE fkc
+ ON fkc.CONSTRAINT_NAME = rc.CONSTRAINT_NAME
+ AND fkc.CONSTRAINT_SCHEMA = rc.CONSTRAINT_SCHEMA
+ WHERE 1=1
+ $clause1
+ $clause2
+"]
+ dict set foreignKeysStatement $exists1 $exists2 $stmt
+ }
+ }
+ }
+}
+
+#------------------------------------------------------------------------------
+#
+# tdbc::mysql::statement --
+#
+# The class 'tdbc::mysql::statement' models one statement against a
+# database accessed through an MYSQL connection
+#
+#------------------------------------------------------------------------------
+
+::oo::class create ::tdbc::mysql::statement {
+
+ superclass ::tdbc::statement
+
+ # The 'resultSetCreate' method forwards to the constructor of the
+ # result set.
+
+ forward resultSetCreate ::tdbc::mysql::resultset create
+
+ # Methods implemented in C:
+ #
+ # constructor connection SQLCode
+ # The constructor accepts the handle to the connection and the SQL code
+ # for the statement to prepare. It creates a subordinate namespace to
+ # hold the statement's active result sets, and then delegates to the
+ # 'init' method, written in C, to do the actual work of preparing the
+ # statement.
+ # params
+ # Returns descriptions of the parameters of a statement.
+ # paramtype paramname ?direction? type ?precision ?scale??
+ # Declares the type of a parameter in the statement
+
+}
+
+#------------------------------------------------------------------------------
+#
+# tdbc::mysql::resultset --
+#
+# The class 'tdbc::mysql::resultset' models the result set that is
+# produced by executing a statement against an MYSQL database.
+#
+#------------------------------------------------------------------------------
+
+::oo::class create ::tdbc::mysql::resultset {
+
+ superclass ::tdbc::resultset
+
+ # Methods implemented in C include:
+
+ # constructor statement ?dictionary?
+ # -- Executes the statement against the database, optionally providing
+ # a dictionary of substituted parameters (default is to get params
+ # from variables in the caller's scope).
+ # columns
+ # -- Returns a list of the names of the columns in the result.
+ # nextdict
+ # -- Stores the next row of the result set in the given variable in
+ # the caller's scope as a dictionary whose keys are
+ # column names and whose values are column values, or else
+ # as a list of cells.
+ # nextlist
+ # -- Stores the next row of the result set in the given variable in
+ # the caller's scope as a list of cells.
+ # rowcount
+ # -- Returns a count of rows affected by the statement, or -1
+ # if the count of rows has not been determined.
+
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.10/tdbcmysql.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.10/pkgIndex.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.10/pkgIndex.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.10/pkgIndex.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,14 @@
+# Index file to load the TDBC ODBC package.
+
+if {![package vsatisfies [package provide Tcl] 8.6-]} {
+ return
+}
+if {[package vsatisfies [package provide Tcl] 9.0-]} {
+ package ifneeded tdbc::odbc 1.1.10 \
+ "[list source -encoding utf-8 [file join $dir tdbcodbc.tcl]]\;\
+ [list load [file join $dir tcl9tdbcodbc1110.dll] [string totitle tdbcodbc]]"
+} else {
+ package ifneeded tdbc::odbc 1.1.10 \
+ "[list source -encoding utf-8 [file join $dir tdbcodbc.tcl]]\;\
+ [list load [file join $dir tdbcodbc1110.dll] [string totitle tdbcodbc]]"
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.10/pkgIndex.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.10/tcl9tdbcodbc1110.dll
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.10/tcl9tdbcodbc1110.dll
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.10/tcl9tdbcodbc1110.dll 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.10/tcl9tdbcodbc1110.dll 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.10/tcl9tdbcodbc1110.dll
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+application/vnd.microsoft.portable-executable
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.10/tdbcodbc.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.10/tdbcodbc.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.10/tdbcodbc.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,554 @@
+# tdbcodbc.tcl --
+#
+# Class definitions and Tcl-level methods for the tdbc::odbc bridge.
+#
+# Copyright (c) 2008 by Kevin B. Kenny
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: tdbcodbc.tcl,v 1.47 2008/02/27 02:08:27 kennykb Exp $
+#
+#------------------------------------------------------------------------------
+
+package require tdbc
+
+::namespace eval ::tdbc::odbc {
+
+ namespace export connection datasources drivers
+
+ # Data types that are predefined in ODBC
+
+ variable sqltypes [dict create \
+ 1 char \
+ 2 numeric \
+ 3 decimal \
+ 4 integer \
+ 5 smallint \
+ 6 float \
+ 7 real \
+ 8 double \
+ 9 datetime \
+ 12 varchar \
+ 91 date \
+ 92 time \
+ 93 timestamp \
+ -1 longvarchar \
+ -2 binary \
+ -3 varbinary \
+ -4 longvarbinary \
+ -5 bigint \
+ -6 tinyint \
+ -7 bit \
+ -8 wchar \
+ -9 wvarchar \
+ -10 wlongvarchar \
+ -11 guid]
+}
+
+#------------------------------------------------------------------------------
+#
+# tdbc::odbc::connection --
+#
+# Class representing a connection to a database through ODBC.
+#
+#-------------------------------------------------------------------------------
+
+::oo::class create ::tdbc::odbc::connection {
+
+ superclass ::tdbc::connection
+
+ variable statementSeq typemap
+
+ # The constructor is written in C. It takes the connection string
+ # as its argument It sets up a namespace to hold the statements
+ # associated with the connection, and then delegates to the 'init'
+ # method (written in C) to do the actual work of attaching to the
+ # database. When that comes back, it sets up a statement to query
+ # the support types, makes a dictionary to enumerate them, and
+ # calls back to set a flag if WVARCHAR is seen (If WVARCHAR is
+ # seen, the database supports Unicode.)
+
+ # The 'statementCreate' method forwards to the constructor of the
+ # statement class
+
+ forward statementCreate ::tdbc::odbc::statement create
+
+ # The 'tables' method returns a dictionary describing the tables
+ # in the database
+
+ method tables {{pattern %}} {
+ set stmt [::tdbc::odbc::tablesStatement create \
+ Stmt::[incr statementSeq] [self] $pattern]
+ set status [catch {
+ set retval {}
+ $stmt foreach -as dicts row {
+ if {[dict exists $row TABLE_NAME]} {
+ dict set retval [dict get $row TABLE_NAME] $row
+ }
+ }
+ set retval
+ } result options]
+ catch {rename $stmt {}}
+ return -level 0 -options $options $result
+ }
+
+ # The 'columns' method returns a dictionary describing the tables
+ # in the database
+
+ method columns {table {pattern %}} {
+ # Make sure that the type map is initialized
+ my typemap
+
+ # Query the columns from the database
+
+ set stmt [::tdbc::odbc::columnsStatement create \
+ Stmt::[incr statementSeq] [self] $table $pattern]
+ set status [catch {
+ set retval {}
+ $stmt foreach -as dicts origrow {
+
+ # Map the type, precision, scale and nullable indicators
+ # to tdbc's notation
+
+ set row {}
+ dict for {key value} $origrow {
+ dict set row [string tolower $key] $value
+ }
+ if {[dict exists $row column_name]} {
+ if {[dict exists $typemap \
+ [dict get $row data_type]]} {
+ dict set row type \
+ [dict get $typemap \
+ [dict get $row data_type]]
+ } else {
+ dict set row type [dict get $row type_name]
+ }
+ if {[dict exists $row column_size]} {
+ dict set row precision \
+ [dict get $row column_size]
+ }
+ if {[dict exists $row decimal_digits]} {
+ dict set row scale \
+ [dict get $row decimal_digits]
+ }
+ if {![dict exists $row nullable]} {
+ dict set row nullable \
+ [expr {!![string trim [dict get $row is_nullable]]}]
+ }
+ dict set retval [dict get $row column_name] $row
+ }
+ }
+ set retval
+ } result options]
+ catch {rename $stmt {}}
+ return -level 0 -options $options $result
+ }
+
+ # The 'primarykeys' method returns a dictionary describing the primary
+ # keys of a table
+
+ method primarykeys {tableName} {
+ set stmt [::tdbc::odbc::primarykeysStatement create \
+ Stmt::[incr statementSeq] [self] $tableName]
+ set status [catch {
+ set retval {}
+ $stmt foreach -as dicts row {
+ foreach {odbcKey tdbcKey} {
+ TABLE_CAT tableCatalog
+ TABLE_SCHEM tableSchema
+ TABLE_NAME tableName
+ COLUMN_NAME columnName
+ KEY_SEQ ordinalPosition
+ PK_NAME constraintName
+ } {
+ if {[dict exists $row $odbcKey]} {
+ dict set row $tdbcKey [dict get $row $odbcKey]
+ dict unset row $odbcKey
+ }
+ }
+ lappend retval $row
+ }
+ set retval
+ } result options]
+ catch {rename $stmt {}}
+ return -level 0 -options $options $result
+ }
+
+ # The 'foreignkeys' method returns a dictionary describing the foreign
+ # keys of a table
+
+ method foreignkeys {args} {
+ set stmt [::tdbc::odbc::foreignkeysStatement create \
+ Stmt::[incr statementSeq] [self] {*}$args]
+ set status [catch {
+ set fkseq 0
+ set retval {}
+ $stmt foreach -as dicts row {
+ foreach {odbcKey tdbcKey} {
+ PKTABLE_CAT primaryCatalog
+ PKTABLE_SCHEM primarySchema
+ PKTABLE_NAME primaryTable
+ PKCOLUMN_NAME primaryColumn
+ FKTABLE_CAT foreignCatalog
+ FKTABLE_SCHEM foreignSchema
+ FKTABLE_NAME foreignTable
+ FKCOLUMN_NAME foreignColumn
+ UPDATE_RULE updateRule
+ DELETE_RULE deleteRule
+ DEFERRABILITY deferrable
+ KEY_SEQ ordinalPosition
+ FK_NAME foreignConstraintName
+ } {
+ if {[dict exists $row $odbcKey]} {
+ dict set row $tdbcKey [dict get $row $odbcKey]
+ dict unset row $odbcKey
+ }
+ }
+ # Horrible kludge: If the driver doesn't report FK_NAME,
+ # make one up.
+ if {![dict exists $row foreignConstraintName]} {
+ if {![dict exists $row ordinalPosition]
+ || [dict get $row ordinalPosition] == 1} {
+ set fkname ?[dict get $row foreignTable]?[incr fkseq]
+ }
+ dict set row foreignConstraintName $fkname
+ }
+ lappend retval $row
+ }
+ set retval
+ } result options]
+ catch {rename $stmt {}}
+ return -level 0 -options $options $result
+ }
+
+ # The 'evaldirect' evaluates driver-native SQL code without preparing it,
+ # and returns a list of dicts (similar to '$connection allrows -as dicts').
+
+ method evaldirect {sqlStatement} {
+ set stmt [::tdbc::odbc::evaldirectStatement create \
+ Stmt::[incr statementSeq] [self] $sqlStatement]
+ set status [catch {
+ $stmt allrows -as dicts
+ } result options]
+ catch {rename $stmt {}}
+ return -level 0 -options $options $result
+ }
+
+ # The 'prepareCall' method gives a portable interface to prepare
+ # calls to stored procedures. It delegates to 'prepare' to do the
+ # actual work.
+
+ method preparecall {call} {
+
+ regexp {^[[:space:]]*(?:([A-Za-z_][A-Za-z_0-9]*)[[:space:]]*=)?(.*)} \
+ $call -> varName rest
+ if {$varName eq {}} {
+ my prepare \\{CALL $rest\\}
+ } else {
+ my prepare \\{:$varName=CALL $rest\\}
+ }
+
+ if 0 {
+ # Kevin thinks this is going to be
+
+ if {![regexp -expanded {
+ ^\s* # leading whitespace
+ (?::([[:alpha:]_][[:alnum:]_]*)\s*=\s*) # possible variable name
+ (?:(?:([[:alpha:]_][[:alnum:]_]*)\s*[.]\s*)? # catalog
+ ([[:alpha:]_][[:alnum:]_]*)\s*[.]\s*)? # schema
+ ([[:alpha:]_][[:alnum:]_]*)\s* # procedure
+ (.*)$ # argument list
+ } $call -> varName catalog schema procedure arglist]} {
+ return -code error \
+ -errorCode [list TDBC \
+ SYNTAX_ERROR_OR_ACCESS_RULE_VIOLATION \
+ 42000 ODBC -1] \
+ "Syntax error in stored procedure call"
+ } else {
+ my PrepareCall $varName $catalog $schema $procedure $arglist
+ }
+
+ # at least if making all parameters 'inout' doesn't work.
+
+ }
+
+ }
+
+ # The 'typemap' method returns the type map
+
+ method typemap {} {
+ if {![info exists typemap]} {
+ set typemap $::tdbc::odbc::sqltypes
+ set typesStmt [tdbc::odbc::typesStatement new [self]]
+ $typesStmt foreach row {
+ set typeNum [dict get $row DATA_TYPE]
+ if {![dict exists $typemap $typeNum]} {
+ dict set typemap $typeNum [string tolower \
+ [dict get $row TYPE_NAME]]
+ }
+ switch -exact -- $typeNum {
+ -9 {
+ [self] HasWvarchar 1
+ }
+ -5 {
+ [self] HasBigint 1
+ }
+ }
+ }
+ rename $typesStmt {}
+ }
+ return $typemap
+ }
+
+ # The 'begintransaction', 'commit' and 'rollback' methods are
+ # implemented in C.
+
+}
+
+#-------------------------------------------------------------------------------
+#
+# tdbc::odbc::statement --
+#
+# The class 'tdbc::odbc::statement' models one statement against a
+# database accessed through an ODBC connection
+#
+#-------------------------------------------------------------------------------
+
+::oo::class create ::tdbc::odbc::statement {
+
+ superclass ::tdbc::statement
+
+ # The constructor is implemented in C. It accepts the handle to
+ # the connection and the SQL code for the statement to prepare.
+ # It creates a subordinate namespace to hold the statement's
+ # active result sets, and then delegates to the 'init' method,
+ # written in C, to do the actual work of preparing the statement.
+
+ # The 'resultSetCreate' method forwards to the result set constructor
+
+ forward resultSetCreate ::tdbc::odbc::resultset create
+
+ # The 'params' method describes the parameters to the statement
+
+ method params {} {
+ set typemap [[my connection] typemap]
+ set result {}
+ foreach {name flags typeNum precision scale nullable} [my ParamList] {
+ set lst [dict create \
+ name $name \
+ direction [lindex {unknown in out inout} \
+ [expr {($flags & 0x06) >> 1}]] \
+ type [dict get $typemap $typeNum] \
+ precision $precision \
+ scale $scale]
+ if {$nullable in {0 1}} {
+ dict set list nullable $nullable
+ }
+ dict set result $name $lst
+ }
+ return $result
+ }
+
+ # Methods implemented in C:
+ # init statement ?dictionary?
+ # Does the heavy lifting for the constructor
+ # connection
+ # Returns the connection handle to which this statement belongs
+ # paramtype paramname ?direction? type ?precision ?scale??
+ # Declares the type of a parameter in the statement
+
+}
+
+#------------------------------------------------------------------------------
+#
+# tdbc::odbc::tablesStatement --
+#
+# The class 'tdbc::odbc::tablesStatement' represents the special
+# statement that queries the tables in a database through an ODBC
+# connection.
+#
+#------------------------------------------------------------------------------
+
+oo::class create ::tdbc::odbc::tablesStatement {
+
+ superclass ::tdbc::statement
+
+ # The constructor is written in C. It accepts the handle to the
+ # connection and a pattern to match table names. It works in all
+ # ways like the constructor of the 'statement' class except that
+ # its 'init' method sets up to enumerate tables and not run a SQL
+ # query.
+
+ # The 'resultSetCreate' method forwards to the result set constructor
+
+ forward resultSetCreate ::tdbc::odbc::resultset create
+
+}
+
+#------------------------------------------------------------------------------
+#
+# tdbc::odbc::columnsStatement --
+#
+# The class 'tdbc::odbc::tablesStatement' represents the special
+# statement that queries the columns of a table or view
+# in a database through an ODBC connection.
+#
+#------------------------------------------------------------------------------
+
+oo::class create ::tdbc::odbc::columnsStatement {
+
+ superclass ::tdbc::statement
+
+ # The constructor is written in C. It accepts the handle to the
+ # connection, a table name, and a pattern to match column
+ # names. It works in all ways like the constructor of the
+ # 'statement' class except that its 'init' method sets up to
+ # enumerate tables and not run a SQL query.
+
+ # The 'resultSetCreate' class forwards to the constructor of the
+ # result set
+
+ forward resultSetCreate ::tdbc::odbc::resultset create
+
+}
+
+#------------------------------------------------------------------------------
+#
+# tdbc::odbc::primarykeysStatement --
+#
+# The class 'tdbc::odbc::primarykeysStatement' represents the special
+# statement that queries the primary keys on a table through an ODBC
+# connection.
+#
+#------------------------------------------------------------------------------
+
+oo::class create ::tdbc::odbc::primarykeysStatement {
+
+ superclass ::tdbc::statement
+
+ # The constructor is written in C. It accepts the handle to the
+ # connection and a table name. It works in all
+ # ways like the constructor of the 'statement' class except that
+ # its 'init' method sets up to enumerate primary keys and not run a SQL
+ # query.
+
+ # The 'resultSetCreate' method forwards to the result set constructor
+
+ forward resultSetCreate ::tdbc::odbc::resultset create
+
+}
+
+#------------------------------------------------------------------------------
+#
+# tdbc::odbc::foreignkeysStatement --
+#
+# The class 'tdbc::odbc::foreignkeysStatement' represents the special
+# statement that queries the foreign keys on a table through an ODBC
+# connection.
+#
+#------------------------------------------------------------------------------
+
+oo::class create ::tdbc::odbc::foreignkeysStatement {
+
+ superclass ::tdbc::statement
+
+ # The constructor is written in C. It accepts the handle to the
+ # connection and the -primary and -foreign options. It works in all
+ # ways like the constructor of the 'statement' class except that
+ # its 'init' method sets up to enumerate foreign keys and not run a SQL
+ # query.
+
+ # The 'resultSetCreate' method forwards to the result set constructor
+
+ forward resultSetCreate ::tdbc::odbc::resultset create
+
+}
+
+#------------------------------------------------------------------------------
+#
+# tdbc::odbc::evaldirectStatement --
+#
+# The class 'tdbc::odbc::evaldirectStatement' provides a mechanism to
+# execute driver-name SQL code through an ODBC connection. The SQL code
+# is not prepared and no tokenization or variable substitution is done.
+#
+#------------------------------------------------------------------------------
+
+oo::class create ::tdbc::odbc::evaldirectStatement {
+
+ superclass ::tdbc::statement
+
+ # The constructor is written in C. It accepts the handle to the
+ # connection and a SQL statement. It works in all
+ # ways like the constructor of the 'statement' class except that
+ # its 'init' method does not tokenize or prepare the SQL statement, and
+ # sets up to run the SQL query without performing variable substitution.
+
+ # The 'resultSetCreate' method forwards to the result set constructor
+
+ forward resultSetCreate ::tdbc::odbc::resultset create
+
+}
+
+#------------------------------------------------------------------------------
+#
+# tdbc::odbc::typesStatement --
+#
+# The class 'tdbc::odbc::typesStatement' represents the special
+# statement that queries the types available in a database through
+# an ODBC connection.
+#
+#------------------------------------------------------------------------------
+
+
+oo::class create ::tdbc::odbc::typesStatement {
+
+ superclass ::tdbc::statement
+
+ # The constructor is written in C. It accepts the handle to the
+ # connection, and (optionally) a data type number. It works in all
+ # ways like the constructor of the 'statement' class except that
+ # its 'init' method sets up to enumerate types and not run a SQL
+ # query.
+
+ # The 'resultSetCreate' method forwards to the constructor of result sets
+
+ forward resultSetCreate ::tdbc::odbc::resultset create
+
+ # The C code contains a variant implementation of the 'init' method.
+
+}
+
+#------------------------------------------------------------------------------
+#
+# tdbc::odbc::resultset --
+#
+# The class 'tdbc::odbc::resultset' models the result set that is
+# produced by executing a statement against an ODBC database.
+#
+#------------------------------------------------------------------------------
+
+::oo::class create ::tdbc::odbc::resultset {
+
+ superclass ::tdbc::resultset
+
+ # Methods implemented in C include:
+
+ # constructor statement ?dictionary?
+ # -- Executes the statement against the database, optionally providing
+ # a dictionary of substituted parameters (default is to get params
+ # from variables in the caller's scope).
+ # columns
+ # -- Returns a list of the names of the columns in the result.
+ # nextdict
+ # -- Stores the next row of the result set in the given variable in
+ # the caller's scope as a dictionary whose keys are
+ # column names and whose values are column values.
+ # nextlist
+ # -- Stores the next row of the result set in the given variable in
+ # the caller's scope as a list of cells.
+ # rowcount
+ # -- Returns a count of rows affected by the statement, or -1
+ # if the count of rows has not been determined.
+
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.10/tdbcodbc.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.10/pkgIndex.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.10/pkgIndex.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.10/pkgIndex.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,14 @@
+# Index file to load the TDBC Postgres package.
+
+if {![package vsatisfies [package provide Tcl] 8.6-]} {
+ return
+}
+if {[package vsatisfies [package provide Tcl] 9.0-]} {
+ package ifneeded tdbc::postgres 1.1.10 \
+ "[list source -encoding utf-8 [file join $dir tdbcpostgres.tcl]]\;\
+ [list load [file join $dir tcl9tdbcpostgres1110.dll] [string totitle tdbcpostgres]]"
+} else {
+ package ifneeded tdbc::postgres 1.1.10 \
+ "[list source -encoding utf-8 [file join $dir tdbcpostgres.tcl]]\;\
+ [list load [file join $dir tdbcpostgres1110.dll] [string totitle tdbcpostgres]]"
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.10/pkgIndex.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.10/tcl9tdbcpostgres1110.dll
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.10/tcl9tdbcpostgres1110.dll
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.10/tcl9tdbcpostgres1110.dll 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.10/tcl9tdbcpostgres1110.dll 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.10/tcl9tdbcpostgres1110.dll
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+application/vnd.microsoft.portable-executable
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.10/tdbcpostgres.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.10/tdbcpostgres.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.10/tdbcpostgres.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,135 @@
+# tdbcpostgres.tcl --
+#
+# Class definitions and Tcl-level methods for the tdbc::postgres bridge.
+#
+# Copyright (c) 2009 by Slawomir Cygan
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#------------------------------------------------------------------------------
+
+package require tdbc
+
+::namespace eval ::tdbc::mypostgres {
+
+ namespace export connection datasources drivers
+
+}
+
+#------------------------------------------------------------------------------
+#
+# tdbc::postgres::connection --
+#
+# Class representing a connection to a Postgres database.
+#
+#-------------------------------------------------------------------------------
+
+::oo::class create ::tdbc::postgres::connection {
+
+ superclass ::tdbc::connection
+
+ # The constructor is written in C. It takes alternating keywords
+ # and values pairs as its arguments. (See the manual page for the
+ # available options.)
+
+ # The 'statementCreate' method delegates to the constructor of the
+ # statement class
+
+ forward statementCreate ::tdbc::postgres::statement create
+
+
+ # The 'prepareCall' method gives a portable interface to prepare
+ # calls to stored procedures. It delegates to 'prepare' to do the
+ # actual work.
+
+ method preparecall {call} {
+ regexp {^[[:space:]]*(?:([A-Za-z_][A-Za-z_0-9]*)[[:space:]]*=)?(.*)} \
+ $call -> varName rest
+ if {$varName eq {}} {
+ my prepare \\{$rest\\}
+ } else {
+ my prepare \\{:$varName=$rest\\}
+ }
+ }
+
+ # The 'init', 'begintransaction', 'commit, 'rollback', 'tables'
+ # and 'columns' methods are implemented in C.
+
+}
+
+#------------------------------------------------------------------------------
+#
+# tdbc::postgres::statement --
+#
+# The class 'tdbc::postgres::statement' models one statement against a
+# database accessed through a Postgres connection
+#
+#------------------------------------------------------------------------------
+
+::oo::class create ::tdbc::postgres::statement {
+
+ superclass ::tdbc::statement
+
+ # The 'resultSetCreate' method forwards to the constructor of the
+ # result set.
+
+ forward resultSetCreate ::tdbc::postgres::resultset create
+
+ # Methods implemented in C:
+ #
+ # constructor connection SQLCode
+ # The constructor accepts the handle to the connection and the SQL code
+ # for the statement to prepare. It creates a subordinate namespace to
+ # hold the statement's active result sets, and then delegates to the
+ # 'init' method, written in C, to do the actual work of preparing the
+ # statement.
+ # params
+ # Returns descriptions of the parameters of a statement.
+ # paramtype paramname ?direction? type ?precision ?scale??
+ # Declares the type of a parameter in the statement
+
+}
+
+#------------------------------------------------------------------------------
+#
+# tdbc::postgres::resultset --
+#
+# The class 'tdbc::postgres::resultset' models the result set that is
+# produced by executing a statement against a Postgres database.
+#
+#------------------------------------------------------------------------------
+
+::oo::class create ::tdbc::postgres::resultset {
+
+ superclass ::tdbc::resultset
+
+ # The 'nextresults' method is stubbed out; tdbcpostgres does not
+ # allow a single call to return multiple results.
+
+ method nextresults {} {
+ while {[my nextdict rubbish]} {}
+ return 0
+ }
+
+ # Methods implemented in C include:
+
+ # constructor statement ?dictionary?
+ # -- Executes the statement against the database, optionally providing
+ # a dictionary of substituted parameters (default is to get params
+ # from variables in the caller's scope).
+ # columns
+ # -- Returns a list of the names of the columns in the result.
+ # nextdict
+ # -- Stores the next row of the result set in the given variable in
+ # the caller's scope as a dictionary whose keys are
+ # column names and whose values are column values, or else
+ # as a list of cells.
+ # nextlist
+ # -- Stores the next row of the result set in the given variable in
+ # the caller's scope as a list of cells.
+ # rowcount
+ # -- Returns a count of rows affected by the statement, or -1
+ # if the count of rows has not been determined.
+
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.10/tdbcpostgres.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/thread3.0.1/pkgIndex.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/thread3.0.1/pkgIndex.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/thread3.0.1/pkgIndex.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,55 @@
+# -*- tcl -*-
+# Tcl package index file, version 1.1
+#
+
+# Tcl 8.7 interps are only supported on 32-bit platforms.
+# Lower than that is never supported. Bye!
+if {![package vsatisfies [package provide Tcl] 9.0]
+ && ((![package vsatisfies [package provide Tcl] 8.7])
+ || ($::tcl_platform(pointerSize)!=4))} {
+ return
+}
+
+# All Tcl 8.7+ interps can [load] thread 3.0.1
+#
+# For interps that are not thread-enabled, we still call [package ifneeded].
+# This is contrary to the usual convention, but is a good idea because we
+# cannot imagine any other version of thread that might succeed in a
+# thread-disabled interp. There's nothing to gain by yielding to other
+# competing callers of [package ifneeded Thread]. On the other hand,
+# deferring the error has the advantage that a script calling
+# [package require Thread] in a thread-disabled interp gets an error message
+# about a thread-disabled interp, instead of the message
+# "can't find package thread".
+
+package ifneeded [string tolower thread] 3.0.1 \
+ [list load [file join $dir tcl9thread301.dll] [string totitle thread]]
+package ifneeded [string totitle thread] 3.0.1 \
+ [list package require -exact [string tolower thread] 3.0.1]
+
+# package ttrace uses some support machinery.
+
+# In Tcl 8.7+ interps; use [::apply]
+
+package ifneeded ttrace 3.0.1 [list ::apply {{dir} {
+ if {[info exists ::env(TCL_THREAD_LIBRARY)] &&
+ [file readable $::env(TCL_THREAD_LIBRARY)/ttrace.tcl]} {
+ source $::env(TCL_THREAD_LIBRARY)/ttrace.tcl
+ } elseif {[file readable [file join $dir .. lib ttrace.tcl]]} {
+ source [file join $dir .. lib ttrace.tcl]
+ } elseif {[file readable [file join $dir ttrace.tcl]]} {
+ source [file join $dir ttrace.tcl]
+ } elseif {[file exists //zipfs:/lib/thread/ttrace.tcl] ||
+ ![catch {zipfs mount [file join $dir tcl9thread301.dll] //zipfs:/lib/thread}]} {
+ source //zipfs:/lib/thread/ttrace.tcl
+ }
+ if {[namespace which ::ttrace::update] ne ""} {
+ ::ttrace::update
+ }
+}} $dir]
+package ifneeded Ttrace 3.0.1 \
+ [list package require -exact ttrace 3.0.1]
+
+
+
+
Property changes on: trunk/Master/tlpkg/tltcl/lib/thread3.0.1/pkgIndex.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/thread3.0.1/tcl9thread301.dll
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/thread3.0.1/tcl9thread301.dll
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/thread3.0.1/tcl9thread301.dll 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/thread3.0.1/tcl9thread301.dll 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/thread3.0.1/tcl9thread301.dll
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+application/zip
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/bgerror.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/bgerror.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/bgerror.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,282 @@
+# bgerror.tcl --
+#
+# Implementation 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, and possible do something more interesting with that
+# trace (like save it to a log). This is adapted from work done by
+# Donal K. Fellows.
+#
+# Copyright © 1998-2000 Ajuba Solutions.
+# Copyright © 2007 ActiveState Software Inc.
+# Copyright © 2007 Daniel A. Steffen <das at users.sourceforge.net>
+# Copyright © 2009 Pat Thoyts <patthoyts at users.sourceforge.net>
+
+namespace eval ::tk::dialog::error {
+ namespace import -force ::tk::msgcat::*
+ namespace export bgerror
+ option add *ErrorDialog.function.text [mc "Save To Log"] \
+ widgetDefault
+ option add *ErrorDialog.function.command [namespace code SaveToLog]
+ option add *ErrorDialog*Label.font TkCaptionFont widgetDefault
+ if {[tk windowingsystem] eq "aqua"} {
+ option add *ErrorDialog*background systemAlertBackgroundActive \
+ widgetDefault
+ option add *ErrorDialog*info.text.background \
+ systemTextBackgroundColor widgetDefault
+ option add *ErrorDialog*Button.highlightBackground \
+ systemAlertBackgroundActive widgetDefault
+ }
+}
+
+proc ::tk::dialog::error::Return {which code} {
+ variable button
+
+ .bgerrorDialog.$which state {active selected focus}
+ update idletasks
+ after 100
+ set button $code
+}
+
+proc ::tk::dialog::error::Details {} {
+ set w .bgerrorDialog
+ set caption [option get $w.function text {}]
+ set command [option get $w.function command {}]
+ if {($caption eq "") || ($command eq "")} {
+ grid forget $w.function
+ }
+ lappend command [$w.top.info.text get 1.0 end-1c]
+ $w.function configure -text $caption -command $command
+ grid $w.top.info - -sticky nsew -padx 3m -pady 3m
+}
+
+proc ::tk::dialog::error::SaveToLog {text} {
+ if {$::tcl_platform(platform) eq "windows"} {
+ set allFiles *.*
+ } else {
+ set allFiles *
+ }
+ set types [list \
+ [list [mc "Log Files"] .log] \
+ [list [mc "Text Files"] .txt] \
+ [list [mc "All Files"] $allFiles] \
+ ]
+ set filename [tk_getSaveFile -title [mc "Select Log File"] \
+ -filetypes $types -defaultextension .log -parent .bgerrorDialog]
+ if {$filename ne {}} {
+ set f [open $filename w]
+ puts -nonewline $f $text
+ close $f
+ }
+ return
+}
+
+proc ::tk::dialog::error::Destroy {w} {
+ if {$w eq ".bgerrorDialog"} {
+ variable button
+ set button -1
+ }
+}
+
+proc ::tk::dialog::error::DeleteByProtocol {} {
+ variable button
+ set button 1
+}
+
+proc ::tk::dialog::error::ReturnInDetails w {
+ bind $w <Return> {}; # Remove this binding
+ $w invoke
+ return -code break
+}
+
+# ::tk::dialog::error::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 ::tk::dialog::error::bgerror {err {flag 1}} {
+ global errorInfo
+ variable button
+
+ set info $errorInfo
+
+ set ret [catch {::tkerror $err} msg];
+ if {$ret != 1} {return -code $ret $msg}
+
+ # The application's tkerror either failed or was not found
+ # so we use the default dialog. But on Aqua we cannot display
+ # the dialog if the background error occurs in an idle task
+ # being processed inside of [NSView drawRect]. In that case
+ # we post the dialog as an after task instead.
+ set windowingsystem [tk windowingsystem]
+ if {$windowingsystem eq "aqua"} {
+ if $flag {
+ set errorInfo $info
+ after 500 [list bgerror "$err" 0]
+ return
+ }
+ }
+
+ set ok [mc OK]
+ # Truncate the message if it is too wide (>maxLine characters) or
+ # too tall (>maxRows lines). Truncation occurs at the first point at
+ # which one of those conditions is met. No trailing newline.
+ set displayedErr ""
+ set lines 0
+ set maxLine 45
+ set maxRows 5
+ foreach line [split $err \n] {
+ if {$lines > $maxRows - 1} {
+ # No more lines. Append to previous line.
+ append displayedErr { ...}
+ break
+ }
+ if {[string length $line] > $maxLine} {
+ append displayedErr "[string range $line 0 $maxLine-3]..."
+ break
+ }
+ if {$lines > $maxRows - 2 && [string length $line] > $maxLine-4} {
+ append displayedErr "[string range $line 0 $maxLine-3]..."
+ break
+ } elseif {$lines > $maxRows - 2} {
+ # Last line, but no break or newline. Room to add 4 chars.
+ append displayedErr "${line}"
+ } else {
+ append displayedErr "${line}\n"
+ }
+ incr lines
+ }
+ set displayedErr [string trim $displayedErr]
+
+ set title [mc "Application Error"]
+ set text [mc "Error: %1\$s" $displayedErr]
+ set buttons [list ok $ok dismiss [mc "Skip Messages"] \
+ function [mc "Details >>"]]
+
+ # 1. Create the top-level window and divide it into top
+ # and bottom parts.
+
+ set dlg .bgerrorDialog
+ set bg [ttk::style lookup . -background]
+ destroy $dlg
+ toplevel $dlg -class ErrorDialog -background $bg
+ wm withdraw $dlg
+ wm title $dlg $title
+ wm iconname $dlg ErrorDialog
+ wm protocol $dlg WM_DELETE_WINDOW [namespace code DeleteByProtocol]
+
+ if {$windowingsystem eq "aqua"} {
+ ::tk::unsupported::MacWindowStyle style $dlg moveableAlert {}
+ } elseif {$windowingsystem eq "x11"} {
+ wm attributes $dlg -type dialog
+ }
+
+ ttk::frame $dlg.bot
+ ttk::frame $dlg.top
+ pack $dlg.bot -side bottom -fill both
+ pack $dlg.top -side top -fill both -expand 1
+
+ set W [ttk::frame $dlg.top.info]
+ text $W.text -setgrid false -height 10 -wrap char \
+ -yscrollcommand [list $W.scroll set]
+ if {$windowingsystem ne "aqua"} {
+ $W.text configure -width 40
+ }
+
+ ttk::scrollbar $W.scroll -command [list $W.text yview]
+ pack $W.scroll -side right -fill y
+ pack $W.text -side left -expand yes -fill both
+ $W.text insert 0.0 "$err\n$info"
+ $W.text mark set insert 0.0
+ bind $W.text <Button-1> {focus %W}
+ $W.text configure -state disabled
+
+ # 2. Fill the top part with bitmap and message
+
+ # Max-width of message is the width of the screen...
+ set wrapwidth [winfo screenwidth $dlg]
+ # ...minus the width of the icon, padding and a fudge factor for
+ # the window manager decorations and aesthetics.
+ set wrapwidth [expr {$wrapwidth-60-[winfo pixels $dlg 9m]}]
+ ttk::label $dlg.msg -justify left -text $text -wraplength $wrapwidth
+ ttk::label $dlg.bitmap -image ::tk::icons::error
+
+ grid $dlg.bitmap $dlg.msg -in $dlg.top -row 0 -padx 3m -pady 3m
+ grid configure $dlg.bitmap -sticky ne
+ grid configure $dlg.msg -sticky nsw -padx {0 3m}
+ grid rowconfigure $dlg.top 1 -weight 1
+ grid columnconfigure $dlg.top 1 -weight 1
+
+ # 3. Create a row of buttons at the bottom of the dialog.
+
+ set i 0
+ foreach {name caption} $buttons {
+ ttk::button $dlg.$name -text $caption -default normal \
+ -command [namespace code [list set button $i]]
+ grid $dlg.$name -in $dlg.bot -column $i -row 0 -sticky ew -padx 7.5p
+ grid columnconfigure $dlg.bot $i -weight 1
+ # We boost the size of some Mac buttons for l&f
+ if {$windowingsystem eq "aqua"} {
+ if {($name eq "ok") || ($name eq "dismiss")} {
+ grid columnconfigure $dlg.bot $i -minsize 90
+ }
+ grid configure $dlg.$name -pady 7
+ }
+ incr i
+ }
+ # The "OK" button is the default for this dialog.
+ $dlg.ok configure -default active
+
+ bind $dlg <Return> [namespace code {Return ok 0}]
+ bind $dlg <Escape> [namespace code {Return dismiss 1}]
+ bind $dlg <Destroy> [namespace code {Destroy %W}]
+ bind $dlg.function <Return> [namespace code {ReturnInDetails %W}]
+ $dlg.function configure -command [namespace code Details]
+
+ # 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 (Motif style) and de-iconify it.
+
+ ::tk::PlaceWindow $dlg
+
+ # 7. Set a grab and claim the focus too.
+
+ ::tk::SetFocusGrab $dlg $dlg.ok
+
+ # 8. Ensure that we are topmost.
+
+ raise $dlg
+ if {[tk windowingsystem] eq "win32"} {
+ # Place it topmost if we aren't at the top of the stacking
+ # order to ensure that it's seen
+ if {[lindex [wm stackorder .] end] ne "$dlg"} {
+ wm attributes $dlg -topmost 1
+ }
+ }
+
+ # 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.
+
+ vwait [namespace which -variable button]
+ set copy $button; # Save a copy...
+
+ ::tk::RestoreFocusGrab $dlg $dlg.ok destroy
+
+ if {$copy == 1} {
+ return -code break
+ }
+}
+
+namespace eval :: {
+ # Fool the indexer
+ proc bgerror err {}
+ rename bgerror {}
+ namespace import ::tk::dialog::error::bgerror
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/bgerror.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/button.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/button.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/button.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,782 @@
+# 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.
+#
+# Copyright © 1992-1994 The Regents of the University of California.
+# Copyright © 1994-1996 Sun Microsystems, Inc.
+# Copyright © 2002 ActiveState Corporation.
+#
+# 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 {[tk windowingsystem] eq "aqua"} {
+
+ bind Radiobutton <Enter> {
+ tk::ButtonEnter %W
+ }
+ bind Radiobutton <Button-1> {
+ tk::ButtonDown %W
+ }
+ bind Radiobutton <ButtonRelease-1> {
+ tk::ButtonUp %W
+ }
+ bind Checkbutton <Enter> {
+ tk::ButtonEnter %W
+ }
+ bind Checkbutton <Button-1> {
+ tk::ButtonDown %W
+ }
+ bind Checkbutton <ButtonRelease-1> {
+ tk::ButtonUp %W
+ }
+ bind Checkbutton <Leave> {
+ tk::ButtonLeave %W
+ }
+}
+if {"win32" eq [tk windowingsystem]} {
+ bind Checkbutton <=> {
+ tk::CheckRadioInvoke %W select
+ }
+ bind Checkbutton <+> {
+ tk::CheckRadioInvoke %W select
+ }
+ bind Checkbutton <minus> {
+ tk::CheckRadioInvoke %W deselect
+ }
+ bind Checkbutton <Button-1> {
+ tk::CheckRadioDown %W
+ }
+ bind Checkbutton <ButtonRelease-1> {
+ tk::ButtonUp %W
+ }
+ bind Checkbutton <Enter> {
+ tk::CheckRadioEnter %W
+ }
+ bind Checkbutton <Leave> {
+ tk::ButtonLeave %W
+ }
+
+ bind Radiobutton <Button-1> {
+ tk::CheckRadioDown %W
+ }
+ bind Radiobutton <ButtonRelease-1> {
+ tk::ButtonUp %W
+ }
+ bind Radiobutton <Enter> {
+ tk::CheckRadioEnter %W
+ }
+}
+if {"x11" eq [tk windowingsystem]} {
+ bind Checkbutton <Return> {
+ if {!$tk_strictMotif} {
+ tk::CheckInvoke %W
+ }
+ }
+ bind Radiobutton <Return> {
+ if {!$tk_strictMotif} {
+ tk::CheckRadioInvoke %W
+ }
+ }
+ bind Checkbutton <Button-1> {
+ tk::CheckInvoke %W
+ }
+ bind Radiobutton <Button-1> {
+ tk::CheckRadioInvoke %W
+ }
+ bind Checkbutton <Enter> {
+ tk::CheckEnter %W
+ }
+ bind Radiobutton <Enter> {
+ tk::ButtonEnter %W
+ }
+ bind Checkbutton <Leave> {
+ tk::CheckLeave %W
+ }
+}
+
+bind Button <space> {
+ tk::ButtonInvoke %W
+}
+bind Checkbutton <space> {
+ tk::CheckRadioInvoke %W
+}
+bind Radiobutton <space> {
+ tk::CheckRadioInvoke %W
+}
+bind Button <<Invoke>> {
+ tk::ButtonInvoke %W
+}
+bind Checkbutton <<Invoke>> {
+ tk::CheckRadioInvoke %W
+}
+bind Radiobutton <<Invoke>> {
+ tk::CheckRadioInvoke %W
+}
+
+bind Button <FocusIn> {}
+bind Button <Enter> {
+ tk::ButtonEnter %W
+}
+bind Button <Leave> {
+ tk::ButtonLeave %W
+}
+bind Button <Button-1> {
+ tk::ButtonDown %W
+}
+bind Button <ButtonRelease-1> {
+ tk::ButtonUp %W
+}
+
+bind Checkbutton <FocusIn> {}
+
+bind Radiobutton <FocusIn> {}
+bind Radiobutton <Leave> {
+ tk::ButtonLeave %W
+}
+
+if {"win32" eq [tk windowingsystem]} {
+
+#########################
+# Windows implementation
+#########################
+
+# ::tk::ButtonEnter --
+# 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 ::tk::ButtonEnter w {
+ variable ::tk::Priv
+ if {[$w cget -state] ne "disabled"} {
+
+ # If the mouse button is down, set the relief to sunken on entry.
+ # Overwise, if there's an -overrelief value, set the relief to that.
+
+ set Priv($w,relief) [$w cget -relief]
+ if {$Priv(buttonWindow) eq $w} {
+ $w configure -relief sunken -state active
+ set Priv($w,prelief) sunken
+ } elseif {[set over [$w cget -overrelief]] ne ""} {
+ $w configure -relief $over
+ set Priv($w,prelief) $over
+ }
+ }
+ set Priv(window) $w
+}
+
+# ::tk::ButtonLeave --
+# The procedure below is invoked when the mouse pointer leaves a
+# button widget. It changes the state of the button back to inactive.
+# Restore any modified relief too.
+#
+# Arguments:
+# w - The name of the widget.
+
+proc ::tk::ButtonLeave w {
+ variable ::tk::Priv
+ if {[$w cget -state] ne "disabled"} {
+ $w configure -state normal
+ }
+
+ # Restore the original button relief if it was changed by Tk.
+ # That is signaled by the existence of Priv($w,prelief).
+
+ if {[info exists Priv($w,relief)]} {
+ if {[info exists Priv($w,prelief)] && \
+ $Priv($w,prelief) eq [$w cget -relief]} {
+ $w configure -relief $Priv($w,relief)
+ }
+ unset -nocomplain Priv($w,relief) Priv($w,prelief)
+ }
+
+ set Priv(window) ""
+}
+
+# ::tk::ButtonDown --
+# 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 ::tk::ButtonDown w {
+ variable ::tk::Priv
+
+ # Only save the button's relief if it does not yet exist. If there
+ # is an overrelief setting, Priv($w,relief) will already have been set,
+ # and the current value of the -relief option will be incorrect.
+
+ if {![info exists Priv($w,relief)]} {
+ set Priv($w,relief) [$w cget -relief]
+ }
+
+ if {[$w cget -state] ne "disabled"} {
+ set Priv(buttonWindow) $w
+ $w configure -relief sunken -state active
+ set Priv($w,prelief) sunken
+
+ # If this button has a repeatdelay set up, get it going with an after
+ after cancel $Priv(afterId)
+ set delay [$w cget -repeatdelay]
+ set Priv(repeated) 0
+ if {$delay > 0} {
+ set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]]
+ }
+ }
+}
+
+# ::tk::ButtonUp --
+# 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 ::tk::ButtonUp w {
+ variable ::tk::Priv
+ if {$Priv(buttonWindow) eq $w} {
+ set Priv(buttonWindow) ""
+
+ # Restore the button's relief if it was cached.
+
+ if {[info exists Priv($w,relief)]} {
+ if {[info exists Priv($w,prelief)] && \
+ $Priv($w,prelief) eq [$w cget -relief]} {
+ $w configure -relief $Priv($w,relief)
+ }
+ unset -nocomplain Priv($w,relief) Priv($w,prelief)
+ }
+
+ # Clean up the after event from the auto-repeater
+ after cancel $Priv(afterId)
+
+ if {$Priv(window) eq $w && [$w cget -state] ne "disabled"} {
+ $w configure -state normal
+
+ # Only invoke the command if it wasn't already invoked by the
+ # auto-repeater functionality
+ if { $Priv(repeated) == 0 } {
+ uplevel #0 [list $w invoke]
+ }
+ }
+ }
+}
+
+# ::tk::CheckRadioEnter --
+# 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 ::tk::CheckRadioEnter w {
+ variable ::tk::Priv
+ if {[$w cget -state] ne "disabled"} {
+ if {$Priv(buttonWindow) eq $w} {
+ $w configure -state active
+ }
+ if {[set over [$w cget -overrelief]] ne ""} {
+ set Priv($w,relief) [$w cget -relief]
+ set Priv($w,prelief) $over
+ $w configure -relief $over
+ }
+ }
+ set Priv(window) $w
+}
+
+# ::tk::CheckRadioDown --
+# 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 ::tk::CheckRadioDown w {
+ variable ::tk::Priv
+ if {![info exists Priv($w,relief)]} {
+ set Priv($w,relief) [$w cget -relief]
+ }
+ if {[$w cget -state] ne "disabled"} {
+ set Priv(buttonWindow) $w
+ set Priv(repeated) 0
+ $w configure -state active
+ }
+}
+
+}
+
+if {"x11" eq [tk windowingsystem]} {
+
+#####################
+# Unix implementation
+#####################
+
+# ::tk::ButtonEnter --
+# 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 ::tk::ButtonEnter {w} {
+ variable ::tk::Priv
+ if {[$w cget -state] ne "disabled"} {
+ # On unix the state is active just with mouse-over
+ $w configure -state active
+
+ # If the mouse button is down, set the relief to sunken on entry.
+ # Overwise, if there's an -overrelief value, set the relief to that.
+
+ set Priv($w,relief) [$w cget -relief]
+ if {$Priv(buttonWindow) eq $w} {
+ $w configure -relief sunken
+ set Priv($w,prelief) sunken
+ } elseif {[set over [$w cget -overrelief]] ne ""} {
+ $w configure -relief $over
+ set Priv($w,prelief) $over
+ }
+ }
+ set Priv(window) $w
+}
+
+# ::tk::ButtonLeave --
+# The procedure below is invoked when the mouse pointer leaves a
+# button widget. It changes the state of the button back to inactive.
+# Restore any modified relief too.
+#
+# Arguments:
+# w - The name of the widget.
+
+proc ::tk::ButtonLeave w {
+ variable ::tk::Priv
+ if {[$w cget -state] ne "disabled"} {
+ $w configure -state normal
+ }
+
+ # Restore the original button relief if it was changed by Tk.
+ # That is signaled by the existence of Priv($w,prelief).
+
+ if {[info exists Priv($w,relief)]} {
+ if {[info exists Priv($w,prelief)] && \
+ $Priv($w,prelief) eq [$w cget -relief]} {
+ $w configure -relief $Priv($w,relief)
+ }
+ unset -nocomplain Priv($w,relief) Priv($w,prelief)
+ }
+
+ set Priv(window) ""
+}
+
+# ::tk::ButtonDown --
+# 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 ::tk::ButtonDown w {
+ variable ::tk::Priv
+
+ # Only save the button's relief if it does not yet exist. If there
+ # is an overrelief setting, Priv($w,relief) will already have been set,
+ # and the current value of the -relief option will be incorrect.
+
+ if {![info exists Priv($w,relief)]} {
+ set Priv($w,relief) [$w cget -relief]
+ }
+
+ if {[$w cget -state] ne "disabled"} {
+ set Priv(buttonWindow) $w
+ $w configure -relief sunken
+ set Priv($w,prelief) sunken
+
+ # If this button has a repeatdelay set up, get it going with an after
+ after cancel $Priv(afterId)
+ set delay [$w cget -repeatdelay]
+ set Priv(repeated) 0
+ if {$delay > 0} {
+ set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]]
+ }
+ }
+}
+
+# ::tk::ButtonUp --
+# 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 ::tk::ButtonUp w {
+ variable ::tk::Priv
+ if {$w eq $Priv(buttonWindow)} {
+ set Priv(buttonWindow) ""
+
+ # Restore the button's relief if it was cached.
+
+ if {[info exists Priv($w,relief)]} {
+ if {[info exists Priv($w,prelief)] && \
+ $Priv($w,prelief) eq [$w cget -relief]} {
+ $w configure -relief $Priv($w,relief)
+ }
+ unset -nocomplain Priv($w,relief) Priv($w,prelief)
+ }
+
+ # Clean up the after event from the auto-repeater
+ after cancel $Priv(afterId)
+
+ if {$Priv(window) eq $w && [$w cget -state] ne "disabled"} {
+ # Only invoke the command if it wasn't already invoked by the
+ # auto-repeater functionality
+ if { $Priv(repeated) == 0 } {
+ uplevel #0 [list $w invoke]
+ }
+ }
+ }
+}
+
+}
+
+if {[tk windowingsystem] eq "aqua"} {
+
+####################
+# Mac implementation
+####################
+
+# ::tk::ButtonEnter --
+# 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 ::tk::ButtonEnter {w} {
+ variable ::tk::Priv
+ if {[$w cget -state] ne "disabled"} {
+
+ # If there's an -overrelief value, set the relief to that.
+
+ if {$Priv(buttonWindow) eq $w} {
+ $w configure -state active
+ } elseif {[set over [$w cget -overrelief]] ne ""} {
+ set Priv($w,relief) [$w cget -relief]
+ set Priv($w,prelief) $over
+ $w configure -relief $over
+ }
+ }
+ set Priv(window) $w
+}
+
+# ::tk::ButtonLeave --
+# 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 (Priv(buttonWindow) == $w), restore the relief of the
+# button too.
+#
+# Arguments:
+# w - The name of the widget.
+
+proc ::tk::ButtonLeave w {
+ variable ::tk::Priv
+ if {$w eq $Priv(buttonWindow)} {
+ $w configure -state normal
+ }
+
+ # Restore the original button relief if it was changed by Tk.
+ # That is signaled by the existence of Priv($w,prelief).
+
+ if {[info exists Priv($w,relief)]} {
+ if {[info exists Priv($w,prelief)] && \
+ $Priv($w,prelief) eq [$w cget -relief]} {
+ $w configure -relief $Priv($w,relief)
+ }
+ unset -nocomplain Priv($w,relief) Priv($w,prelief)
+ }
+
+ set Priv(window) ""
+}
+
+# ::tk::ButtonDown --
+# 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 ::tk::ButtonDown w {
+ variable ::tk::Priv
+
+ if {[$w cget -state] ne "disabled"} {
+ set Priv(buttonWindow) $w
+ $w configure -state active
+
+ # If this button has a repeatdelay set up, get it going with an after
+ after cancel $Priv(afterId)
+ set Priv(repeated) 0
+ if { ![catch {$w cget -repeatdelay} delay] } {
+ if {$delay > 0} {
+ set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]]
+ }
+ }
+ }
+}
+
+# ::tk::ButtonUp --
+# 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 ::tk::ButtonUp w {
+ variable ::tk::Priv
+ if {$Priv(buttonWindow) eq $w} {
+ set Priv(buttonWindow) ""
+ $w configure -state normal
+
+ # Restore the button's relief if it was cached.
+
+ if {[info exists Priv($w,relief)]} {
+ if {[info exists Priv($w,prelief)] && \
+ $Priv($w,prelief) eq [$w cget -relief]} {
+ $w configure -relief $Priv($w,relief)
+ }
+ unset -nocomplain Priv($w,relief) Priv($w,prelief)
+ }
+
+ # Clean up the after event from the auto-repeater
+ after cancel $Priv(afterId)
+
+ if {$Priv(window) eq $w && [$w cget -state] ne "disabled"} {
+ # Only invoke the command if it wasn't already invoked by the
+ # auto-repeater functionality
+ if { $Priv(repeated) == 0 } {
+ uplevel #0 [list $w invoke]
+ }
+ }
+ }
+}
+
+}
+
+##################
+# Shared routines
+##################
+
+# ::tk::ButtonInvoke --
+# 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 ::tk::ButtonInvoke w {
+ if {[winfo exists $w] && [$w cget -state] ne "disabled"} {
+ set oldRelief [$w cget -relief]
+ set oldState [$w cget -state]
+ $w configure -state active -relief sunken
+ after 100 [list ::tk::ButtonInvokeEnd $w $oldState $oldRelief]
+ }
+}
+
+# ::tk::ButtonInvokeEnd --
+# The procedure below is called after a button is invoked through
+# the keyboard. It simulate a release of the button via the mouse.
+#
+# Arguments:
+# w - The name of the widget.
+# oldState - Old state to be set back.
+# oldRelief - Old relief to be set back.
+
+proc ::tk::ButtonInvokeEnd {w oldState oldRelief} {
+ if {[winfo exists $w]} {
+ $w configure -state $oldState -relief $oldRelief
+ uplevel #0 [list $w invoke]
+ }
+}
+
+# ::tk::ButtonAutoInvoke --
+#
+# Invoke an auto-repeating button, and set it up to continue to repeat.
+#
+# Arguments:
+# w button to invoke.
+#
+# Results:
+# None.
+#
+# Side effects:
+# May create an after event to call ::tk::ButtonAutoInvoke.
+
+proc ::tk::ButtonAutoInvoke {w} {
+ variable ::tk::Priv
+ after cancel $Priv(afterId)
+ set delay [$w cget -repeatinterval]
+ if {$Priv(window) eq $w} {
+ incr Priv(repeated)
+ uplevel #0 [list $w invoke]
+ }
+ if {$delay > 0} {
+ set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]]
+ }
+}
+
+# ::tk::CheckRadioInvoke --
+# 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 ::tk::CheckRadioInvoke {w {cmd invoke}} {
+ if {[$w cget -state] ne "disabled"} {
+ uplevel #0 [list $w $cmd]
+ }
+}
+
+# Special versions of the handlers for checkbuttons on Unix that do the magic
+# to make things work right when the checkbutton indicator is hidden;
+# radiobuttons don't need this complexity.
+
+# ::tk::CheckInvoke --
+# The procedure below invokes the checkbutton, like ButtonInvoke, but handles
+# what to do when the checkbutton indicator is missing. Only used on Unix.
+#
+# Arguments:
+# w - The name of the widget.
+
+proc ::tk::CheckInvoke {w} {
+ variable ::tk::Priv
+ if {[$w cget -state] ne "disabled"} {
+ # Additional logic to switch the "selected" colors around if necessary
+ # (when we're indicator-less).
+
+ if {![$w cget -indicatoron] && [info exist Priv($w,selectcolor)]} {
+ if {[$w cget -selectcolor] eq $Priv($w,aselectcolor)} {
+ $w configure -selectcolor $Priv($w,selectcolor)
+ } else {
+ $w configure -selectcolor $Priv($w,aselectcolor)
+ }
+ }
+ uplevel #0 [list $w invoke]
+ }
+}
+
+# ::tk::CheckEnter --
+# The procedure below enters the checkbutton, like ButtonEnter, but handles
+# what to do when the checkbutton indicator is missing. Only used on Unix.
+#
+# Arguments:
+# w - The name of the widget.
+
+proc ::tk::CheckEnter {w} {
+ variable ::tk::Priv
+ if {[$w cget -state] ne "disabled"} {
+ # On unix the state is active just with mouse-over
+ $w configure -state active
+
+ # If the mouse button is down, set the relief to sunken on entry.
+ # Overwise, if there's an -overrelief value, set the relief to that.
+
+ set Priv($w,relief) [$w cget -relief]
+ if {$Priv(buttonWindow) eq $w} {
+ $w configure -relief sunken
+ set Priv($w,prelief) sunken
+ } elseif {[set over [$w cget -overrelief]] ne ""} {
+ $w configure -relief $over
+ set Priv($w,prelief) $over
+ }
+
+ # Compute what the "selected and active" color should be.
+
+ if {![$w cget -indicatoron] && [$w cget -selectcolor] ne ""} {
+ set Priv($w,selectcolor) [$w cget -selectcolor]
+ lassign [winfo rgb $w [$w cget -selectcolor]] r1 g1 b1
+ lassign [winfo rgb $w [$w cget -activebackground]] r2 g2 b2
+ set Priv($w,aselectcolor) \
+ [format "#%04x%04x%04x" [expr {($r1+$r2)/2}] \
+ [expr {($g1+$g2)/2}] [expr {($b1+$b2)/2}]]
+ # use uplevel to work with other var resolvers
+ if {[uplevel #0 [list set [$w cget -variable]]]
+ eq [$w cget -onvalue]} {
+ $w configure -selectcolor $Priv($w,aselectcolor)
+ }
+ }
+ }
+ set Priv(window) $w
+}
+
+# ::tk::CheckLeave --
+# The procedure below leaves the checkbutton, like ButtonLeave, but handles
+# what to do when the checkbutton indicator is missing. Only used on Unix.
+#
+# Arguments:
+# w - The name of the widget.
+
+proc ::tk::CheckLeave {w} {
+ variable ::tk::Priv
+ if {[$w cget -state] ne "disabled"} {
+ $w configure -state normal
+ }
+
+ # Restore the original button "selected" color; but only if the user
+ # has not changed it in the meantime.
+
+ if {![$w cget -indicatoron] && [info exist Priv($w,selectcolor)]} {
+ if {[$w cget -selectcolor] eq $Priv($w,selectcolor)
+ || ([info exist Priv($w,aselectcolor)] &&
+ [$w cget -selectcolor] eq $Priv($w,aselectcolor))} {
+ $w configure -selectcolor $Priv($w,selectcolor)
+ }
+ }
+ unset -nocomplain Priv($w,selectcolor) Priv($w,aselectcolor)
+
+ # Restore the original button relief if it was changed by Tk. That is
+ # signaled by the existence of Priv($w,prelief).
+
+ if {[info exists Priv($w,relief)]} {
+ if {[info exists Priv($w,prelief)] && \
+ $Priv($w,prelief) eq [$w cget -relief]} {
+ $w configure -relief $Priv($w,relief)
+ }
+ unset -nocomplain Priv($w,relief) Priv($w,prelief)
+ }
+
+ set Priv(window) ""
+}
+
+return
+
+# Local Variables:
+# mode: tcl
+# fill-column: 78
+# End:
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/button.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/choosedir.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/choosedir.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/choosedir.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,310 @@
+# choosedir.tcl --
+#
+# Choose directory dialog implementation for Unix/Mac.
+#
+# Copyright © 1998-2000 Scriptics Corporation.
+# All rights reserved.
+
+# Make sure the tk::dialog namespace, in which all dialogs should live, exists
+namespace eval ::tk::dialog {}
+namespace eval ::tk::dialog::file {}
+
+# Make the chooseDir namespace inside the dialog namespace
+namespace eval ::tk::dialog::file::chooseDir {
+ namespace import -force ::tk::msgcat::*
+}
+
+# ::tk::dialog::file::chooseDir:: --
+#
+# Implements the TK directory selection dialog.
+#
+# Arguments:
+# args Options parsed by the procedure.
+#
+proc ::tk::dialog::file::chooseDir:: {args} {
+ variable ::tk::Priv
+ set dataName __tk_choosedir
+ upvar ::tk::dialog::file::$dataName data
+ Config $dataName $args
+
+ if {$data(-parent) eq "."} {
+ set w .$dataName
+ } else {
+ set w $data(-parent).$dataName
+ }
+
+ # (re)create the dialog box if necessary
+ #
+ if {![winfo exists $w]} {
+ ::tk::dialog::file::Create $w TkChooseDir
+ } elseif {[winfo class $w] ne "TkChooseDir"} {
+ destroy $w
+ ::tk::dialog::file::Create $w TkChooseDir
+ } else {
+ set data(dirMenuBtn) $w.contents.f1.menu
+ set data(dirMenu) $w.contents.f1.menu.menu
+ set data(upBtn) $w.contents.f1.up
+ set data(icons) $w.contents.icons
+ set data(ent) $w.contents.f2.ent
+ set data(okBtn) $w.contents.f2.ok
+ set data(cancelBtn) $w.contents.f2.cancel
+ set data(hiddenBtn) $w.contents.f2.hidden
+ }
+ if {$::tk::dialog::file::showHiddenBtn} {
+ $data(hiddenBtn) configure -state normal
+ grid $data(hiddenBtn)
+ } else {
+ $data(hiddenBtn) configure -state disabled
+ grid remove $data(hiddenBtn)
+ }
+
+ # When using -mustexist, manage the OK button state for validity
+ $data(okBtn) configure -state normal
+ if {$data(-mustexist)} {
+ $data(ent) configure -validate key \
+ -validatecommand [list ::tk::dialog::file::chooseDir::IsOK? $w %P]
+ } else {
+ $data(ent) configure -validate none
+ }
+
+ # Dialog boxes should be transient with respect to their parent,
+ # so that they will always stay on top of their parent window. However,
+ # some window managers will create the window as withdrawn if the parent
+ # window is withdrawn or iconified. Combined with the grab we put on the
+ # window, this can hang the entire application. Therefore we only make
+ # the dialog transient if the parent is viewable.
+
+ if {[winfo viewable [winfo toplevel $data(-parent)]] } {
+ wm transient $w $data(-parent)
+ }
+
+ trace add variable data(selectPath) write \
+ [list ::tk::dialog::file::SetPath $w]
+ $data(dirMenuBtn) configure \
+ -textvariable ::tk::dialog::file::${dataName}(selectPath)
+
+ set data(filter) "*"
+ set data(previousEntryText) ""
+ ::tk::dialog::file::UpdateWhenIdle $w
+
+ # 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 (Motif style) and de-iconify it.
+
+ ::tk::PlaceWindow $w widget $data(-parent)
+ wm title $w $data(-title)
+
+ # Set a grab and claim the focus too.
+
+ ::tk::SetFocusGrab $w $data(ent)
+ $data(ent) delete 0 end
+ $data(ent) insert 0 $data(selectPath)
+ $data(ent) selection range 0 end
+ $data(ent) icursor end
+
+ # Wait for the user to respond, then restore the focus and
+ # return the index of the selected button. Restore the focus
+ # before deleting the window, since otherwise the window manager
+ # may take the focus away so we can't redirect it. Finally,
+ # restore any grab that was in effect.
+
+ vwait ::tk::Priv(selectFilePath)
+
+ ::tk::RestoreFocusGrab $w $data(ent) withdraw
+
+ # Cleanup traces on selectPath variable
+ #
+
+ foreach trace [trace info variable data(selectPath)] {
+ trace remove variable data(selectPath) [lindex $trace 0] [lindex $trace 1]
+ }
+ if {[winfo exists $data(dirMenuBtn)]} {
+ $data(dirMenuBtn) configure -textvariable {}
+ }
+
+ # Return value to user
+ #
+
+ return $Priv(selectFilePath)
+}
+
+# ::tk::dialog::file::chooseDir::Config --
+#
+# Configures the Tk choosedir dialog according to the argument list
+#
+proc ::tk::dialog::file::chooseDir::Config {dataName argList} {
+ upvar ::tk::dialog::file::$dataName data
+
+ # 0: Delete all variable that were set on data(selectPath) the
+ # last time the file dialog is used. The traces may cause troubles
+ # if the dialog is now used with a different -parent option.
+ #
+ foreach trace [trace info variable data(selectPath)] {
+ trace remove variable data(selectPath) [lindex $trace 0] [lindex $trace 1]
+ }
+
+ # 1: the configuration specs
+ #
+ set specs {
+ {-mustexist "" "" 0}
+ {-initialdir "" "" ""}
+ {-parent "" "" "."}
+ {-title "" "" ""}
+ }
+
+ # 2: default values depending on the type of the dialog
+ #
+ if {![info exists data(selectPath)]} {
+ # first time the dialog has been popped up
+ set data(selectPath) [pwd]
+ }
+
+ # 3: parse the arguments
+ #
+ tclParseConfigSpec ::tk::dialog::file::$dataName $specs "" $argList
+
+ if {$data(-title) eq ""} {
+ set data(-title) "[mc "Choose Directory"]"
+ }
+
+ # Stub out the -multiple value for the dialog; it doesn't make sense for
+ # choose directory dialogs, but we have to have something there because we
+ # share so much code with the file dialogs.
+ set data(-multiple) 0
+
+ # 4: set the default directory and selection according to the -initial
+ # settings
+ #
+ if {$data(-initialdir) ne ""} {
+ # Ensure that initialdir is an absolute path name.
+ if {[file isdirectory $data(-initialdir)]} {
+ set old [pwd]
+ cd $data(-initialdir)
+ set data(selectPath) [pwd]
+ cd $old
+ } else {
+ set data(selectPath) [pwd]
+ }
+ }
+
+ if {![winfo exists $data(-parent)]} {
+ return -code error -errorcode [list TK LOOKUP WINDOW $data(-parent)] \
+ "bad window path name \"$data(-parent)\""
+ }
+}
+
+# Gets called when user presses Return in the "Selection" entry or presses OK.
+#
+proc ::tk::dialog::file::chooseDir::OkCmd {w} {
+ upvar ::tk::dialog::file::[winfo name $w] data
+
+ # This is the brains behind selecting non-existant directories. Here's
+ # the flowchart:
+ # 1. If the icon list has a selection, join it with the current dir,
+ # and return that value.
+ # 1a. If the icon list does not have a selection ...
+ # 2. If the entry is empty, do nothing.
+ # 3. If the entry contains an invalid directory, then...
+ # 3a. If the value is the same as last time through here, end dialog.
+ # 3b. If the value is different than last time, save it and return.
+ # 4. If entry contains a valid directory, then...
+ # 4a. If the value is the same as the current directory, end dialog.
+ # 4b. If the value is different from the current directory, change to
+ # that directory.
+
+ set selection [$data(icons) selection get]
+ if {[llength $selection] != 0} {
+ set iconText [$data(icons) get [lindex $selection 0]]
+ set iconText [file join $data(selectPath) $iconText]
+ Done $w $iconText
+ } else {
+ set text [$data(ent) get]
+ if {$text eq ""} {
+ return
+ }
+ set text [file join {*}[file split [string trim $text]]]
+ if {![file exists $text] || ![file isdirectory $text]} {
+ # Entry contains an invalid directory. If it's the same as the
+ # last time they came through here, reset the saved value and end
+ # the dialog. Otherwise, save the value (so we can do this test
+ # next time).
+ if {$text eq $data(previousEntryText)} {
+ set data(previousEntryText) ""
+ Done $w $text
+ } else {
+ set data(previousEntryText) $text
+ }
+ } else {
+ # Entry contains a valid directory. If it is the same as the
+ # current directory, end the dialog. Otherwise, change to that
+ # directory.
+ if {$text eq $data(selectPath)} {
+ Done $w $text
+ } else {
+ set data(selectPath) $text
+ }
+ }
+ }
+ return
+}
+
+# Change state of OK button to match -mustexist correctness of entry
+#
+proc ::tk::dialog::file::chooseDir::IsOK? {w text} {
+ upvar ::tk::dialog::file::[winfo name $w] data
+
+ set ok [file isdirectory $text]
+ $data(okBtn) configure -state [expr {$ok ? "normal" : "disabled"}]
+
+ # always return 1
+ return 1
+}
+
+proc ::tk::dialog::file::chooseDir::DblClick {w} {
+ upvar ::tk::dialog::file::[winfo name $w] data
+ set selection [$data(icons) selection get]
+ if {[llength $selection] != 0} {
+ set filenameFragment [$data(icons) get [lindex $selection 0]]
+ set file $data(selectPath)
+ if {[file isdirectory $file]} {
+ ::tk::dialog::file::ListInvoke $w [list $filenameFragment]
+ return
+ }
+ }
+}
+
+# Gets called when user browses the IconList widget (dragging mouse, arrow
+# keys, etc)
+#
+proc ::tk::dialog::file::chooseDir::ListBrowse {w text} {
+ upvar ::tk::dialog::file::[winfo name $w] data
+
+ if {$text eq ""} {
+ return
+ }
+
+ set file [::tk::dialog::file::JoinFile $data(selectPath) $text]
+ $data(ent) delete 0 end
+ $data(ent) insert 0 $file
+}
+
+# ::tk::dialog::file::chooseDir::Done --
+#
+# Gets called when user has input a valid filename. Pops up a
+# dialog box to confirm selection when necessary. Sets the
+# Priv(selectFilePath) variable, which will break the "vwait"
+# loop in tk_chooseDirectory and return the selected filename to the
+# script that calls tk_getOpenFile or tk_getSaveFile
+#
+proc ::tk::dialog::file::chooseDir::Done {w {selectFilePath ""}} {
+ upvar ::tk::dialog::file::[winfo name $w] data
+ variable ::tk::Priv
+
+ if {$selectFilePath eq ""} {
+ set selectFilePath $data(selectPath)
+ }
+ if {$data(-mustexist) && ![file isdirectory $selectFilePath]} {
+ return
+ }
+ set Priv(selectFilePath) $selectFilePath
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/choosedir.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/clrpick.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/clrpick.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/clrpick.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,696 @@
+# clrpick.tcl --
+#
+# Color selection dialog for platforms that do not support a
+# standard color selection dialog.
+#
+# Copyright © 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.
+#
+
+# Make sure namespaces exist
+namespace eval ::tk {}
+namespace eval ::tk::dialog {}
+namespace eval ::tk::dialog::color {
+ namespace import ::tk::msgcat::*
+}
+
+# ::tk::dialog::color:: --
+#
+# 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 ::tk::dialog::color:: {args} {
+ variable ::tk::Priv
+ set dataName __tk__color
+ upvar ::tk::dialog::color::$dataName data
+ set w .$dataName
+
+ # 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) 16
+
+ # BARS_WIDTH is the number of pixels wide the color bar portion of the
+ # canvas is. BARS_WIDTH, BARS_WIDTH * 1.25, BARS_WIDTH * 1.5, and
+ # BARS_WIDTH * 1.75 must be multiples of NUM_COLORBARS.
+ set data(BARS_WIDTH) [::tk::ScaleNum 192]
+
+ # 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. PLGN_WIDTH,
+ # PLGN_WIDTH * 1.25, PLGN_WIDTH * 1.5, and PLGN_WIDTH * 1.75 must be even.
+ set data(PLGN_WIDTH) [::tk::ScaleNum 8]
+
+ # 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_HEIGHT) [::tk::ScaleNum 8]
+
+ Config $dataName $args
+ InitValues $dataName
+
+ set sc [winfo screen $data(-parent)]
+ set winExists [winfo exists $w]
+ if {!$winExists || $sc ne [winfo screen $w]} {
+ if {$winExists} {
+ destroy $w
+ }
+ toplevel $w -class TkColorDialog -screen $sc
+ if {[tk windowingsystem] eq "x11"} {wm attributes $w -type dialog}
+ BuildDialog $w
+ }
+
+ # Dialog boxes should be transient with respect to their parent,
+ # so that they will always stay on top of their parent window. However,
+ # some window managers will create the window as withdrawn if the parent
+ # window is withdrawn or iconified. Combined with the grab we put on the
+ # window, this can hang the entire application. Therefore we only make
+ # the dialog transient if the parent is viewable.
+
+ if {[winfo viewable [winfo toplevel $data(-parent)]] } {
+ 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 (Motif style) and de-iconify it.
+
+ ::tk::PlaceWindow $w widget $data(-parent)
+ wm title $w $data(-title)
+
+ # 6. Set a grab and claim the focus too.
+
+ ::tk::SetFocusGrab $w $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.
+
+ vwait ::tk::Priv(selectColor)
+ set result $Priv(selectColor)
+ ::tk::RestoreFocusGrab $w $data(okBtn)
+ unset data
+
+ return $result
+}
+
+# ::tk::dialog::color::InitValues --
+#
+# Get called during initialization or when user resets NUM_COLORBARS
+#
+proc ::tk::dialog::color::InitValues {dataName} {
+ upvar ::tk::dialog::color::$dataName 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}]
+}
+
+# ::tk::dialog::color::Config --
+#
+# Parses the command line arguments to tk_chooseColor
+#
+proc ::tk::dialog::color::Config {dataName argList} {
+ variable ::tk::Priv
+ upvar ::tk::dialog::color::$dataName data
+
+ # 1: the configuration specs
+ #
+ if {[info exists Priv(selectColor)] && $Priv(selectColor) ne ""} {
+ set defaultColor $Priv(selectColor)
+ } else {
+ set defaultColor [. cget -background]
+ }
+
+ set specs [list \
+ [list -initialcolor "" "" $defaultColor] \
+ [list -parent "" "" "."] \
+ [list -title "" "" [mc "Color"]] \
+ ]
+
+ # 2: parse the arguments
+ #
+ tclParseConfigSpec ::tk::dialog::color::$dataName $specs "" $argList
+
+ if {$data(-title) eq ""} {
+ set data(-title) " "
+ }
+ if {[catch {winfo rgb . $data(-initialcolor)} err]} {
+ return -code error -errorcode [list TK LOOKUP COLOR $data(-initialcolor)] \
+ $err
+ }
+
+ if {![winfo exists $data(-parent)]} {
+ return -code error -errorcode [list TK LOOKUP WINDOW $data(-parent)] \
+ "bad window path name \"$data(-parent)\""
+ }
+}
+
+# ::tk::dialog::color::BuildDialog --
+#
+# Build the dialog.
+#
+proc ::tk::dialog::color::BuildDialog {w} {
+ upvar ::tk::dialog::color::[winfo name $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]
+
+ set maxWidth [::tk::mcmaxamp &Red &Green &Blue]
+ set maxWidth [expr {$maxWidth<6 ? 6 : $maxWidth}]
+ set colorList {
+ red "&Red"
+ green "&Green"
+ blue "&Blue"
+ }
+ foreach {color l} $colorList {
+ # 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]
+
+ ::tk::AmpWidget label $box.label -text "[mc $l]:" \
+ -width $maxWidth -anchor ne
+ bind $box.label <<AltUnderlined>> [list focus $box.entry]
+
+ entry $box.entry -textvariable \
+ ::tk::dialog::color::[winfo name $w]($color,intensity) \
+ -width 4
+ pack $box.label -side left -fill y -padx 1.5p -pady 2p
+ 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 1.5p
+
+ set data($color,entry) $box.entry
+ set data($color,col) $f.color
+ set data($color,sel) $f.sel
+
+ bind $data($color,col) <Configure> \
+ [list tk::dialog::color::DrawColorScale $w $color 1]
+ bind $data($color,col) <Enter> \
+ [list tk::dialog::color::EnterColorBar $w $color]
+ bind $data($color,col) <Leave> \
+ [list tk::dialog::color::LeaveColorBar $w $color]
+
+ bind $data($color,sel) <Enter> \
+ [list tk::dialog::color::EnterColorBar $w $color]
+ bind $data($color,sel) <Leave> \
+ [list tk::dialog::color::LeaveColorBar $w $color]
+
+ bind $box.entry <Return> [list tk::dialog::color::HandleRGBEntry $w]
+ }
+
+ pack $stripsFrame -side left -fill both -padx 3p -pady 7.5p
+
+ # The selFrame contains a frame that demonstrates the currently
+ # selected color
+ #
+ set selFrame [frame $topFrame.sel]
+ set lab [::tk::AmpWidget label $selFrame.lab \
+ -text [mc "&Selection:"] -anchor sw]
+ set ent [entry $selFrame.ent \
+ -textvariable ::tk::dialog::color::[winfo name $w](selection) \
+ -width 16]
+ set f1 [frame $selFrame.f1 -relief sunken -bd 2]
+ set data(finalCanvas) [frame $f1.demo -bd 0 -width 75p -height 51p]
+
+ pack $lab $ent -side top -fill x -padx 3p -pady 1.5p
+ pack $f1 -expand yes -anchor nw -fill both -padx 4.5p -pady 7.5p
+ pack $data(finalCanvas) -expand yes -fill both
+
+ bind $ent <Return> [list tk::dialog::color::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]
+
+ ::tk::AmpWidget button $botFrame.ok -text [mc "&OK"] \
+ -command [list tk::dialog::color::OkCmd $w]
+ ::tk::AmpWidget button $botFrame.cancel -text [mc "&Cancel"] \
+ -command [list tk::dialog::color::CancelCmd $w]
+
+ set data(okBtn) $botFrame.ok
+ set data(cancelBtn) $botFrame.cancel
+
+ grid x $botFrame.ok x $botFrame.cancel x -sticky ew
+ grid configure $botFrame.ok $botFrame.cancel -padx 7.5p -pady 7.5p
+ grid columnconfigure $botFrame {0 4} -weight 1 -uniform space
+ grid columnconfigure $botFrame {1 3} -weight 1 -uniform button
+ grid columnconfigure $botFrame 2 -weight 2 -uniform space
+ pack $botFrame -side bottom -fill x
+
+ # Accelerator bindings
+ bind $lab <<AltUnderlined>> [list focus $ent]
+ bind $w <Escape> [list tk::ButtonInvoke $data(cancelBtn)]
+ bind $w <Alt-Key> [list tk::AltKeyInDialog $w %A]
+
+ wm protocol $w WM_DELETE_WINDOW [list tk::dialog::color::CancelCmd $w]
+}
+
+# ::tk::dialog::color::SetRGBValue --
+#
+# Sets the current selection of the dialog box
+#
+proc ::tk::dialog::color::SetRGBValue {w color} {
+ upvar ::tk::dialog::color::[winfo name $w] data
+
+ set data(red,intensity) [lindex $color 0]
+ set data(green,intensity) [lindex $color 1]
+ set data(blue,intensity) [lindex $color 2]
+
+ RedrawColorBars $w all
+
+ # Now compute the new x value of each colorbars pointer polygon
+ foreach color {red green blue} {
+ set x [RgbToX $w $data($color,intensity)]
+ MoveSelector $w $data($color,sel) $color $x 0
+ }
+}
+
+# ::tk::dialog::color::XToRgb --
+#
+# Converts a screen coordinate to intensity
+#
+proc ::tk::dialog::color::XToRgb {w x} {
+ upvar ::tk::dialog::color::[winfo name $w] data
+
+ set x [expr {($x * $data(intensityIncr))/ $data(colorbarWidth)}]
+ if {$x > 255} {
+ set x 255
+ }
+ return $x
+}
+
+# ::tk::dialog::color::RgbToX
+#
+# Converts an intensity to screen coordinate.
+#
+proc ::tk::dialog::color::RgbToX {w color} {
+ upvar ::tk::dialog::color::[winfo name $w] data
+
+ return [expr {($color * $data(colorbarWidth)/ $data(intensityIncr))}]
+}
+
+# ::tk::dialog::color::DrawColorScale --
+#
+# Draw color scale is called whenever the size of one of the color
+# scale canvases is changed.
+#
+proc ::tk::dialog::color::DrawColorScale {w c {create 0}} {
+ upvar ::tk::dialog::color::[winfo name $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
+ CreateSelector $w $sel $c
+ $sel bind $data($c,index) <Button-1> \
+ [list tk::dialog::color::StartMove $w $sel $c %x $data(selPad) 1]
+ $sel bind $data($c,index) <B1-Motion> \
+ [list tk::dialog::color::MoveSelector $w $sel $c %x $data(selPad)]
+ $sel bind $data($c,index) <ButtonRelease-1> \
+ [list tk::dialog::color::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 <Button-1> \
+ [list tk::dialog::color::StartMove $w $sel $c %x $data(colorPad)]
+ bind $col <B1-Motion> \
+ [list tk::dialog::color::MoveSelector $w $sel $c %x $data(colorPad)]
+ bind $col <ButtonRelease-1> \
+ [list tk::dialog::color::ReleaseMouse $w $sel $c %x $data(colorPad)]
+
+ $sel bind $data($c,clickRegion) <Button-1> \
+ [list tk::dialog::color::StartMove $w $sel $c %x $data(selPad)]
+ $sel bind $data($c,clickRegion) <B1-Motion> \
+ [list tk::dialog::color::MoveSelector $w $sel $c %x $data(selPad)]
+ $sel bind $data($c,clickRegion) <ButtonRelease-1> \
+ [list tk::dialog::color::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 eq "red"} {
+ set color [format "#%02x%02x%02x" \
+ $intensity $data(green,intensity) $data(blue,intensity)]
+ } elseif {$c eq "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 itemconfigure $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}]
+ }
+
+ RedrawFinalColor $w
+}
+
+# ::tk::dialog::color::CreateSelector --
+#
+# Creates and draws the selector polygon at the position
+# $data($c,intensity).
+#
+proc ::tk::dialog::color::CreateSelector {w sel c } {
+ upvar ::tk::dialog::color::[winfo name $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) [RgbToX $w $data($c,intensity)]
+ $sel move $data($c,index) $data($c,x) 0
+}
+
+# ::tk::dialog::color::RedrawFinalColor
+#
+# Combines the intensities of the three colors into the final color
+#
+proc ::tk::dialog::color::RedrawFinalColor {w} {
+ upvar ::tk::dialog::color::[winfo name $w] data
+
+ set color [format "#%02x%02x%02x" $data(red,intensity) \
+ $data(green,intensity) $data(blue,intensity)]
+
+ $data(finalCanvas) configure -bg $color
+ set data(finalColor) $color
+ set data(selection) $color
+ set data(finalRGB) [list \
+ $data(red,intensity) \
+ $data(green,intensity) \
+ $data(blue,intensity)]
+}
+
+# ::tk::dialog::color::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 ::tk::dialog::color::RedrawColorBars {w colorChanged} {
+ upvar ::tk::dialog::color::[winfo name $w] data
+
+ switch $colorChanged {
+ red {
+ DrawColorScale $w green
+ DrawColorScale $w blue
+ }
+ green {
+ DrawColorScale $w red
+ DrawColorScale $w blue
+ }
+ blue {
+ DrawColorScale $w red
+ DrawColorScale $w green
+ }
+ default {
+ DrawColorScale $w red
+ DrawColorScale $w green
+ DrawColorScale $w blue
+ }
+ }
+ RedrawFinalColor $w
+}
+
+#----------------------------------------------------------------------
+# Event handlers
+#----------------------------------------------------------------------
+
+# ::tk::dialog::color::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 ::tk::dialog::color::StartMove {w sel color x delta {dontMove 0}} {
+ upvar ::tk::dialog::color::[winfo name $w] data
+
+ if {!$dontMove} {
+ MoveSelector $w $sel $color $x $delta
+ }
+}
+
+# ::tk::dialog::color::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 ::tk::dialog::color::MoveSelector {w sel color x delta} {
+ upvar ::tk::dialog::color::[winfo name $w] data
+
+ incr x -$delta
+
+ if { $x < 0 } {
+ set x 0
+ } elseif { $x > $data(BARS_WIDTH)} {
+ set x $data(BARS_WIDTH)
+ }
+ 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
+}
+
+# ::tk::dialog::color::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 ::tk::dialog::color::ReleaseMouse {w sel color x delta} {
+ upvar ::tk::dialog::color::[winfo name $w] data
+
+ set x [MoveSelector $w $sel $color $x $delta]
+
+ # Determine exactly what color we are looking at.
+ set data($color,intensity) [XToRgb $w $x]
+
+ RedrawColorBars $w $color
+}
+
+# ::tk::dialog::color::ResizeColorbars --
+#
+# Completely redraws the colorbars, including resizing the
+# colorstrips
+#
+proc ::tk::dialog::color::ResizeColorBars {w} {
+ upvar ::tk::dialog::color::[winfo name $w] data
+
+ if {
+ ($data(BARS_WIDTH) < $data(NUM_COLORBARS)) ||
+ (($data(BARS_WIDTH) % $data(NUM_COLORBARS)) != 0)
+ } then {
+ set data(BARS_WIDTH) $data(NUM_COLORBARS)
+ }
+ InitValues [winfo name $w]
+ foreach color {red green blue} {
+ $data($color,col) configure -width $data(canvasWidth)
+ DrawColorScale $w $color 1
+ }
+}
+
+# ::tk::dialog::color::HandleSelEntry --
+#
+# Handles the return keypress event in the "Selection:" entry
+#
+proc ::tk::dialog::color::HandleSelEntry {w} {
+ upvar ::tk::dialog::color::[winfo name $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}]
+
+ SetRGBValue $w "$R $G $B"
+ set data(selection) $text
+}
+
+# ::tk::dialog::color::HandleRGBEntry --
+#
+# Handles the return keypress event in the R, G or B entry
+#
+proc ::tk::dialog::color::HandleRGBEntry {w} {
+ upvar ::tk::dialog::color::[winfo name $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
+ }
+ }
+
+ SetRGBValue $w "$data(red,intensity) \
+ $data(green,intensity) $data(blue,intensity)"
+}
+
+# mouse cursor enters a color bar
+#
+proc ::tk::dialog::color::EnterColorBar {w color} {
+ upvar ::tk::dialog::color::[winfo name $w] data
+
+ $data($color,sel) itemconfigure $data($color,index) -fill red
+}
+
+# mouse leaves enters a color bar
+#
+proc ::tk::dialog::color::LeaveColorBar {w color} {
+ upvar ::tk::dialog::color::[winfo name $w] data
+
+ $data($color,sel) itemconfigure $data($color,index) -fill black
+}
+
+# user hits OK button
+#
+proc ::tk::dialog::color::OkCmd {w} {
+ variable ::tk::Priv
+ upvar ::tk::dialog::color::[winfo name $w] data
+
+ set Priv(selectColor) $data(finalColor)
+}
+
+# user hits Cancel button or destroys window
+#
+proc ::tk::dialog::color::CancelCmd {w} {
+ variable ::tk::Priv
+ set Priv(selectColor) ""
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/clrpick.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/comdlg.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/comdlg.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/comdlg.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,322 @@
+# comdlg.tcl --
+#
+# Some functions needed for the common dialog boxes. Probably need to go
+# in a different file.
+#
+# Copyright © 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 = a list of flags. Currently supported flags are:
+# DONTSETDEFAULTS = skip default values setting
+#
+# 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} {
+ return -code error -errorcode {TK VALUE CONFIG_SPEC} \
+ "\"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 {[llength $argList] & 1} {
+ set cmdsw [lindex $argList end]
+ if {![info exists cmd($cmdsw)]} {
+ return -code error -errorcode [list TK LOOKUP OPTION $cmdsw] \
+ "bad option \"$cmdsw\": must be [tclListValidFlags cmd]"
+ }
+ return -code error -errorcode {TK VALUE_MISSING} \
+ "value for \"$cmdsw\" missing"
+ }
+
+ # 2: set the default values
+ #
+ if {"DONTSETDEFAULTS" ni $flags} {
+ foreach cmdsw [array names cmd] {
+ set data($cmdsw) $def($cmdsw)
+ }
+ }
+
+ # 3: parse the argument list
+ #
+ foreach {cmdsw value} $argList {
+ if {![info exists cmd($cmdsw)]} {
+ return -code error -errorcode [list TK LOOKUP OPTION $cmdsw] \
+ "bad 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
+}
+
+#----------------------------------------------------------------------
+#
+# 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.
+#
+#----------------------------------------------------------------------
+
+
+# ::tk::FocusGroup_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 ::tk::FocusGroup_Create {t} {
+ variable ::tk::Priv
+ if {[winfo toplevel $t] ne $t} {
+ return -code error -errorcode [list TK LOOKUP TOPLEVEL $t] \
+ "$t is not a toplevel window"
+ }
+ if {![info exists Priv(fg,$t)]} {
+ set Priv(fg,$t) 1
+ set Priv(focus,$t) ""
+ bind $t <FocusIn> [list tk::FocusGroup_In $t %W %d]
+ bind $t <FocusOut> [list tk::FocusGroup_Out $t %W %d]
+ bind $t <Destroy> [list tk::FocusGroup_Destroy $t %W]
+ }
+}
+
+# ::tk::FocusGroup_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 ::tk::FocusGroup_BindIn {t w cmd} {
+ variable FocusIn
+ variable ::tk::Priv
+ if {![info exists Priv(fg,$t)]} {
+ return -code error -errorcode [list TK LOOKUP FOCUS_GROUP $t] \
+ "focus group \"$t\" does not exist"
+ }
+ set FocusIn($t,$w) $cmd
+}
+
+
+# ::tk::FocusGroup_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 ::tk::FocusGroup_BindOut {t w cmd} {
+ variable FocusOut
+ variable ::tk::Priv
+ if {![info exists Priv(fg,$t)]} {
+ return -code error -errorcode [list TK LOOKUP FOCUS_GROUP $t] \
+ "focus group \"$t\" does not exist"
+ }
+ set FocusOut($t,$w) $cmd
+}
+
+# ::tk::FocusGroup_Destroy --
+#
+# Cleans up when members of the focus group is deleted, or when the
+# toplevel itself gets deleted.
+#
+proc ::tk::FocusGroup_Destroy {t w} {
+ variable FocusIn
+ variable FocusOut
+ variable ::tk::Priv
+
+ if {$t eq $w} {
+ unset Priv(fg,$t)
+ unset Priv(focus,$t)
+
+ foreach name [array names FocusIn $t,*] {
+ unset FocusIn($name)
+ }
+ foreach name [array names FocusOut $t,*] {
+ unset FocusOut($name)
+ }
+ } else {
+ if {[info exists Priv(focus,$t)] && ($Priv(focus,$t) eq $w)} {
+ set Priv(focus,$t) ""
+ }
+ unset -nocomplain FocusIn($t,$w) FocusOut($t,$w)
+ }
+}
+
+# ::tk::FocusGroup_In --
+#
+# Handles the <FocusIn> event. Calls the FocusIn command for the newly
+# focused widget in the focus group.
+#
+proc ::tk::FocusGroup_In {t w detail} {
+ variable FocusIn
+ variable ::tk::Priv
+
+ if {$detail ne "NotifyNonlinear" && $detail ne "NotifyNonlinearVirtual"} {
+ # This is caused by mouse moving out&in of the window *or*
+ # ordinary keypresses some window managers (ie: CDE [Bug: 2960]).
+ return
+ }
+ if {![info exists FocusIn($t,$w)]} {
+ set FocusIn($t,$w) ""
+ return
+ }
+ if {![info exists Priv(focus,$t)]} {
+ return
+ }
+ if {$Priv(focus,$t) eq $w} {
+ # This is already in focus
+ #
+ return
+ } else {
+ set Priv(focus,$t) $w
+ eval $FocusIn($t,$w)
+ }
+}
+
+# ::tk::FocusGroup_Out --
+#
+# Handles the <FocusOut> 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 ::tk::FocusGroup_Out {t w detail} {
+ variable FocusOut
+ variable ::tk::Priv
+
+ if {$detail ne "NotifyNonlinear" && $detail ne "NotifyNonlinearVirtual"} {
+ # This is caused by mouse moving out of the window
+ return
+ }
+ if {![info exists Priv(focus,$t)]} {
+ return
+ }
+ if {![info exists FocusOut($t,$w)]} {
+ return
+ } else {
+ eval $FocusOut($t,$w)
+ set Priv(focus,$t) ""
+ }
+}
+
+# ::tk::FDGetFileTypes --
+#
+# 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 ::tk::FDGetFileTypes {string} {
+ foreach t $string {
+ if {[llength $t] < 2 || [llength $t] > 3} {
+ return -code error -errorcode {TK VALUE FILE_TYPE} \
+ "bad file type \"$t\", should be \"typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?\""
+ }
+ lappend 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
+ }
+
+ # Validate each macType. This is to agree with the
+ # behaviour of TkGetFileFilters(). This list may be
+ # empty.
+ foreach macType [lindex $t 2] {
+ if {[string length $macType] != 4} {
+ return -code error -errorcode {TK VALUE MAC_TYPE} \
+ "bad Macintosh file type \"$macType\""
+ }
+ }
+
+ set name "$label \("
+ set sep ""
+ set doAppend 1
+ foreach ext $fileTypes($label) {
+ if {$ext eq ""} {
+ continue
+ }
+ regsub {^[.]} $ext "*." ext
+ if {![info exists hasGotExt($label,$ext)]} {
+ if {$doAppend} {
+ if {[string length $sep] && [string length $name]>40} {
+ set doAppend 0
+ append name $sep...
+ } else {
+ 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
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/comdlg.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/console.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/console.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/console.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,1143 @@
+# 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.
+#
+# Copyright © 1995-1997 Sun Microsystems, Inc.
+# Copyright © 1998-2000 Ajuba Solutions.
+# Copyright © 2007-2008 Daniel A. Steffen <das at users.sourceforge.net>
+#
+# 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
+
+namespace eval ::tk::console {
+ variable blinkTime 500 ; # msecs to blink braced range for
+ variable blinkRange 1 ; # enable blinking of the entire braced range
+ variable magicKeys 1 ; # enable brace matching and proc/var recognition
+ variable maxLines 600 ; # maximum # of lines buffered in console
+ variable showMatches 1 ; # show multiple expand matches
+ variable useFontchooser [llength [info command ::tk::fontchooser]]
+ variable inPlugin [info exists embed_args]
+ variable defaultPrompt ; # default prompt if tcl_prompt1 isn't used
+
+ if {$inPlugin} {
+ set defaultPrompt {subst {[history nextid] % }}
+ } else {
+ set defaultPrompt {subst {([file tail [pwd]]) [history nextid] % }}
+ }
+}
+
+# simple compat function for tkcon code added for this console
+interp alias {} EvalAttached {} consoleinterp eval
+
+# ::tk::ConsoleInit --
+# This procedure constructs and configures the console windows.
+#
+# Arguments:
+# None.
+
+proc ::tk::ConsoleInit {} {
+ if {![consoleinterp eval {set tcl_interactive}]} {
+ wm withdraw .
+ }
+
+ if {[tk windowingsystem] eq "aqua"} {
+ set mod "Cmd"
+ } else {
+ set mod "Ctrl"
+ }
+
+ if {[catch {menu .menubar} err]} {
+ bgerror "INIT: $err"
+ }
+ AmpMenuArgs .menubar add cascade -label [mc &File] -menu .menubar.file
+ AmpMenuArgs .menubar add cascade -label [mc &Edit] -menu .menubar.edit
+
+ menu .menubar.file -tearoff 0
+ AmpMenuArgs .menubar.file add command -label [mc "&Source..."] \
+ -command {tk::ConsoleSource}
+ AmpMenuArgs .menubar.file add command -label [mc "&Hide Console"] \
+ -command {wm withdraw .}
+ AmpMenuArgs .menubar.file add command -label [mc "&Clear Console"] \
+ -command {.console delete 1.0 "promptEnd linestart"}
+ if {[tk windowingsystem] ne "aqua"} {
+ AmpMenuArgs .menubar.file add command -label [mc E&xit] -command {exit}
+ }
+
+ menu .menubar.edit -tearoff 0
+ AmpMenuArgs .menubar.edit add command -label [mc Cu&t] -accel "$mod+X"\
+ -command {event generate .console <<Cut>>}
+ AmpMenuArgs .menubar.edit add command -label [mc &Copy] -accel "$mod+C"\
+ -command {event generate .console <<Copy>>}
+ AmpMenuArgs .menubar.edit add command -label [mc P&aste] -accel "$mod+V"\
+ -command {event generate .console <<Paste>>}
+
+ if {[tk windowingsystem] ne "win32"} {
+ AmpMenuArgs .menubar.edit add command -label [mc Cl&ear] \
+ -command {event generate .console <<Clear>>}
+ } else {
+ AmpMenuArgs .menubar.edit add command -label [mc &Delete] \
+ -command {event generate .console <<Clear>>} -accel "Del"
+
+ AmpMenuArgs .menubar add cascade -label [mc &Help] -menu .menubar.help
+ menu .menubar.help -tearoff 0
+ AmpMenuArgs .menubar.help add command -label [mc &About...] \
+ -command tk::ConsoleAbout
+ }
+
+ AmpMenuArgs .menubar.edit add separator
+ if {$::tk::console::useFontchooser} {
+ if {[tk windowingsystem] eq "aqua"} {
+ .menubar.edit add command -label tk_choose_font_marker
+ set index [.menubar.edit index tk_choose_font_marker]
+ .menubar.edit entryconfigure $index \
+ -label [mc "Show Fonts"]\
+ -accelerator "$mod-T"\
+ -command [list ::tk::console::FontchooserToggle]
+ bind Console <<TkFontchooserVisibility>> \
+ [list ::tk::console::FontchooserVisibility $index]
+ ::tk::console::FontchooserVisibility $index
+ } else {
+ AmpMenuArgs .menubar.edit add command -label [mc "&Font..."] \
+ -command [list ::tk::console::FontchooserToggle]
+ }
+ bind Console <FocusIn> [list ::tk::console::FontchooserFocus %W 1]
+ bind Console <FocusOut> [list ::tk::console::FontchooserFocus %W 0]
+ }
+ AmpMenuArgs .menubar.edit add command -label [mc "&Increase Font Size"] \
+ -accel "$mod++" -command {event generate .console <<Console_FontSizeIncr>>}
+ AmpMenuArgs .menubar.edit add command -label [mc "&Decrease Font Size"] \
+ -accel "$mod+-" -command {event generate .console <<Console_FontSizeDecr>>}
+ AmpMenuArgs .menubar.edit add command -label [mc "Fit To Screen Width"] \
+ -command {event generate .console <<Console_FitScreenWidth>>}
+
+ if {[tk windowingsystem] eq "aqua"} {
+ .menubar add cascade -label [mc Window] -menu [menu .menubar.window]
+ .menubar add cascade -label [mc Help] -menu [menu .menubar.help]
+ }
+
+ . configure -menu .menubar
+
+ # See if we can find a better font than the TkFixedFont
+ catch {font create TkConsoleFont {*}[font configure TkFixedFont]}
+ set families [font families]
+ switch -exact -- [tk windowingsystem] {
+ aqua { set preferred {Monaco 10} }
+ win32 { set preferred {ProFontWindows 8 Consolas 8} }
+ default { set preferred {} }
+ }
+ foreach {family size} $preferred {
+ if {$family in $families} {
+ font configure TkConsoleFont -family $family -size $size
+ break
+ }
+ }
+
+ # Provide the right border for the text widget (platform dependent).
+ ::ttk::style layout ConsoleFrame {
+ Entry.field -sticky news -border 1 -children {
+ ConsoleFrame.padding -sticky news
+ }
+ }
+ ::ttk::frame .consoleframe -style ConsoleFrame
+
+ set con [text .console -yscrollcommand [list .sb set] -setgrid true \
+ -borderwidth 0 -highlightthickness 0 -font TkConsoleFont]
+ if {[tk windowingsystem] eq "aqua"} {
+ scrollbar .sb -command [list $con yview]
+ } else {
+ ::ttk::scrollbar .sb -command [list $con yview]
+ }
+ pack .sb -in .consoleframe -fill both -side right -padx 1 -pady 1
+ pack $con -in .consoleframe -fill both -expand 1 -side left -padx 1 -pady 1
+ pack .consoleframe -fill both -expand 1 -side left
+
+ ConsoleBind $con
+
+ $con tag configure stderr -foreground red
+ $con tag configure stdin -foreground blue
+ $con tag configure prompt -foreground \#8F4433
+ $con tag configure proc -foreground \#008800
+ $con tag configure var -background \#FFC0D0
+ $con tag raise sel
+ $con tag configure blink -background \#FFFF00
+ $con tag configure find -background \#FFFF00
+
+ focus $con
+
+ # Avoid listing this console in [winfo interps]
+ if {[info command ::send] eq "::send"} {rename ::send {}}
+
+ wm protocol . WM_DELETE_WINDOW { wm withdraw . }
+ wm title . [mc "Console"]
+ flush stdout
+ $con mark set output [$con index "end - 1 char"]
+ tk::TextSetCursor $con end
+ $con mark set promptEnd insert
+ $con mark gravity promptEnd left
+
+ # A variant of ConsolePrompt to avoid a 'puts' call
+ set w $con
+ set temp [$w index "end - 1 char"]
+ $w mark set output end
+ if {![consoleinterp eval "info exists tcl_prompt1"]} {
+ set string [EvalAttached $::tk::console::defaultPrompt]
+ $w insert output $string stdout
+ }
+ $w mark set output $temp
+ ::tk::TextSetCursor $w end
+ $w mark set promptEnd insert
+ $w mark gravity promptEnd left
+
+ if {[tk windowingsystem] ne "aqua"} {
+ # Subtle work-around to erase the '% ' that tclMain.c prints out
+ after idle [subst -nocommand {
+ if {[$con get 1.0 output] eq "% "} { $con delete 1.0 output }
+ }]
+ }
+}
+
+# ::tk::ConsoleSource --
+#
+# Prompts the user for a file to source in the main interpreter.
+#
+# Arguments:
+# None.
+
+proc ::tk::ConsoleSource {} {
+ set filename [tk_getOpenFile -defaultextension .tcl -parent . \
+ -title [mc "Select a file to source"] \
+ -filetypes [list \
+ [list [mc "Tcl Scripts"] .tcl] \
+ [list [mc "All Files"] *]]]
+ if {$filename ne ""} {
+ set cmd [list source -encoding utf-8 $filename]
+ if {[catch {consoleinterp eval $cmd} result]} {
+ ConsoleOutput stderr "$result\n"
+ }
+ }
+}
+
+# ::tk::ConsoleInvoke --
+# 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 ::tk::ConsoleInvoke {args} {
+ set ranges [.console tag ranges input]
+ set cmd ""
+ if {[llength $ranges]} {
+ set pos 0
+ while {[lindex $ranges $pos] ne ""} {
+ set start [lindex $ranges $pos]
+ set end [lindex $ranges [incr pos]]
+ append cmd [.console get $start $end]
+ incr pos
+ }
+ }
+ if {$cmd eq ""} {
+ ConsolePrompt
+ } elseif {[info complete $cmd]} {
+ .console mark set output end
+ .console tag delete input
+ set result [consoleinterp record $cmd]
+ if {$result ne ""} {
+ puts $result
+ }
+ ConsoleHistory reset
+ ConsolePrompt
+ } else {
+ ConsolePrompt partial
+ }
+ .console yview -pickplace insert
+}
+
+# ::tk::ConsoleHistory --
+# 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 variable
+# ::tk::HistNum is used to store the current location in the history.
+#
+# Arguments:
+# cmd - Which action to take: prev, next, reset.
+
+set ::tk::HistNum 1
+proc ::tk::ConsoleHistory {cmd} {
+ variable 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}
+ .console see end
+ }
+ 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 ne ""} {
+ catch {consoleinterp eval $cmd} cmd
+ }
+ .console delete promptEnd end
+ .console insert promptEnd $cmd {input stdin}
+ .console see end
+ }
+ reset {
+ set HistNum 1
+ }
+ }
+}
+
+# ::tk::ConsolePrompt --
+# 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 ::tk::ConsolePrompt {{partial normal}} {
+ set w .console
+ if {$partial eq "normal"} {
+ set temp [$w index "end - 1 char"]
+ $w mark set output end
+ if {[consoleinterp eval "info exists tcl_prompt1"]} {
+ consoleinterp eval "eval \[set tcl_prompt1\]"
+ } else {
+ puts -nonewline [EvalAttached $::tk::console::defaultPrompt]
+ }
+ } else {
+ set temp [$w index output]
+ $w mark set output end
+ if {[consoleinterp eval "info exists tcl_prompt2"]} {
+ consoleinterp eval "eval \[set tcl_prompt2\]"
+ } else {
+ puts -nonewline "> "
+ }
+ }
+ flush stdout
+ $w mark set output $temp
+ ::tk::TextSetCursor $w end
+ $w mark set promptEnd insert
+ $w mark gravity promptEnd left
+ ::tk::console::ConstrainBuffer $w $::tk::console::maxLines
+ $w see end
+}
+
+# Copy selected text from the console
+proc ::tk::console::Copy {w} {
+ if {![catch {set data [$w get sel.first sel.last]}]} {
+ clipboard clear -displayof $w
+ clipboard append -displayof $w $data
+ }
+}
+# Copies selected text. If the selection is within the current active edit
+# region then it will be cut, if not it is only copied.
+proc ::tk::console::Cut {w} {
+ if {![catch {set data [$w get sel.first sel.last]}]} {
+ clipboard clear -displayof $w
+ clipboard append -displayof $w $data
+ if {[$w compare sel.first >= output]} {
+ $w delete sel.first sel.last
+ }
+ }
+}
+# Paste text from the clipboard
+proc ::tk::console::Paste {w} {
+ catch {
+ set clip [::tk::GetSelection $w CLIPBOARD]
+ set list [split $clip \n\r]
+ tk::ConsoleInsert $w [lindex $list 0]
+ foreach x [lrange $list 1 end] {
+ $w mark set insert {end - 1c}
+ tk::ConsoleInsert $w "\n"
+ tk::ConsoleInvoke
+ tk::ConsoleInsert $w $x
+ }
+ }
+}
+
+# Fit TkConsoleFont to window width
+proc ::tk::console::FitScreenWidth {w} {
+ set width [winfo screenwidth $w]
+ set cwidth [$w cget -width]
+ set s -50
+ set fit 0
+ array set fi [font configure TkConsoleFont]
+ while {$s < 0} {
+ set fi(-size) $s
+ set f [font create {*}[array get fi]]
+ set c [font measure $f "eM"]
+ font delete $f
+ if {$c * $cwidth < 1.667 * $width} {
+ font configure TkConsoleFont -size $s
+ break
+ }
+ incr s 2
+ }
+}
+
+# ::tk::ConsoleBind --
+# 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 ::tk::ConsoleBind {w} {
+ bindtags $w [list $w Console PostConsole [winfo toplevel $w] all]
+
+ ## Get all Text bindings into Console
+ foreach ev [bind Text] {
+ bind Console $ev [bind Text $ev]
+ }
+ ## We really didn't want the newline insertion...
+ bind Console <Control-o> {}
+ ## ...or any Control-v binding (would block <<Paste>>)
+ bind Console <Control-v> {}
+
+ # For the moment, transpose isn't enabled until the console
+ # gets and overhaul of how it handles input -- hobbs
+ bind Console <Control-t> {}
+
+ # Ignore all Alt, Meta, Control, Command, and Fn keypresses unless explicitly bound.
+ # Otherwise, if a widget binding for one of these is defined, the
+ # <Keypress> class binding will also fire and insert the character
+ # which is wrong.
+
+ bind Console <Alt-Key> {# nothing }
+ bind Console <Meta-Key> {# nothing}
+ bind Console <Control-Key> {# nothing}
+ bind Console <Command-Key> {# nothing}
+ bind Console <Fn-Key> {# nothing}
+
+ foreach {ev key} {
+ <<Console_NextImmediate>> <Control-n>
+ <<Console_PrevImmediate>> <Control-p>
+ <<Console_PrevSearch>> <Control-r>
+ <<Console_NextSearch>> <Control-s>
+
+ <<Console_Expand>> <Tab>
+ <<Console_Expand>> <Escape>
+ <<Console_ExpandFile>> <Control-Shift-F>
+ <<Console_ExpandProc>> <Control-Shift-P>
+ <<Console_ExpandVar>> <Control-Shift-V>
+ <<Console_Tab>> <Control-i>
+ <<Console_Tab>> <Meta-i>
+ <<Console_Eval>> <Return>
+ <<Console_Eval>> <KP_Enter>
+
+ <<Console_Clear>> <Control-l>
+ <<Console_KillLine>> <Control-k>
+ <<Console_Transpose>> <Control-t>
+ <<Console_ClearLine>> <Control-u>
+ <<Console_SaveCommand>> <Control-z>
+ <<Console_FontSizeIncr>> <Control-+>
+ <<Console_FontSizeDecr>> <Control-minus>
+ <<Console_FontSizeIncr>> <Command-+>
+ <<Console_FontSizeDecr>> <Command-minus>
+ } {
+ event add $ev $key
+ bind Console $key {}
+ }
+ if {$::tk::console::useFontchooser} {
+ bind Console <Command-t> [list ::tk::console::FontchooserToggle]
+ }
+ bind Console <<Console_Expand>> {
+ if {[%W compare insert > promptEnd]} {
+ ::tk::console::Expand %W
+ }
+ }
+ bind Console <<Console_ExpandFile>> {
+ if {[%W compare insert > promptEnd]} {
+ ::tk::console::Expand %W path
+ }
+ }
+ bind Console <<Console_ExpandProc>> {
+ if {[%W compare insert > promptEnd]} {
+ ::tk::console::Expand %W proc
+ }
+ }
+ bind Console <<Console_ExpandVar>> {
+ if {[%W compare insert > promptEnd]} {
+ ::tk::console::Expand %W var
+ }
+ }
+ bind Console <<Console_Eval>> {
+ %W mark set insert {end - 1c}
+ tk::ConsoleInsert %W "\n"
+ tk::ConsoleInvoke
+ break
+ }
+ bind Console <Delete> {
+ if {{} ne [%W tag nextrange sel 1.0 end] \
+ && [%W compare sel.first >= promptEnd]} {
+ %W delete sel.first sel.last
+ } elseif {[%W compare insert >= promptEnd]} {
+ %W delete insert
+ %W see insert
+ }
+ }
+ bind Console <BackSpace> {
+ if {{} ne [%W tag nextrange sel 1.0 end] \
+ && [%W compare sel.first >= promptEnd]} {
+ %W delete sel.first sel.last
+ } elseif {[%W compare insert != 1.0] && \
+ [%W compare insert > promptEnd]} {
+ %W delete insert-1c
+ %W see insert
+ }
+ }
+ bind Console <Control-h> [bind Console <BackSpace>]
+
+ bind Console <<LineStart>> {
+ if {[%W compare insert < promptEnd]} {
+ tk::TextSetCursor %W {insert linestart}
+ } else {
+ tk::TextSetCursor %W promptEnd
+ }
+ }
+ bind Console <<LineEnd>> {
+ tk::TextSetCursor %W {insert lineend}
+ }
+ bind Console <Control-d> {
+ if {[%W compare insert < promptEnd]} {
+ break
+ }
+ %W delete insert
+ }
+ bind Console <<Console_KillLine>> {
+ if {[%W compare insert < promptEnd]} {
+ break
+ }
+ if {[%W compare insert == {insert lineend}]} {
+ %W delete insert
+ } else {
+ %W delete insert {insert lineend}
+ }
+ }
+ bind Console <<Console_Clear>> {
+ ## Clear console display
+ %W delete 1.0 "promptEnd linestart"
+ }
+ bind Console <<Console_ClearLine>> {
+ ## Clear command line (Unix shell staple)
+ %W delete promptEnd end
+ }
+ bind Console <Meta-d> {
+ if {[%W compare insert >= promptEnd]} {
+ %W delete insert {insert wordend}
+ }
+ }
+ bind Console <Meta-BackSpace> {
+ if {[%W compare {insert -1c wordstart} >= promptEnd]} {
+ %W delete {insert -1c wordstart} insert
+ }
+ }
+ bind Console <Meta-d> {
+ if {[%W compare insert >= promptEnd]} {
+ %W delete insert {insert wordend}
+ }
+ }
+ bind Console <Meta-BackSpace> {
+ if {[%W compare {insert -1c wordstart} >= promptEnd]} {
+ %W delete {insert -1c wordstart} insert
+ }
+ }
+ bind Console <Meta-Delete> {
+ if {[%W compare insert >= promptEnd]} {
+ %W delete insert {insert wordend}
+ }
+ }
+ bind Console <<PrevLine>> {
+ tk::ConsoleHistory prev
+ }
+ bind Console <<NextLine>> {
+ tk::ConsoleHistory next
+ }
+ bind Console <Insert> {
+ catch {tk::ConsoleInsert %W [::tk::GetSelection %W PRIMARY]}
+ }
+ bind Console <Key> {
+ tk::ConsoleInsert %W %A
+ }
+ bind Console <F9> {
+ destroy {*}[winfo children .]
+ source -encoding utf-8 [file join $tk_library console.tcl]
+ }
+ bind Console <Command-q> {
+ exit
+ }
+ bind Console <<Cut>> { ::tk::console::Cut %W }
+ bind Console <<Copy>> { ::tk::console::Copy %W }
+ bind Console <<Paste>> { ::tk::console::Paste %W }
+
+ bind Console <<Console_FontSizeIncr>> {
+ set size [font configure TkConsoleFont -size]
+ if {$size < 0} {set sign -1} else {set sign 1}
+ set size [expr {(abs($size) + 1) * $sign}]
+ font configure TkConsoleFont -size $size
+ if {$::tk::console::useFontchooser} {
+ tk fontchooser configure -font TkConsoleFont
+ }
+ }
+ bind Console <<Console_FontSizeDecr>> {
+ set size [font configure TkConsoleFont -size]
+ if {abs($size) < 2} { return }
+ if {$size < 0} {set sign -1} else {set sign 1}
+ set size [expr {(abs($size) - 1) * $sign}]
+ font configure TkConsoleFont -size $size
+ if {$::tk::console::useFontchooser} {
+ tk fontchooser configure -font TkConsoleFont
+ }
+ }
+ bind Console <<Console_FitScreenWidth>> {
+ ::tk::console::FitScreenWidth %W
+ }
+
+ ##
+ ## Bindings for doing special things based on certain keys
+ ##
+ bind PostConsole <)> {
+ if {"\\" ne [%W get insert-2c]} {
+ ::tk::console::MatchPair %W \( \) promptEnd
+ }
+ }
+ bind PostConsole <bracketright> {
+ if {"\\" ne [%W get insert-2c]} {
+ ::tk::console::MatchPair %W \[ \] promptEnd
+ }
+ }
+ bind PostConsole <braceright> {
+ if {"\\" ne [%W get insert-2c]} {
+ ::tk::console::MatchPair %W \{ \} promptEnd
+ }
+ }
+ bind PostConsole <quotedbl> {
+ if {"\\" ne [%W get insert-2c]} {
+ ::tk::console::MatchQuote %W promptEnd
+ }
+ }
+
+ bind PostConsole <Key> {
+ if {"%A" ne ""} {
+ ::tk::console::TagProc %W
+ }
+ }
+}
+
+# ::tk::ConsoleInsert --
+# 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 ::tk::ConsoleInsert {w s} {
+ if {$s eq ""} {
+ 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
+}
+
+# ::tk::ConsoleOutput --
+#
+# 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 ::tk::ConsoleOutput {dest string} {
+ set w .console
+ $w insert output $string $dest
+ ::tk::console::ConstrainBuffer $w $::tk::console::maxLines
+ $w see insert
+}
+
+# ::tk::ConsoleExit --
+#
+# 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 ::tk::ConsoleExit {} {
+ destroy .
+}
+
+# ::tk::ConsoleAbout --
+#
+# This routine displays an About box to show Tcl/Tk version info.
+#
+# Arguments:
+# None.
+
+proc ::tk::ConsoleAbout {} {
+ tk_messageBox -type ok -message "[mc {Tcl for Windows}]
+
+Tcl $::tcl_patchLevel
+Tk $::tk_patchLevel"
+}
+
+# ::tk::console::Fontchooser* --
+# Let the user select the console font (TIP 324).
+
+proc ::tk::console::FontchooserToggle {} {
+ if {[tk fontchooser configure -visible]} {
+ tk fontchooser hide
+ } else {
+ tk fontchooser show
+ }
+}
+proc ::tk::console::FontchooserVisibility {index} {
+ if {[tk fontchooser configure -visible]} {
+ .menubar.edit entryconfigure $index -label [::tk::msgcat::mc "Hide Fonts"]
+ } else {
+ .menubar.edit entryconfigure $index -label [::tk::msgcat::mc "Show Fonts"]
+ }
+}
+proc ::tk::console::FontchooserFocus {w isFocusIn} {
+ if {$isFocusIn} {
+ tk fontchooser configure -parent $w -font TkConsoleFont \
+ -command [namespace code [list FontchooserApply]]
+ } else {
+ tk fontchooser configure -parent $w -font {} -command {}
+ }
+}
+proc ::tk::console::FontchooserApply {font args} {
+ catch {font configure TkConsoleFont {*}[font actual $font]}
+}
+
+# ::tk::console::TagProc --
+#
+# Tags a procedure in the console if it's recognized
+# This procedure is not perfect. However, making it perfect wastes
+# too much CPU time...
+#
+# Arguments:
+# w - console text widget
+
+proc ::tk::console::TagProc w {
+ if {!$::tk::console::magicKeys} {
+ return
+ }
+ set exp "\[^\\\\\]\[\[ \t\n\r\;{}\"\$\]"
+ set i [$w search -backwards -regexp $exp insert-1c promptEnd-1c]
+ if {$i eq ""} {
+ set i promptEnd
+ } else {
+ append i +2c
+ }
+ regsub -all "\[\[\\\\\\?\\*\]" [$w get $i "insert-1c wordend"] {\\\0} c
+ if {[llength [EvalAttached [list info commands $c]]]} {
+ $w tag add proc $i "insert-1c wordend"
+ } else {
+ $w tag remove proc $i "insert-1c wordend"
+ }
+ if {[llength [EvalAttached [list info vars $c]]]} {
+ $w tag add var $i "insert-1c wordend"
+ } else {
+ $w tag remove var $i "insert-1c wordend"
+ }
+}
+
+# ::tk::console::MatchPair --
+#
+# Blinks a matching pair of characters
+# c2 is assumed to be at the text index 'insert'.
+# This proc is really loopy and took me an hour to figure out given
+# all possible combinations with escaping except for escaped \'s.
+# It doesn't take into account possible commenting... Oh well. If
+# anyone has something better, I'd like to see/use it. This is really
+# only efficient for small contexts.
+#
+# Arguments:
+# w - console text widget
+# c1 - first char of pair
+# c2 - second char of pair
+#
+# Calls: ::tk::console::Blink
+
+proc ::tk::console::MatchPair {w c1 c2 {lim 1.0}} {
+ if {!$::tk::console::magicKeys} {
+ return
+ }
+ if {{} ne [set ix [$w search -back $c1 insert $lim]]} {
+ while {
+ [string match {\\} [$w get $ix-1c]] &&
+ [set ix [$w search -back $c1 $ix-1c $lim]] ne {}
+ } {}
+ set i1 insert-1c
+ while {$ix ne {}} {
+ set i0 $ix
+ set j 0
+ while {[set i0 [$w search $c2 $i0 $i1]] ne {}} {
+ append i0 +1c
+ if {[string match {\\} [$w get $i0-2c]]} {
+ continue
+ }
+ incr j
+ }
+ if {!$j} {
+ break
+ }
+ set i1 $ix
+ while {$j && [set ix [$w search -back $c1 $ix $lim]] ne {}} {
+ if {[string match {\\} [$w get $ix-1c]]} {
+ continue
+ }
+ incr j -1
+ }
+ }
+ if {[string match {} $ix]} {
+ set ix [$w index $lim]
+ }
+ } else {
+ set ix [$w index $lim]
+ }
+ if {$::tk::console::blinkRange} {
+ Blink $w $ix [$w index insert]
+ } else {
+ Blink $w $ix $ix+1c [$w index insert-1c] [$w index insert]
+ }
+}
+
+# ::tk::console::MatchQuote --
+#
+# Blinks between matching quotes.
+# Blinks just the quote if it's unmatched, otherwise blinks quoted string
+# The quote to match is assumed to be at the text index 'insert'.
+#
+# Arguments:
+# w - console text widget
+#
+# Calls: ::tk::console::Blink
+
+proc ::tk::console::MatchQuote {w {lim 1.0}} {
+ if {!$::tk::console::magicKeys} {
+ return
+ }
+ set i insert-1c
+ set j 0
+ while {[set i [$w search -back \" $i $lim]] ne {}} {
+ if {[string match {\\} [$w get $i-1c]]} {
+ continue
+ }
+ if {!$j} {
+ set i0 $i
+ }
+ incr j
+ }
+ if {$j&1} {
+ if {$::tk::console::blinkRange} {
+ Blink $w $i0 [$w index insert]
+ } else {
+ Blink $w $i0 $i0+1c [$w index insert-1c] [$w index insert]
+ }
+ } else {
+ Blink $w [$w index insert-1c] [$w index insert]
+ }
+}
+
+# ::tk::console::Blink --
+#
+# Blinks between n index pairs for a specified duration.
+#
+# Arguments:
+# w - console text widget
+# i1 - start index to blink region
+# i2 - end index of blink region
+# dur - duration in usecs to blink for
+#
+# Outputs:
+# blinks selected characters in $w
+
+proc ::tk::console::Blink {w args} {
+ eval [list $w tag add blink] $args
+ after $::tk::console::blinkTime [list $w] tag remove blink $args
+}
+
+# ::tk::console::ConstrainBuffer --
+#
+# This limits the amount of data in the text widget
+# Called by Prompt and ConsoleOutput
+#
+# Arguments:
+# w - console text widget
+# size - # of lines to constrain to
+#
+# Outputs:
+# may delete data in console widget
+
+proc ::tk::console::ConstrainBuffer {w size} {
+ if {[$w index end] > $size} {
+ $w delete 1.0 [expr {int([$w index end])-$size}].0
+ }
+}
+
+# ::tk::console::Expand --
+#
+# Arguments:
+# ARGS: w - text widget in which to expand str
+# type - type of expansion (path / proc / variable)
+#
+# Calls: ::tk::console::Expand(Pathname|Procname|Variable)
+#
+# Outputs: The string to match is expanded to the longest possible match.
+# If ::tk::console::showMatches is non-zero and the longest match
+# equaled the string to expand, then all possible matches are
+# output to stdout. Triggers bell if no matches are found.
+#
+# Returns: number of matches found
+
+proc ::tk::console::Expand {w {type ""}} {
+ set exp "\[^\\\\\]\[\[ \t\n\r\\\{\"\\\\\$\]"
+ set tmp [$w search -backwards -regexp $exp insert-1c promptEnd-1c]
+ if {$tmp eq ""} {
+ set tmp promptEnd
+ } else {
+ append tmp +2c
+ }
+ if {[$w compare $tmp >= insert]} {
+ return
+ }
+ set str [$w get $tmp insert]
+ switch -glob $type {
+ path* {
+ set res [ExpandPathname $str]
+ }
+ proc* {
+ set res [ExpandProcname $str]
+ }
+ var* {
+ set res [ExpandVariable $str]
+ }
+ default {
+ set res {}
+ foreach t {Pathname Procname Variable} {
+ if {![catch {Expand$t $str} res] && ($res ne "")} {
+ break
+ }
+ }
+ }
+ }
+ set len [llength $res]
+ if {$len} {
+ set repl [lindex $res 0]
+ $w delete $tmp insert
+ $w insert $tmp $repl {input stdin}
+ if {($len > 1) && ($::tk::console::showMatches) && ($repl eq $str)} {
+ puts stdout [lsort [lreplace $res 0 0]]
+ }
+ } else {
+ bell
+ }
+ return [incr len -1]
+}
+
+# ::tk::console::ExpandPathname --
+#
+# Expand a file pathname based on $str
+# This is based on UNIX file name conventions
+#
+# Arguments:
+# str - partial file pathname to expand
+#
+# Calls: ::tk::console::ExpandBestMatch
+#
+# Returns: list containing longest unique match followed by all the
+# possible further matches
+
+proc ::tk::console::ExpandPathname str {
+ set pwd [EvalAttached pwd]
+ if {[catch {EvalAttached [list cd [file dirname $str]]} err opt]} {
+ return -options $opt $err
+ }
+ set dir [file tail $str]
+ ## Check to see if it was known to be a directory and keep the trailing
+ ## slash if so (file tail cuts it off)
+ if {[string match */ $str]} {
+ append dir /
+ }
+ if {[catch {lsort [EvalAttached [list glob $dir*]]} m]} {
+ set match {}
+ } else {
+ if {[llength $m] > 1} {
+ if { $::tcl_platform(platform) eq "windows" } {
+ ## Windows is screwy because it's case insensitive
+ set tmp [ExpandBestMatch [string tolower $m] \
+ [string tolower $dir]]
+ ## Don't change case if we haven't changed the word
+ if {[string length $dir]==[string length $tmp]} {
+ set tmp $dir
+ }
+ } else {
+ set tmp [ExpandBestMatch $m $dir]
+ }
+ if {[string match ?*/* $str]} {
+ set tmp [file dirname $str]/$tmp
+ } elseif {[string match /* $str]} {
+ set tmp /$tmp
+ }
+ regsub -all { } $tmp {\\ } tmp
+ set match [linsert $m 0 $tmp]
+ } else {
+ ## This may look goofy, but it handles spaces in path names
+ eval append match $m
+ if {[file isdir $match]} {
+ append match /
+ }
+ if {[string match ?*/* $str]} {
+ set match [file dirname $str]/$match
+ } elseif {[string match /* $str]} {
+ set match /$match
+ }
+ regsub -all { } $match {\\ } match
+ ## Why is this one needed and the ones below aren't!!
+ set match [list $match]
+ }
+ }
+ EvalAttached [list cd $pwd]
+ return $match
+}
+
+# ::tk::console::ExpandProcname --
+#
+# Expand a tcl proc name based on $str
+#
+# Arguments:
+# str - partial proc name to expand
+#
+# Calls: ::tk::console::ExpandBestMatch
+#
+# Returns: list containing longest unique match followed by all the
+# possible further matches
+
+proc ::tk::console::ExpandProcname str {
+ set match [EvalAttached [list info commands $str*]]
+ if {[llength $match] == 0} {
+ set ns [EvalAttached \
+ "namespace children \[namespace current\] [list $str*]"]
+ if {[llength $ns]==1} {
+ set match [EvalAttached [list info commands ${ns}::*]]
+ } else {
+ set match $ns
+ }
+ }
+ if {[llength $match] > 1} {
+ regsub -all { } [ExpandBestMatch $match $str] {\\ } str
+ set match [linsert $match 0 $str]
+ } else {
+ regsub -all { } $match {\\ } match
+ }
+ return $match
+}
+
+# ::tk::console::ExpandVariable --
+#
+# Expand a tcl variable name based on $str
+#
+# Arguments:
+# str - partial tcl var name to expand
+#
+# Calls: ::tk::console::ExpandBestMatch
+#
+# Returns: list containing longest unique match followed by all the
+# possible further matches
+
+proc ::tk::console::ExpandVariable str {
+ if {[regexp {([^\(]*)\((.*)} $str -> ary str]} {
+ ## Looks like they're trying to expand an array.
+ set match [EvalAttached [list array names $ary $str*]]
+ if {[llength $match] > 1} {
+ set vars $ary\([ExpandBestMatch $match $str]
+ foreach var $match {
+ lappend vars $ary\($var\)
+ }
+ return $vars
+ } elseif {[llength $match] == 1} {
+ set match $ary\($match\)
+ }
+ ## Space transformation avoided for array names.
+ } else {
+ set match [EvalAttached [list info vars $str*]]
+ if {[llength $match] > 1} {
+ regsub -all { } [ExpandBestMatch $match $str] {\\ } str
+ set match [linsert $match 0 $str]
+ } else {
+ regsub -all { } $match {\\ } match
+ }
+ }
+ return $match
+}
+
+# ::tk::console::ExpandBestMatch --
+#
+# Finds the best unique match in a list of names.
+# The extra $e in this argument allows us to limit the innermost loop a little
+# further. This improves speed as $l becomes large or $e becomes long.
+#
+# Arguments:
+# l - list to find best unique match in
+# e - currently best known unique match
+#
+# Returns: longest unique match in the list
+
+proc ::tk::console::ExpandBestMatch {l {e {}}} {
+ set ec [lindex $l 0]
+ if {[llength $l]>1} {
+ set e [expr {[string length $e] - 1}]
+ set ei [expr {[string length $ec] - 1}]
+ foreach l $l {
+ while {$ei>=$e && [string first $ec $l]} {
+ set ec [string range $ec 0 [incr ei -1]]
+ }
+ }
+ }
+ return $ec
+}
+
+# now initialize the console
+::tk::ConsoleInit
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/console.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/README
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/README (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/README 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,44 @@
+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 on your path
+then you can invoke any of the programs in this directory just
+by typing its file name to your command shell under Unix. 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.
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/README
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/anilabel.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/anilabel.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/anilabel.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,168 @@
+# anilabel.tcl --
+#
+# This demonstration script creates a toplevel window containing
+# several animated label widgets.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+set w .anilabel
+catch {destroy $w}
+toplevel $w
+wm title $w "Animated Label Demonstration"
+wm iconname $w "anilabel"
+positionWindow $w
+
+label $w.msg -font $font -wraplength 4i -justify left -text "Four animated labels are displayed below; each of the labels on the left is animated by making the text message inside it appear to scroll, and the label on the right is animated by animating the image that it displays."
+pack $w.msg -side top
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+# Ensure that this this is an array
+array set animationCallbacks {}
+
+## This callback is the core of how to do animation in Tcl/Tk; all
+## animations work in basically the same way, with a procedure that
+## uses the [after] command to reschedule itself at some point in the
+## future. Of course, the details of how to update the state will vary
+## according to what is being animated.
+proc RotateLabelText {w interval} {
+ global animationCallbacks
+
+ # Schedule the calling of this procedure again in the future
+ set animationCallbacks($w) [after $interval RotateLabelText $w $interval]
+
+ # We do marquee-like scrolling text by chopping characters off the
+ # front of the text and sticking them on the end.
+ set text [$w cget -text]
+ set newText [string range $text 1 end][string index $text 0]
+ $w configure -text $newText
+}
+
+## A helper procedure to start the animation happening.
+proc animateLabelText {w text interval} {
+ global animationCallbacks
+
+ # Install the text into the widget
+ $w configure -text $text
+
+ # Schedule the start of the animation loop
+ set animationCallbacks($w) [after $interval RotateLabelText $w $interval]
+
+ # Make sure that the animation stops and is cleaned up after itself
+ # when the animated label is destroyed. Note that at this point we
+ # cannot manipulate the widget itself, as that has already died.
+ bind $w <Destroy> {
+ after cancel $animationCallbacks(%W)
+ unset animationCallbacks(%W)
+ }
+}
+
+## Next, a similar pair of procedures to animate a GIF loaded into a
+## photo image.
+proc SelectNextImageFrame {w interval} {
+ global animationCallbacks image zoomFactor
+ set animationCallbacks($w) \
+ [after $interval SelectNextImageFrame $w $interval]
+ set image2 [$w cget -image]
+
+ # The easy way to animate a GIF!
+ set idx -1
+ scan [$image cget -format] "GIF -index %d" idx
+ if {[catch {
+ # Note that we get an error if the index is out of range
+ $image configure -format "GIF -index [incr idx]"
+ }]} then {
+ $image configure -format "GIF -index 0"
+ }
+ $image2 copy $image -zoom $zoomFactor
+}
+proc animateLabelImage {w imageData interval} {
+ global animationCallbacks image zoomFactor
+
+ # Create a multi-frame GIF from base-64-encoded data
+ set image [image create photo -format GIF -data $imageData]
+
+ # Create a copy of the image just created, magnified according to the
+ # display's DPI scaling level. Since the zooom factor must be an integer,
+ # the copy will only be effectively magnified if $tk::scalingPct >= 200.
+ set image2 [image create photo]
+ set zoomFactor [expr {$tk::scalingPct / 100}]
+ $image2 copy $image -zoom $zoomFactor
+
+ # Install the image copy into the widget
+ $w configure -image $image2
+
+ # Schedule the start of the animation loop
+ set animationCallbacks($w) \
+ [after $interval SelectNextImageFrame $w $interval]
+
+ # Make sure that the animation stops and is cleaned up after itself
+ # when the animated label is destroyed. Note that at this point we
+ # cannot manipulate the widget itself, as that has already died.
+ # Also note that this script is in double-quotes; this is always OK
+ # because image names are chosen automatically to be simple words.
+ bind $w <Destroy> "
+ after cancel \$animationCallbacks(%W)
+ unset animationCallbacks(%W)
+ rename $image {}
+ "
+}
+
+# Make some widgets to contain the animations
+labelframe $w.left -text "Scrolling Texts"
+labelframe $w.right -text "GIF Image"
+pack $w.left $w.right -side left -padx 7.5p -pady 7.5p -expand yes
+
+# This method of scrolling text looks far better with a fixed-width font
+label $w.left.l1 -bd 3p -relief ridge -font fixedFont
+label $w.left.l2 -bd 3p -relief groove -font fixedFont
+label $w.left.l3 -bd 3p -relief flat -font fixedFont -width 18
+pack $w.left.l1 $w.left.l2 $w.left.l3 -side top -expand yes -padx 7.5p -pady 7.5p -anchor w
+# Don't need to do very much with this label except turn off the border
+label $w.right.l -bd 0
+pack $w.right.l -side top -expand yes -padx 7.5p -pady 7.5p
+
+# This is a base-64-encoded animated GIF file.
+set tclPoweredData {
+ R0lGODlhKgBAAPQAAP//////zP//AP/MzP/Mmf/MAP+Zmf+ZZv+ZAMz//8zM
+ zMyZmcyZZsxmZsxmAMwzAJnMzJmZzJmZmZlmmZlmZplmM5kzM2aZzGZmzGZm
+ mWZmZmYzZmYzMzNmzDMzZgAzmSH+IE1hZGUgd2l0aCBHSU1QIGJ5IExARGVt
+ YWlsbHkuY29tACH5BAVkAAEALAAAAAAqAEAAAAX+YCCOZEkyTKM2jOm66yPP
+ dF03bx7YcuHIDkGBR7SZeIyhTID4FZ+4Es8nQyCe2EeUNJ0peY2s9mi7PhAM
+ ngEAMGRbUpvzSxskLh1J+Hkg134OdDIDEB+GHxtYMEQMTjMGEYeGFoomezaC
+ DZGSHFmLXTQKkh8eNQVpZ2afmDQGHaOYSoEyhhcklzVmMpuHnaZmDqiGJbg0
+ qFqvh6UNAwB7VA+OwydEjgujkgrPNhbTI8dFvNgEYcHcHx0lB1kX2IYeA2G6
+ NN0YfkXJ2BsAMuAzHB9cZMk3qoEbRzUACsRCUBK5JxsC3iMiKd8GN088SIyT
+ 0RAFSROyeEg38caDiB/+JEgqxsODrZJ1BkT0oHKSmI0ceQxo94HDpg0qsuDk
+ UmRAMgu8OgwQ+uIJgUMVeGXA+IQkzEeHGvD8cIGlDXsLiRjQ+EHroQhea7xY
+ 8IQBSgYYDi1IS+OFBCgaDMGVS3fGi5BPJpBaENdQ0EomKGD56IHwO39EXiSC
+ Ysgxor5+Xfgq0qByYUpiXmwuoredB2aYH4gWWda0B7SeNENpEJHC1ghi+pS4
+ AJpIAwWvKPBi+8YEht5EriEqpFfMlhEdkBNpx0HUhwypx5T4IB1MBg/Ws2sn
+ wV3MSQOkzI8fUd48Aw3dOZto71x85hHtHijYv18Gf/3GqCdDCXHNoICBobSo
+ IqBqJLyCoH8JPrLgdh88CKCFD0CGmAiGYPgffwceZh6FC2ohIIklnkhehTNY
+ 4CIHHGzgwYw01ujBBhvAqKOLLq5AAk9kuSPkkKO40NB+h1gnypJIIvkBf09a
+ N5QIRz5p5ZJXJpmlIVhOGQA2TmIJZZhKKmmll2BqyWSXWUrZpQtpatlmk1c2
+ KaWRHeTZEJF8SqLDn/hhsOeQgBbqAh6DGqronxeARUIIACH5BAUeAAAALAUA
+ LgAFAAUAAAUM4CeKz/OV5YmqaRkCACH5BAUeAAEALAUALgAKAAUAAAUUICCK
+ z/OdJVCaa7p+7aOWcDvTZwgAIfkEBR4AAQAsCwAuAAkABQAABRPgA4zP95zA
+ eZqoWqqpyqLkZ38hACH5BAUKAAEALAcALgANAA4AAAU7ICA+jwiUJEqeKau+
+ r+vGaTmac63v/GP9HM7GQyx+jsgkkoRUHJ3Qx0cK/VQVTKtWwbVKn9suNunc
+ WkMAIfkEBQoAAAAsBwA3AAcABQAABRGgIHzk842j+Yjlt5KuO8JmCAAh+QQF
+ CgAAACwLADcABwAFAAAFEeAnfN9TjqP5oOWziq05lmUIACH5BAUKAAAALA8A
+ NwAHAAUAAAUPoPCJTymS3yiQj4qOcPmEACH5BAUKAAAALBMANwAHAAUAAAUR
+ oCB+z/MJX2o+I2miKimiawgAIfkEBQoAAAAsFwA3AAcABQAABRGgIHzfY47j
+ Q4qk+aHl+pZmCAAh+QQFCgAAACwbADcABwAFAAAFEaAgfs/zCV9qPiNJouo7
+ ll8IACH5BAUKAAAALB8ANwADAAUAAAUIoCB8o0iWZggAOw==
+}
+
+# Finally, set up the text scrolling animation
+animateLabelText $w.left.l1 "* Slow Animation *" 300
+animateLabelText $w.left.l2 "* Fast Animation *" 80
+animateLabelText $w.left.l3 "This is a longer scrolling text in a widget that will not show the whole message at once. " 150
+animateLabelImage $w.right.l $tclPoweredData 100
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/anilabel.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/aniwave.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/aniwave.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/aniwave.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,107 @@
+# aniwave.tcl --
+#
+# This demonstration script illustrates how to adjust canvas item
+# coordinates in a way that does something fairly similar to waveform
+# display.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+set w .aniwave
+catch {destroy $w}
+toplevel $w
+wm title $w "Animated Wave Demonstration"
+wm iconname $w "aniwave"
+positionWindow $w
+
+label $w.msg -font $font -wraplength 4i -justify left -text "This demonstration contains a canvas widget with a line item inside it. The animation routines work by adjusting the coordinates list of the line; a trace on a variable is used so updates to the variable result in a change of position of the line."
+pack $w.msg -side top
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+# Create a canvas large enough to hold the wave. In fact, the wave
+# sticks off both sides of the canvas to prevent visual glitches.
+pack [canvas $w.c -width 225p -height 150p -background black] -padx 7.5p -pady 7.5p -expand yes
+
+# Ensure that this this is an array
+array set animationCallbacks {}
+
+# Creates a coordinates list of a wave. This code does a very sketchy
+# job and relies on Tk's line smoothing to make things look better.
+set waveCoords {}
+for {set x -10} {$x<=300} {incr x 5} {
+ lappend waveCoords $x 100
+}
+lappend waveCoords $x 0 [incr x 5] 200
+
+# Create a smoothed line and arrange for its coordinates to be the
+# contents of the variable waveCoords.
+$w.c create line $waveCoords -tags wave -width 0.75p -fill green -smooth 1
+proc waveCoordsTracer {w args} {
+ global waveCoords
+ # Actual visual update will wait until we have finished
+ # processing; Tk does that for us automatically.
+ $w.c coords wave $waveCoords
+
+ set scaleFactor [expr {$tk::scalingPct / 100.0}]
+ $w.c scale wave 0 0 $scaleFactor $scaleFactor
+}
+trace add variable waveCoords write [list waveCoordsTracer $w]
+
+# Basic motion handler. Given what direction the wave is travelling
+# in, it advances the y coordinates in the coordinate-list one step in
+# that direction.
+proc basicMotion {} {
+ global waveCoords direction
+ set oc $waveCoords
+ for {set i 1} {$i<[llength $oc]} {incr i 2} {
+ if {$direction eq "left"} {
+ lset waveCoords $i [lindex $oc \
+ [expr {$i+2>[llength $oc] ? 1 : $i+2}]]
+ } else {
+ lset waveCoords $i \
+ [lindex $oc [expr {$i-2<0 ? "end" : $i-2}]]
+ }
+ }
+}
+
+# Oscillation handler. This detects whether to reverse the direction
+# of the wave by checking to see if the peak of the wave has moved off
+# the screen (whose size we know already.)
+proc reverser {} {
+ global waveCoords direction
+ if {[lindex $waveCoords 1] < 10} {
+ set direction "right"
+ } elseif {[lindex $waveCoords end] < 10} {
+ set direction "left"
+ }
+}
+
+# Main animation "loop". This calls the two procedures that handle the
+# movement repeatedly by scheduling asynchronous calls back to itself
+# using the [after] command. This procedure is the fundamental basis
+# for all animated effect handling in Tk.
+proc move {} {
+ basicMotion
+ reverser
+
+ # Theoretically 100 frames-per-second (==10ms between frames)
+ global animationCallbacks
+ set animationCallbacks(simpleWave) [after 10 move]
+}
+
+# Initialise our remaining animation variables
+set direction "left"
+set animateAfterCallback {}
+# Arrange for the animation loop to stop when the canvas is deleted
+bind $w.c <Destroy> {
+ after cancel $animationCallbacks(simpleWave)
+ unset animationCallbacks(simpleWave)
+}
+# Start the animation processing
+move
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/aniwave.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/arrow.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/arrow.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/arrow.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,260 @@
+# arrow.tcl --
+#
+# This demonstration script creates a canvas widget that displays a
+# large line with an arrowhead whose shape can be edited interactively.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+# scl --
+# Scales an integer according to the display's current scaling percentage.
+#
+# Arguments:
+# num - An integer.
+
+proc scl num {
+ return [expr {round($num*$tk::scalingPct/100.0)}]
+}
+
+# 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
+ $c create line $v(x1) $v(y) $v(x2) $v(y) -arrow last \
+ -width [expr {10*$v(width)}] -arrowshape [list \
+ [expr {10*$v(a)}] [expr {10*$v(b)}] [expr {10*$v(c)}]] \
+ {*}$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 1.5p -capstyle round -joinstyle round
+
+ # Create the boxes for reshaping the line and arrowhead.
+
+ set _5 [scl 5]
+ $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}] \
+ -tags {box1 box} {*}$v(boxStyle)
+ $c create rect [expr {$xtip-$_5}] [expr {$v(y)-$deltaY-$_5}] \
+ [expr {$xtip+$_5}] [expr {$v(y)-$deltaY+$_5}] \
+ -tags {box2 box} {*}$v(boxStyle)
+ $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}] \
+ -tags {box3 box} {*}$v(boxStyle)
+ if {$cur != ""} {
+ $c itemconfigure $cur {*}$v(activeStyle)
+ }
+
+ # Create three arrows in actual size with the same parameters.
+
+ set _10 [scl 10]
+ set _15 [scl 15]
+ set _25 [scl 25]
+ set _50 [scl 50]
+ set _75 [scl 75]
+ set _125 [scl 125]
+ $c create line [expr {$v(x2)+$_50}] 0 [expr {$v(x2)+$_50}] 750p -width 1.5p
+ set tmp [expr {$v(x2)+[scl 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) 232.5p -text "-width $v(width)" \
+ -anchor w -font {Helvetica 18}
+ $c create text $v(x1) 247.5p -text "-arrowshape {$v(a) $v(b) $v(c)}" \
+ -anchor w -font {Helvetica 18}
+
+ incr v(count)
+}
+
+set w .arrow
+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
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+canvas $c -width 375p -height 262.5p -relief sunken -borderwidth 2
+pack $c -expand yes -fill both
+
+set demo_arrowInfo(a) [scl 8]
+set demo_arrowInfo(b) [scl 10]
+set demo_arrowInfo(c) [scl 3]
+set demo_arrowInfo(width) [scl 2]
+set demo_arrowInfo(motionProc) arrowMoveNull
+set demo_arrowInfo(x1) [scl 40]
+set demo_arrowInfo(x2) [scl 350]
+set demo_arrowInfo(y) [scl 150]
+set demo_arrowInfo(smallTips) {3.75p 3.75p 1.5p}
+set demo_arrowInfo(count) 0
+if {[winfo depth $c] > 1} {
+ if {[tk windowingsystem] eq "aqua"} {
+ set demo_arrowInfo(bigLineStyle) "-fill systemSelectedTextBackgroundColor"
+ } else {
+ set demo_arrowInfo(bigLineStyle) "-fill LightSeaGreen"
+ }
+ set demo_arrowInfo(boxStyle) "-fill {} -width 0.75p"
+ set demo_arrowInfo(activeStyle) "-fill red -width 0.75p"
+} else {
+ # Main widget program sets variable tk_demoDirectory
+ set demo_arrowInfo(bigLineStyle) "-fill black \
+ -stipple @[file join $tk_demoDirectory images grey.25]"
+ set demo_arrowInfo(boxStyle) "-fill {} -outline black -width 0.75p"
+ set demo_arrowInfo(activeStyle) "-fill black -outline black -width 0.75p"
+}
+arrowSetup $c
+$c bind box <Enter> "$c itemconfigure current $demo_arrowInfo(activeStyle)"
+$c bind box <Leave> "$c itemconfigure current $demo_arrowInfo(boxStyle)"
+$c bind box <B1-Enter> " "
+$c bind box <B1-Leave> " "
+$c bind box1 <Button-1> {set demo_arrowInfo(motionProc) arrowMove1}
+$c bind box2 <Button-1> {set demo_arrowInfo(motionProc) arrowMove2}
+$c bind box3 <Button-1> {set demo_arrowInfo(motionProc) arrowMove3}
+$c bind box <B1-Motion> "\$demo_arrowInfo(motionProc) $c %x %y"
+bind $c <ButtonRelease-1> "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)+[scl 5]-round([$c canvasx $x]))/10}]
+ if {$newA < 0} {
+ set newA 0
+ }
+ set _25 [scl 25]
+ 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 _5 [scl 5]
+ set newB [expr {($v(x2)+$_5-round([$c canvasx $x]))/10}]
+ if {$newB < 0} {
+ set newB 0
+ }
+ set _25 [scl 25]
+ 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
+ }
+ set _20 [scl 20]
+ 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)+[scl 2]-round([$c canvasy $y]))/5}]
+ if {$newWidth < 0} {
+ set newWidth 0
+ }
+ set _20 [scl 20]
+ if {$newWidth > $_20} {
+ set newWidth $_20
+ }
+ if {$newWidth != $v(width)} {
+ $c move box3 0 [expr {5*($v(width)-$newWidth)}]
+ set v(width) $newWidth
+ }
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/arrow.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/bind.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/bind.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/bind.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,78 @@
+# bind.tcl --
+#
+# This demonstration script creates a text widget with bindings set
+# up for hypertext-like effects.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+set w .bind
+catch {destroy $w}
+toplevel $w
+wm title $w "Text Demonstration - Tag Bindings"
+wm iconname $w "bind"
+positionWindow $w
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+text $w.text -yscrollcommand "$w.scroll set" -setgrid true \
+ -width 60 -height 24 -font $font -wrap word
+ttk::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 <Enter> "$w.text tag configure $tag $bold"
+ $w.text tag bind $tag <Leave> "$w.text tag configure $tag $normal"
+}
+# Main widget program sets variable tk_demoDirectory
+$w.text tag bind d1 <Button-1> {source -encoding utf-8 [file join $tk_demoDirectory items.tcl]}
+$w.text tag bind d2 <Button-1> {source -encoding utf-8 [file join $tk_demoDirectory plot.tcl]}
+$w.text tag bind d3 <Button-1> {source -encoding utf-8 [file join $tk_demoDirectory ctext.tcl]}
+$w.text tag bind d4 <Button-1> {source -encoding utf-8 [file join $tk_demoDirectory arrow.tcl]}
+$w.text tag bind d5 <Button-1> {source -encoding utf-8 [file join $tk_demoDirectory ruler.tcl]}
+$w.text tag bind d6 <Button-1> {source -encoding utf-8 [file join $tk_demoDirectory cscroll.tcl]}
+
+$w.text mark set insert 0.0
+$w.text configure -state disabled
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/bind.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/bitmap.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/bitmap.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/bitmap.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,52 @@
+# bitmap.tcl --
+#
+# This demonstration script creates a toplevel window that displays
+# all of Tk's built-in bitmaps.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+# 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
+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
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+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
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/bitmap.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/browse
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/browse (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/browse 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,66 @@
+#!/bin/sh
+# the next line restarts using wish \
+exec wish90 "$0" ${1+"$@"}
+
+# browse --
+# This script generates a directory browser, which lists the working
+# directory and allows you to open files or subdirectories by
+# double-clicking.
+
+package require tk
+
+# 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.
+
+set browseScript [file join [pwd] $argv0]
+proc browse {dir file} {
+ global env browseScript
+ if {[string compare $dir "."] != 0} {set file $dir/$file}
+ switch [file type $file] {
+ directory {
+ exec [info nameofexecutable] $browseScript $file &
+ }
+ file {
+ if {[info exists env(EDITOR)]} {
+ eval exec $env(EDITOR) $file &
+ } else {
+ exec xedit $file &
+ }
+ }
+ default {
+ puts stdout "\"$file\" isn't a directory or regular file"
+ }
+ }
+}
+
+# Fill the listbox with a list of all the files in the directory.
+
+if {$argc>0} {set dir [lindex $argv 0]} else {set dir "."}
+foreach i [lsort [glob * .* *.*]] {
+ if {[file type $i] eq "directory"} {
+ # Safe to do since it is still a directory.
+ append i /
+ }
+ .list insert end $i
+}
+
+# Set up bindings for the browser.
+
+bind all <Control-c> {destroy .}
+bind .list <Double-Button-1> {foreach i [selection get] {browse $dir $i}}
+
+# Local Variables:
+# mode: tcl
+# End:
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/browse
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/button.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/button.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/button.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,47 @@
+# button.tcl --
+#
+# This demonstration script creates a toplevel window containing
+# several button widgets.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+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
+
+## See Code / Dismiss buttons
+pack [addSeeDismiss $w.buttons $w] -side bottom -fill x
+
+proc colorrefresh {w col} {
+ $w configure -bg $col
+ if {[tk windowingsystem] eq "aqua"} {
+ # set highlightbackground of all buttons in $w
+ set l [list $w]
+ while {[llength $l]} {
+ set l [concat [lassign $l b] [winfo children $b]]
+ if {[winfo class $b] eq "Button"} {
+ $b configure -highlightbackground $col
+ }
+ }
+ }
+}
+
+button $w.b1 -text "Peach Puff" -width 10 \
+ -command [list colorrefresh $w PeachPuff1]
+button $w.b2 -text "Light Blue" -width 10 \
+ -command [list colorrefresh $w LightBlue1]
+button $w.b3 -text "Sea Green" -width 10 \
+ -command [list colorrefresh $w SeaGreen2]
+button $w.b4 -text "Yellow" -width 10 \
+ -command [list colorrefresh $w Yellow1]
+pack $w.b1 $w.b2 $w.b3 $w.b4 -side top -expand yes -pady 1.5p
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/button.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/check.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/check.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/check.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,71 @@
+# check.tcl --
+#
+# This demonstration script creates a toplevel window containing
+# several checkbuttons.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+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 "Four 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. The first button also follows the state of the other three. If only some of the three are checked, the first button will display the tri-state mode. Click the \"See Variables\" button to see the current values of the variables."
+pack $w.msg -side top
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w [list safety wipers brakes sober]]
+pack $btns -side bottom -fill x
+
+checkbutton $w.b0 -text "Safety Check" -variable safety -relief flat \
+ -onvalue "all" \
+ -offvalue "none" \
+ -tristatevalue "partial"
+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.b0 -side top -pady 1.5p -anchor w
+pack $w.b1 $w.b2 $w.b3 -side top -pady 1.5p -anchor w -padx 12p
+
+## This code makes $w.b0 function as a tri-state button; it's not
+## needed at all for just straight yes/no buttons.
+
+set in_check 0
+proc tristate_check {n1 n2 op} {
+ global safety wipers brakes sober in_check
+ if {$in_check} {
+ return
+ }
+ set in_check 1
+ if {$n1 eq "safety"} {
+ if {$safety eq "none"} {
+ set wipers 0
+ set brakes 0
+ set sober 0
+ } elseif {$safety eq "all"} {
+ set wipers 1
+ set brakes 1
+ set sober 1
+ }
+ } else {
+ if {$wipers == 1 && $brakes == 1 && $sober == 1} {
+ set safety all
+ } elseif {$wipers == 1 || $brakes == 1 || $sober == 1} {
+ set safety partial
+ } else {
+ set safety none
+ }
+ }
+ set in_check 0
+}
+
+trace add variable wipers write tristate_check
+trace add variable brakes write tristate_check
+trace add variable sober write tristate_check
+trace add variable safety write tristate_check
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/check.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/clrpick.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/clrpick.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/clrpick.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,54 @@
+# clrpick.tcl --
+#
+# This demonstration script prompts the user to select a color.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+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
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+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
+ }
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/clrpick.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/colors.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/colors.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/colors.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,99 @@
+# 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.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+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
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+frame $w.frame -borderwidth 7.5p
+pack $w.frame -side top -expand yes -fill y
+
+ttk::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 <Double-Button-1> {
+ 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
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/colors.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/combo.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/combo.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/combo.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,62 @@
+# combo.tcl --
+#
+# This demonstration script creates several combobox widgets.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+set w .combo
+catch {destroy $w}
+toplevel $w
+wm title $w "Combobox Demonstration"
+wm iconname $w "combo"
+positionWindow $w
+
+ttk::label $w.msg -font $font -wraplength 5i -justify left -text "Three different\
+ combo-boxes are displayed below. You can add characters to the first\
+ one by pointing, clicking and typing, just as with an entry; pressing\
+ Return will cause the current value to be added to the list that is\
+ selectable from the drop-down list, and you can choose other values\
+ by pressing the Down key, using the arrow keys to pick another one,\
+ and pressing Return again. The second combo-box is fixed to a\
+ particular value, and cannot be modified at all. The third one only\
+ allows you to select values from its drop-down list of Australian\
+ cities."
+pack $w.msg -side top -fill x
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w {firstValue secondValue ozCity}]
+pack $btns -side bottom -fill x
+
+ttk::frame $w.f
+pack $w.f -fill both -expand 1
+set w $w.f
+
+set australianCities {
+ Canberra Sydney Melbourne Perth Adelaide Brisbane
+ Hobart Darwin "Alice Springs"
+}
+set secondValue unchangable
+set ozCity Sydney
+
+ttk::labelframe $w.c1 -text "Fully Editable"
+ttk::combobox $w.c1.c -textvariable firstValue -placeholder {Enter text here}
+ttk::style configure TEntry -placeholderforeground gray50
+ttk::labelframe $w.c2 -text Disabled
+ttk::combobox $w.c2.c -textvariable secondValue -state disabled
+ttk::labelframe $w.c3 -text "Defined List Only"
+ttk::combobox $w.c3.c -textvariable ozCity -state readonly \
+ -values $australianCities
+bind $w.c1.c <Return> {
+ if {[%W get] ni [%W cget -values]} {
+ %W configure -values [concat [%W cget -values] [list [%W get]]]
+ }
+}
+
+pack $w.c1 $w.c2 $w.c3 -side top -pady 3p -padx 7.5p
+pack $w.c1.c -pady 3p -padx 7.5p
+pack $w.c2.c -pady 3p -padx 7.5p
+pack $w.c3.c -pady 3p -padx 7.5p
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/combo.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/cscroll.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/cscroll.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/cscroll.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,134 @@
+# cscroll.tcl --
+#
+# This demonstration script creates a simple canvas that can be
+# scrolled in two dimensions.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+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 by using the scrollbars, by dragging with button 2 in the canvas, by using a mouse wheel, or with the two-finger gesture on a touchpad. If you click button 1 on one of the rectangles, its indices will be printed on stdout."
+pack $w.msg -side top
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+frame $w.grid
+scrollbar $w.hscroll -orient horizontal -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 \
+ -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 <Enter> "scrollEnter $c"
+$c bind all <Leave> "scrollLeave $c"
+$c bind all <Button-1> "scrollButton $c"
+bind $c <Button-2> "$c scan mark %x %y"
+bind $c <B2-Motion> "$c scan dragto %x %y"
+
+# We must make sure that positive and negative movements are rounded
+# equally to integers, avoiding the problem that
+# (int)1/-40 = -1,
+# but
+# (int)-1/-40 = 0
+# The following code ensures equal +/- behaviour.
+bind $c <MouseWheel> {
+ if {%D >= 0} {
+ %W yview scroll [expr {%D/-40}] units
+ } else {
+ %W yview scroll [expr {(%D-39)/-40}] units
+ }
+}
+bind $c <Option-MouseWheel> {
+ if {%D >= 0} {
+ %W yview scroll [expr {%D/-12}] units
+ } else {
+ %W yview scroll [expr {(%D-11)/-12}] units
+ }
+}
+bind $c <Shift-MouseWheel> {
+ if {%D >= 0} {
+ %W xview scroll [expr {%D/-40}] units
+ } else {
+ %W xview scroll [expr {(%D-39)/-40}] units
+ }
+}
+bind $c <Shift-Option-MouseWheel> {
+ if {%D >= 0} {
+ %W xview scroll [expr {%D/-12}] units
+ } else {
+ %W xview scroll [expr {(%D-11)/-12}] units
+ }
+}
+bind $c <TouchpadScroll> {
+ lassign [tk::PreciseScrollDeltas %D] deltaX deltaY
+ if {$deltaX != 0 || $deltaY != 0} {
+ tk::ScrollByPixels %W $deltaX $deltaY
+ }
+}
+
+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} {
+ if {[tk windowingsystem] eq "aqua"} {
+ $canvas itemconfigure $id -fill systemSelectedTextBackgroundColor
+ } else {
+ $canvas itemconfigure $id -fill LightSeaGreen
+ }
+ }
+}
+
+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
+}
+
+proc scrollButton canvas {
+ 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]"
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/cscroll.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ctext.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ctext.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ctext.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,172 @@
+# ctext.tcl --
+#
+# This demonstration script creates a canvas widget with a text
+# item that can be edited and reconfigured in various ways.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+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, and on a pie slice to change its angle. 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
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+canvas $c -relief flat -borderwidth 0 -width 375p -height 262.5p
+pack $w.c -side top -expand yes -fill both
+
+set textFont {Helvetica 24}
+
+$c create rectangle 183.75p 122.25p 191.25p 129.75p -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 187.5p 126p -text "This is just a string of text to demonstrate the text facilities of canvas widgets. Bindings have been defined to support editing (see above)." -width 330p -anchor n -font $textFont -justify left]
+$c bind text <Button-1> "textB1Press $c %x %y"
+$c bind text <B1-Motion> "textB1Move $c %x %y"
+$c bind text <Shift-Button-1> "$c select adjust current @%x,%y"
+$c bind text <Shift-B1-Motion> "textB1Move $c %x %y"
+$c bind text <Key> "textInsert $c %A"
+$c bind text <Return> "textInsert $c \\n"
+$c bind text <Control-h> "textBs $c"
+$c bind text <BackSpace> "textBs $c"
+$c bind text <Delete> "textDel $c"
+$c bind text <Button-2> "textPaste $c @%x,%y"
+
+# Next, create some items that allow the text's anchor position
+# to be edited.
+
+proc mkTextConfigBox {w x y option value color} { ;# x, y are in points
+ set item [$w create rect ${x}p ${y}p [expr {$x+22.5}]p [expr {$y+22.5}]p \
+ -outline black -fill $color -width 0.75p]
+ $w bind $item <Button-1> "$w itemconf text $option $value"
+ $w addtag config withtag $item
+}
+proc mkTextConfigPie {w x y a option value color} { ;# x, y are in points
+ set item [$w create arc ${x}p ${y}p [expr {$x+67.5}]p [expr {$y+67.5}]p \
+ -start [expr {$a-15}] -extent 30 -outline black -fill $color \
+ -width 0.75p]
+ $w bind $item <Button-1> "$w itemconf text $option $value"
+ $w addtag config withtag $item
+}
+
+set x 37.5 ;# in points
+set y 37.5 ;# in points
+set color LightSkyBlue1
+mkTextConfigBox $c $x $y -anchor se $color
+mkTextConfigBox $c [expr {$x+22.5}] [expr {$y }] -anchor s $color
+mkTextConfigBox $c [expr {$x+45 }] [expr {$y }] -anchor sw $color
+mkTextConfigBox $c [expr {$x }] [expr {$y+22.5}] -anchor e $color
+mkTextConfigBox $c [expr {$x+22.5}] [expr {$y+22.5}] -anchor center $color
+mkTextConfigBox $c [expr {$x+45 }] [expr {$y+22.5}] -anchor w $color
+mkTextConfigBox $c [expr {$x }] [expr {$y+45 }] -anchor ne $color
+mkTextConfigBox $c [expr {$x+22.5}] [expr {$y+45 }] -anchor n $color
+mkTextConfigBox $c [expr {$x+45 }] [expr {$y+45 }] -anchor nw $color
+set item [$c create rect \
+ [expr {$x+30}]p [expr {$y+30}]p [expr {$x+37.5}]p [expr {$y+37.5}]p \
+ -outline black -fill red]
+$c bind $item <Button-1> "$c itemconf text -anchor center"
+$c create text [expr {$x+33.75}]p [expr {$y-3.75}]p \
+ -text {Text Position} -anchor s -font {Times 20} -fill brown
+
+# Now create some items that allow the text's angle to be changed.
+
+set x 153.75 ;# in points
+set y 37.5 ;# in points
+set color Yellow
+mkTextConfigPie $c $x $y 0 -angle 90 $color
+mkTextConfigPie $c $x $y 30 -angle 120 $color
+mkTextConfigPie $c $x $y 60 -angle 150 $color
+mkTextConfigPie $c $x $y 90 -angle 180 $color
+mkTextConfigPie $c $x $y 120 -angle 210 $color
+mkTextConfigPie $c $x $y 150 -angle 240 $color
+mkTextConfigPie $c $x $y 180 -angle 270 $color
+mkTextConfigPie $c $x $y 210 -angle 300 $color
+mkTextConfigPie $c $x $y 240 -angle 330 $color
+mkTextConfigPie $c $x $y 270 -angle 0 $color
+mkTextConfigPie $c $x $y 300 -angle 30 $color
+mkTextConfigPie $c $x $y 330 -angle 60 $color
+$c create text [expr {$x+33.75}]p [expr {$y-3.75}]p \
+ -text {Text Angle} -anchor s -font {Times 20} -fill brown
+
+# Lastly, create some items that allow the text's justification to be
+# changed.
+
+set x 262.5 ;# in points
+set y 37.5 ;# in points
+set color SeaGreen2
+mkTextConfigBox $c $x $y -justify left $color
+mkTextConfigBox $c [expr {$x+22.5}] $y -justify center $color
+mkTextConfigBox $c [expr {$x+45}] $y -justify right $color
+$c create text [expr {$x+33.75}]p [expr {$y-3.75}]p \
+ -text {Justification} -anchor s -font {Times 20} -fill brown
+
+$c bind config <Enter> "textEnter $c"
+$c bind config <Leave> "$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
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ctext.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/dialog1.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/dialog1.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/dialog1.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,25 @@
+# dialog1.tcl --
+#
+# This demonstration script creates a dialog box with a local grab.
+
+interp create child
+load {} Tk child
+child eval {
+ wm title . child
+ wm geometry . +700+30
+ pack [text .t -width 30 -height 10]
+}
+
+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 mouse or keyboard 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. For example, you should be able to edit text in the window named "child" which was created by a child interpreter.} \
+info 0 OK Cancel {Show Code}]
+
+switch $i {
+ 0 {puts "You pressed OK"}
+ 1 {puts "You pressed Cancel"}
+ 2 {showCode .dialog1}
+}
+
+if {[interp exists child]} {
+ interp delete child
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/dialog1.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/dialog2.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/dialog2.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/dialog2.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,18 @@
+# dialog2.tcl --
+#
+# This demonstration script creates a dialog box with a global grab.
+
+after idle {
+ .dialog2.msg configure -wraplength 4i
+}
+after 100 {
+ grab -global .dialog2
+}
+set i [tk_dialog .dialog2 "Dialog with global grab" {This dialog box uses a global grab. If you are using an X11 window manager you will be prevented from interacting with anything on your display until you invoke one of the buttons below. This is almost always a bad idea; don't use global grabs with X11 unless you're truly desperate. On macOS systems you will not be able to interact with any window belonging to this process, but interaction with other macOS Applications will still be possible.}\
+warning 0 OK Cancel {Show Code}]
+
+switch $i {
+ 0 {puts "You pressed OK"}
+ 1 {puts "You pressed Cancel"}
+ 2 {showCode .dialog2}
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/dialog2.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/en.msg
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/en.msg (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/en.msg 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,103 @@
+::msgcat::mcset en "Widget Demonstration"
+::msgcat::mcset en "tkWidgetDemo"
+::msgcat::mcset en "&File"
+::msgcat::mcset en "About..."
+::msgcat::mcset en "&About..."
+::msgcat::mcset en "<F1>"
+::msgcat::mcset en "&Quit"
+::msgcat::mcset en "Meta+Q" ;# Displayed hotkey
+::msgcat::mcset en "Meta-q" ;# Actual binding sequence
+::msgcat::mcset en "Ctrl+Q" ;# Displayed hotkey
+::msgcat::mcset en "Control-q" ;# Actual binding sequence
+::msgcat::mcset en "See Variables"
+::msgcat::mcset en "Variable values"
+::msgcat::mcset en "Variable values:"
+::msgcat::mcset en "OK"
+::msgcat::mcset en "Run the \"%s\" sample program"
+::msgcat::mcset en "Dismiss"
+::msgcat::mcset en "Rerun Demo"
+::msgcat::mcset en "Print Code"
+::msgcat::mcset en "Demo code: %s"
+::msgcat::mcset en "About Widget Demo"
+::msgcat::mcset en "Tk widget demonstration"
+::msgcat::mcset en "Copyright © %s"
+
+::msgcat::mcset en "Tk Widget Demonstrations"
+::msgcat::mcset en "This application provides a front end for several short scripts"
+::msgcat::mcset en "that demonstrate what you can do with Tk widgets. Each of the"
+::msgcat::mcset en "numbered lines below describes a demonstration; you can click on"
+::msgcat::mcset en "it to invoke the demonstration. Once the demonstration window"
+::msgcat::mcset en "appears, you can click the"
+::msgcat::mcset en "See Code" "See Code" ;# This is also button text!
+::msgcat::mcset en "button to see the Tcl/Tk code that created the demonstration. If"
+::msgcat::mcset en "you wish, you can edit the code and click the"
+::msgcat::mcset en "button in the code window to reinvoke the demonstration with the"
+::msgcat::mcset en "modified code."
+
+::msgcat::mcset en "Labels, buttons, checkbuttons, and radiobuttons"
+::msgcat::mcset en "Labels (text and bitmaps)"
+::msgcat::mcset en "Labels and UNICODE text"
+::msgcat::mcset en "Buttons"
+::msgcat::mcset en "Check-buttons (select any of a group)"
+::msgcat::mcset en "Radio-buttons (select one of a group)"
+::msgcat::mcset en "A 15-puzzle game made out of buttons"
+::msgcat::mcset en "Iconic buttons that use bitmaps"
+::msgcat::mcset en "Two labels displaying images"
+::msgcat::mcset en "A simple user interface for viewing images"
+::msgcat::mcset en "Labelled frames"
+
+::msgcat::mcset en "Listboxes"
+::msgcat::mcset en "The 50 states"
+::msgcat::mcset en "Colors: change the color scheme for the application"
+::msgcat::mcset en "A collection of famous and infamous sayings"
+
+::msgcat::mcset en "Entries and Spin-boxes"
+::msgcat::mcset en "Entries without scrollbars"
+::msgcat::mcset en "Entries with scrollbars"
+::msgcat::mcset en "Validated entries and password fields"
+::msgcat::mcset en "Spin-boxes"
+::msgcat::mcset en "Simple Rolodex-like form"
+
+::msgcat::mcset en "Text"
+::msgcat::mcset en "Basic editable text"
+::msgcat::mcset en "Text display styles"
+::msgcat::mcset en "Hypertext (tag bindings)"
+::msgcat::mcset en "A text widget with embedded windows"
+::msgcat::mcset en "A search tool built with a text widget"
+
+::msgcat::mcset en "Canvases"
+::msgcat::mcset en "The canvas item types"
+::msgcat::mcset en "A simple 2-D plot"
+::msgcat::mcset en "Text items in canvases"
+::msgcat::mcset en "An editor for arrowheads on canvas lines"
+::msgcat::mcset en "A ruler with adjustable tab stops"
+::msgcat::mcset en "A building floor plan"
+::msgcat::mcset en "A simple scrollable canvas"
+
+::msgcat::mcset en "Scales"
+::msgcat::mcset en "Horizontal scale"
+::msgcat::mcset en "Vertical scale"
+
+::msgcat::mcset en "Paned Windows"
+::msgcat::mcset en "Horizontal paned window"
+::msgcat::mcset en "Vertical paned window"
+::msgcat::mcset en "Menus"
+::msgcat::mcset en "Menus and cascades (sub-menus)"
+::msgcat::mcset en "Menu-buttons"
+::msgcat::mcset en "Common Dialogs"
+::msgcat::mcset en "Message boxes"
+::msgcat::mcset en "File selection dialog"
+::msgcat::mcset en "Color picker"
+::msgcat::mcset en "Font selection dialog"
+::msgcat::mcset en "System tray icon and notification"
+::msgcat::mcset en "Printing from canvas and text widgets"
+::msgcat::mcset en "Animation"
+::msgcat::mcset en "Animated labels"
+::msgcat::mcset en "Animated wave"
+::msgcat::mcset en "Pendulum simulation"
+::msgcat::mcset en "A celebration of Rube Goldberg"
+::msgcat::mcset en "Miscellaneous"
+::msgcat::mcset en "The built-in bitmaps"
+::msgcat::mcset en "A dialog box with a local grab"
+::msgcat::mcset en "A dialog box with a global grab"
+::msgcat::mcset en "Window icons and badges"
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/en.msg
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/entry1.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/entry1.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/entry1.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,34 @@
+# entry1.tcl --
+#
+# This demonstration script creates several entry widgets without
+# scrollbars.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+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 the middle mouse button pressed."
+pack $w.msg -side top
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+entry $w.e1
+entry $w.e2
+entry $w.e3 -placeholder {Enter text here} -placeholderforeground gray75
+pack $w.e1 $w.e2 $w.e3 -side top -pady 3p -padx 7.5p -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."
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/entry1.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/entry2.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/entry2.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/entry2.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,47 @@
+# entry2.tcl --
+#
+# This demonstration script is the same as the entry1.tcl script
+# except that it creates scrollbars for the entries.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+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 the middle mouse button pressed."
+pack $w.msg -side top
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+frame $w.frame -borderwidth 7.5p
+pack $w.frame -side top -fill x -expand 1
+
+entry $w.frame.e1 -xscrollcommand "$w.frame.s1 set"
+ttk::scrollbar $w.frame.s1 -orient horizontal -command \
+ "$w.frame.e1 xview"
+frame $w.frame.spacer1 -width 15p -height 7.5p
+entry $w.frame.e2 -xscrollcommand "$w.frame.s2 set"
+ttk::scrollbar $w.frame.s2 -orient horizontal -command \
+ "$w.frame.e2 xview"
+frame $w.frame.spacer2 -width 15p -height 7.5p
+entry $w.frame.e3 -xscrollcommand "$w.frame.s3 set"
+ttk::scrollbar $w.frame.s3 -orient horizontal -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."
+$w.frame.e3 configure -placeholder {Enter text here} -placeholderforeground gray75
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/entry2.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/entry3.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/entry3.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/entry3.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,185 @@
+# entry3.tcl --
+#
+# This demonstration script creates several entry widgets whose
+# permitted input is constrained in some way. It also shows off a
+# password entry.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+set w .entry3
+catch {destroy $w}
+toplevel $w
+wm title $w "Constrained Entry Demonstration"
+wm iconname $w "entry3"
+positionWindow $w
+
+label $w.msg -font $font -wraplength 5i -justify left -text "Four different\
+ entries are displayed below. You can add characters by pointing,\
+ clicking and typing, though each is constrained in what it will\
+ accept. The first only accepts 32-bit integers or the empty string\
+ (checking when focus leaves it) and will flash to indicate any\
+ problem. The second only accepts strings with fewer than ten\
+ characters and sounds the bell when an attempt to go over the limit\
+ is made. The third accepts US phone numbers, mapping letters to\
+ their digit equivalent and sounding the bell on encountering an\
+ illegal character or if trying to type over a character that is not\
+ a digit. The fourth is a password field that accepts up to eight\
+ characters (silently ignoring further ones), and displaying them as\
+ asterisk characters."
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+# focusAndFlash --
+# Error handler for entry widgets that forces the focus onto the
+# widget and makes the widget flash by exchanging the foreground and
+# background colours at intervals of 200ms (i.e. at approximately
+# 2.5Hz).
+#
+# Arguments:
+# W - Name of entry widget to flash
+# fg - Initial foreground colour
+# bg - Initial background colour
+# count - Counter to control the number of times flashed
+
+proc focusAndFlash {W fg bg {count 9}} {
+ focus -force $W
+ if {$count<1} {
+ $W configure -foreground $fg -background $bg
+ } else {
+ if {$count%2} {
+ $W configure -foreground $bg -background $fg
+ } else {
+ $W configure -foreground $fg -background $bg
+ }
+ after 200 [list focusAndFlash $W $fg $bg [expr {$count-1}]]
+ }
+}
+
+labelframe $w.l1 -text "Integer Entry"
+# Alternatively try using {string is digit} for arbitrary length numbers,
+# and not just 32-bit ones.
+entry $w.l1.e -validate focus -validatecommand {string is integer %P}
+$w.l1.e configure -invalidcommand \
+ "focusAndFlash %W [$w.l1.e cget -fg] [$w.l1.e cget -bg]"
+pack $w.l1.e -fill x -expand 1 -padx 1m -pady 1m
+
+labelframe $w.l2 -text "Length-Constrained Entry"
+entry $w.l2.e -validate key -invcmd bell -validatecommand {expr {[string length %P]<10}}
+pack $w.l2.e -fill x -expand 1 -padx 1m -pady 1m
+
+### PHONE NUMBER ENTRY ###
+# Note that the source to this is quite a bit longer as the behaviour
+# demonstrated is a lot more ambitious than with the others.
+
+# Initial content for the third entry widget
+set entry3content "1-(000)-000-0000"
+# Mapping from alphabetic characters to numbers. This is probably
+# wrong, but it is the only mapping I have; the UK doesn't really go
+# for associating letters with digits for some reason.
+set phoneNumberMap {}
+foreach {chars digit} {abc 2 def 3 ghi 4 jkl 5 mno 6 pqrs 7 tuv 8 wxyz 9} {
+ foreach char [split $chars ""] {
+ lappend phoneNumberMap $char $digit [string toupper $char] $digit
+ }
+}
+
+# validatePhoneChange --
+# Checks that the replacement (mapped to a digit) of the given
+# character in an entry widget at the given position will leave a
+# valid phone number in the widget.
+#
+# W - The entry widget to validate
+# vmode - The widget's validation mode
+# idx - The index where replacement is to occur
+# char - The character (or string, though that will always be
+# refused) to be overwritten at that point.
+
+proc validatePhoneChange {W vmode idx char} {
+ global phoneNumberMap entry3content
+ if {$idx < 0} {return 1}
+ after idle [list $W configure -validate $vmode -invcmd bell]
+ if {
+ !($idx<3 || $idx==6 || $idx==7 || $idx==11 || $idx>15) &&
+ [string match {[0-9A-Za-z]} $char]
+ } then {
+ $W delete $idx
+ $W insert $idx [string map $phoneNumberMap $char]
+ after idle [list phoneSkipRight $W -1]
+ return 1
+ }
+ return 0
+}
+
+# phoneSkipLeft --
+# Skip over fixed characters in a phone-number string when moving left.
+#
+# Arguments:
+# W - The entry widget containing the phone-number.
+
+proc phoneSkipLeft {W} {
+ set idx [$W index insert]
+ if {$idx == 8} {
+ # Skip back two extra characters
+ $W icursor [incr idx -2]
+ } elseif {$idx == 7 || $idx == 12} {
+ # Skip back one extra character
+ $W icursor [incr idx -1]
+ } elseif {$idx <= 3} {
+ # Can't move any further
+ bell
+ return -code break
+ }
+}
+
+# phoneSkipRight --
+# Skip over fixed characters in a phone-number string when moving right.
+#
+# Arguments:
+# W - The entry widget containing the phone-number.
+# add - Offset to add to index before calculation (used by validation.)
+
+proc phoneSkipRight {W {add 0}} {
+ set idx [$W index insert]
+ if {$idx+$add == 5} {
+ # Skip forward two extra characters
+ $W icursor [incr idx 2]
+ } elseif {$idx+$add == 6 || $idx+$add == 10} {
+ # Skip forward one extra character
+ $W icursor [incr idx]
+ } elseif {$idx+$add == 15 && !$add} {
+ # Can't move any further
+ bell
+ return -code break
+ }
+}
+
+labelframe $w.l3 -text "US Phone-Number Entry"
+entry $w.l3.e -validate key -invcmd bell -textvariable entry3content \
+ -validatecommand {validatePhoneChange %W %v %i %S}
+# Click to focus goes to the first editable character...
+bind $w.l3.e <FocusIn> {
+ if {"%d" ne "NotifyAncestor"} {
+ %W icursor 3
+ after idle {%W selection clear}
+ }
+}
+bind $w.l3.e <<PrevChar>> {phoneSkipLeft %W}
+bind $w.l3.e <<NextChar>> {phoneSkipRight %W}
+pack $w.l3.e -fill x -expand 1 -padx 1m -pady 1m
+
+labelframe $w.l4 -text "Password Entry"
+entry $w.l4.e -validate key -show "*" -validatecommand {expr {[string length %P]<=8}}
+pack $w.l4.e -fill x -expand 1 -padx 1m -pady 1m
+
+lower [frame $w.mid]
+grid $w.l1 $w.l2 -in $w.mid -padx 3m -pady 1m -sticky ew
+grid $w.l3 $w.l4 -in $w.mid -padx 3m -pady 1m -sticky ew
+grid columnconfigure $w.mid {0 1} -uniform 1
+pack $w.msg -side top
+pack $w.mid -fill both -expand 1
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/entry3.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/filebox.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/filebox.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/filebox.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,82 @@
+# filebox.tcl --
+#
+# This demonstration script prompts the user to select a file.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+set w .filebox
+catch {destroy $w}
+toplevel $w
+wm title $w "File Selection Dialogs"
+wm iconname $w "filebox"
+positionWindow $w
+
+ttk::frame $w._bg
+place $w._bg -x 0 -y 0 -relwidth 1 -relheight 1
+
+ttk::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
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+set f [ttk::frame $w.f]
+foreach i {open save} {
+ ttk::label $f.lab_$i -text "Select a file to $i:"
+ ttk::entry $f.ent_$i -width 20
+ ttk::button $f.but_$i -text "Browse ..." -command \
+ "fileDialog $w $f.ent_$i $i"
+ grid $f.lab_$i $f.ent_$i $f.but_$i -pady 3p -sticky w
+ grid configure $f.ent_$i -padx 3p -sticky ew
+}
+grid columnconfigure $f 1 -weight 1
+pack $f -fill x -padx 1c
+
+if {[tk windowingsystem] eq "x11"} {
+ ttk::checkbutton $w.strict -text "Use Motif Style Dialog" \
+ -variable tk_strictMotif -onvalue 1 -offvalue 0
+ pack $w.strict -anchor c
+
+ # This binding ensures that we don't run the rest of the demos
+ # with motif style interactions
+ bind $w.strict <Destroy> {set tk_strictMotif 0}
+}
+
+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"} {
+ global selected_type
+ if {![info exists selected_type]} {
+ set selected_type "Tcl Scripts"
+ }
+ set file [tk_getOpenFile -filetypes $types -parent $w \
+ -typevariable selected_type]
+ puts "You selected filetype \"$selected_type\""
+ } 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
+ }
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/filebox.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/floor.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/floor.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/floor.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,1379 @@
+# floor.tcl --
+#
+# This demonstration script creates a canvas widet that displays the
+# floorplan for DEC's Western Research Laboratory.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+# 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
+
+ # Rescale the coordinates in pixels of all of the
+ # items according to the display's DPI scaling level.
+
+ set scaleFactor [expr {$tk::scalingPct / 100.0}]
+ $w scale all 0 0 $scaleFactor $scaleFactor
+
+ # 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 450p 75p -anchor w -window $w.entry
+ $w create text 450p 75p -anchor e -text "Room: "
+
+ # Configure the canvas.
+
+ set bbox [$w bbox all]
+ lassign $bbox x1 y1 x2 y2
+ set morePx [expr {round(20 * $tk::scalingPct / 100.0)}]
+ set width [expr {$x2 - $x1 + $morePx}]
+ set height [expr {$y2 - $y1 + $morePx}]
+ $w configure -scrollregion $bbox -width $width -height $height
+}
+
+# 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) \
+ -outline {} -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 polygon 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 -outline {}
+ $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 polygon 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 -outline {}
+ $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 polygon 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 -outline {}
+ $w create polygon 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 -outline {}
+ $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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 {} -outline {} -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 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 75p 75p
+
+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
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+set f [frame $w.frame]
+pack $f -side top -fill both -expand yes
+set h [ttk::scrollbar $f.hscroll -orient horizontal]
+set v [ttk::scrollbar $f.vscroll -orient vertical]
+set f1 [frame $f.f1 -borderwidth 2 -relief sunken]
+set c [canvas $f1.c -highlightthickness 0 \
+ -xscrollcommand [list $h set] -yscrollcommand [list $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 configure -command [list $c yview]
+$h configure -command [list $c xview]
+
+# Create an entry for displaying and typing in current room.
+
+entry $c.entry -width 10 -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 <Button-1> "floorDisplay $c 1"
+$c bind floor2 <Button-1> "floorDisplay $c 2"
+$c bind floor3 <Button-1> "floorDisplay $c 3"
+$c bind room <Enter> "newRoom $c"
+$c bind room <Leave> {set currentRoom ""}
+bind $c <Button-2> "$c scan mark %x %y"
+bind $c <B2-Motion> "$c scan dragto %x %y"
+bind $c <Destroy> "unset currentRoom"
+set currentRoom ""
+trace add variable currentRoom write "roomChanged $c"
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/floor.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/fontchoose.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/fontchoose.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/fontchoose.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,67 @@
+# fontchoose.tcl --
+#
+# Show off the stock font selector dialog
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+set w .fontchoose
+catch {destroy $w}
+toplevel $w
+wm title $w "Font Selection Dialog"
+wm iconname $w "fontchooser"
+positionWindow $w
+
+catch {font create FontchooseDemoFont {*}[font actual TkDefaultFont]}
+
+# The font chooser needs to be configured and then shown.
+proc SelectFont {parent} {
+ tk fontchooser configure -font FontchooseDemoFont \
+ -command ApplyFont -parent $parent
+ tk fontchooser show
+}
+
+proc ApplyFont {font} {
+ font configure FontchooseDemoFont {*}[font actual $font]
+}
+
+# When the visibility of the fontchooser changes, the following event is fired
+# to the parent widget.
+#
+bind $w <<TkFontchooserVisibility>> {
+ if {[tk fontchooser configure -visible]} {
+ %W.f.font state disabled
+ } else {
+ %W.f.font state !disabled
+ }
+}
+
+
+set f [ttk::frame $w.f -relief sunken -padding 1.5p]
+
+text $f.msg -font FontchooseDemoFont -width 40 -height 6 -borderwidth 0 \
+ -yscrollcommand [list $f.vs set]
+ttk::scrollbar $f.vs -command [list $f.msg yview]
+
+$f.msg insert end "Press the buttons below to choose a new font for the\
+ text shown in this window.\n" {}
+
+ttk::button $f.font -text "Set font ..." -command [list SelectFont $w]
+
+grid $f.msg $f.vs -sticky news
+grid $f.font - -sticky e
+grid columnconfigure $f 0 -weight 1
+grid rowconfigure $f 0 -weight 1
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+
+grid $f -sticky news
+grid $btns -sticky ew
+grid columnconfigure $w 0 -weight 1
+grid rowconfigure $w 0 -weight 1
+update idletasks
+grid propagate $f 0
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/fontchoose.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/form.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/form.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/form.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,38 @@
+# form.tcl --
+#
+# This demonstration script creates a simple form with a bunch
+# of entry widgets.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+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
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+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 <Return> "destroy $w"
+focus $w.f1.entry
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/form.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/goldberg.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/goldberg.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/goldberg.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,1970 @@
+##+#################################################################
+#
+# TkGoldberg.tcl
+# by Keith Vetter, March 13, 2003
+#
+# "Man will always find a difficult means to perform a simple task"
+# Rube Goldberg
+#
+# Reproduced here with permission.
+#
+##+#################################################################
+#
+# Keith Vetter 2003-03-21: this started out as a simple little program
+# but was so much fun that it grew and grew. So I apologize about the
+# size but I just couldn't resist sharing it.
+#
+# This is a whizzlet that does a Rube Goldberg type animation, the
+# design of which comes from an New Years e-card from IncrediMail.
+# That version had nice sound effects which I eschewed. On the other
+# hand, that version was in black and white (actually dark blue and
+# light blue) and this one is fully colorized.
+#
+# One thing I learned from this project is that drawing filled complex
+# objects on a canvas is really hard. More often than not I had to
+# draw each item twice--once with the desired fill color but no
+# outline, and once with no fill but with the outline. Another trick
+# is erasing by drawing with the background color. Having a flood fill
+# command would have been extremely helpful.
+#
+# Two wiki pages were extremely helpful: Drawing rounded rectangles
+# which I generalized into Drawing rounded polygons, and regular
+# polygons which allowed me to convert ovals and arcs into polygons
+# which could then be rotated (see Canvas Rotation). I also wrote
+# Named Colors to aid in the color selection.
+#
+# I could comment on the code, but it's just 26 state machines with
+# lots of canvas create and move calls.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+set w .goldberg
+catch {destroy $w}
+toplevel $w
+wm title $w "Tk Goldberg (demonstration)"
+wm iconname $w "goldberg"
+wm resizable $w 0 0
+#positionWindow $w
+
+proc StartMessage {w} {
+ set msg1 "This\
+ is a demonstration of just how complex you can make your animations\
+ become. Close this dialog and click the ball to start things\
+ moving!\n\n\"Man will always find a difficult means to perform a\
+ simple task\"\n - Rube Goldberg"
+ PlacedDialog $w.c.messframe $msg1 {Helvetica 12}
+}
+###--- End of Boilerplate ---###
+
+array set BaseDimensions {
+ CanX 675
+ CanY 540
+ ScrX 750
+ ScrY 750
+ MsgX 338
+ MsgY 573
+ MovX 10
+ MovY -45
+}
+
+# The original value was 1.0 but this can make the demo
+# too large for the screen. Try a smaller value.
+set overallFactor 0.75
+
+foreach el [array names BaseDimensions] {
+ set Dims($el) [expr {$BaseDimensions($el) * $overallFactor}]p
+}
+
+set scaleFactor [expr {$::tk::scalingPct / 100.0 * $overallFactor}]
+
+# Ensure that this is an array
+array set animationCallbacks {}
+bind $w <Destroy> {
+ if {"%W" eq [winfo toplevel %W]} {
+ unset S C delays
+ }
+}
+
+set S(title) "Tk Goldberg"
+set S(speed) 5
+set S(cnt) 0
+set S(message) "\\nWelcome\\nto\\nTcl/Tk!"
+array set delays \
+ {1 500 2 400 3 300 4 200 5 150 6 100 7 80 8 50 9 20 10 10}
+
+set MSTART 0; set MGO 1; set MPAUSE 2; set MSSTEP 3; set MBSTEP 4; set MDONE 5
+set S(mode) $::MSTART
+
+# Colors for everything
+set C(fg) black
+set C(bg) cornflowerblue
+
+set C(0) white; set C(1a) darkgreen; set C(1b) yellow
+set C(2) red; set C(3a) green; set C(3b) darkblue
+set C(4) $C(fg); set C(5a) brown; set C(5b) white
+set C(6) magenta; set C(7) green; set C(8) $C(fg)
+set C(9) blue4; set C(10a) white; set C(10b) cyan
+set C(11a) yellow; set C(11b) mediumblue; set C(12) tan2
+set C(13a) yellow; set C(13b) red; set C(14) white
+set C(15a) green; set C(15b) yellow; set C(16) gray65
+set C(17) \#A65353; set C(18) $C(fg); set C(19) gray50
+set C(20) cyan; set C(21) gray65; set C(22) $C(20)
+set C(23a) blue; set C(23b) red; set C(23c) yellow
+set C(24a) red; set C(24b) white;
+set C(24c) black; set C(26) $C(0);
+
+proc DoDisplay {w} {
+ global S C Dims
+
+ ttk::frame $w.ctrl -relief ridge -borderwidth 1 -padding 3p
+ pack [frame $w.screen -bd 1 -relief raised] \
+ -side left -fill both -expand 1
+
+ canvas $w.c -width $Dims(CanX) -height $Dims(CanY) -bg $C(bg) \
+ -highlightthickness 0
+ $w.c config -scrollregion [list 0 0 $Dims(ScrX) $Dims(ScrY)]
+ $w.c yview moveto .06 ;# Kludge: move everything up
+ pack $w.c -in $w.screen -side top -fill both -expand 1
+
+ bind $w.c <Configure> { %W yview moveto .06 }
+ bind $w.c <Button-3> [list $w.pause invoke]
+ bind $w.c <Destroy> {
+ after cancel $animationCallbacks(goldberg)
+ unset animationCallbacks(goldberg)
+ }
+ DoCtrlFrame $w
+ DoDetailFrame $w
+ if {[tk windowingsystem] ne "aqua"} {
+ ttk::button $w.show -text "▶" -command [list ShowCtrl $w] -width 2
+ } else {
+ button $w.show -text "▶" -command [list ShowCtrl $w] -width 1 \
+ -borderwidth 1 -highlightthickness 0 -padx 0 -pady 0 \
+ -highlightbackground $C(bg)
+ }
+ place $w.show -in $w.c -relx 1 -rely 0 -anchor ne
+ update
+}
+
+proc DoCtrlFrame {w} {
+ global S
+ ttk::button $w.start -text "Start" -command [list DoButton $w 0]
+ ttk::checkbutton $w.pause -text "Pause" -command [list DoButton $w 1] \
+ -variable S(pause)
+ ttk::button $w.step -text "Single Step" -command [list DoButton $w 2]
+ ttk::button $w.bstep -text "Big Step" -command [list DoButton $w 4]
+ ttk::button $w.reset -text "Reset" -command [list DoButton $w 3]
+ ttk::labelframe $w.details
+ raise $w.details
+ set S(details) 0
+ ttk::checkbutton $w.details.cb -text "Details" -variable S(details)
+ ttk::labelframe $w.message -text "Message"
+ ttk::entry $w.message.e -textvariable S(message) -justify center
+ ttk::labelframe $w.speed -text "Speed: 0"
+ ttk::scale $w.speed.scale -orient horizontal -from 1 -to 10 \
+ -variable S(speed)
+ ttk::button $w.about -text About -command [list About $w]
+
+ grid $w.start -in $w.ctrl -row 0 -sticky ew
+ grid rowconfigure $w.ctrl 1 -minsize 3p
+ grid $w.pause -in $w.ctrl -row 2 -sticky ew
+ grid $w.step -in $w.ctrl -sticky ew -pady 1.5p
+ grid $w.bstep -in $w.ctrl -sticky ew
+ grid $w.reset -in $w.ctrl -sticky ew -pady 1.5p
+ grid rowconfigure $w.ctrl 10 -minsize 3p
+ grid $w.details -in $w.ctrl -row 11 -sticky ew
+ grid rowconfigure $w.ctrl 11 -minsize 3p
+ $w.details configure -labelwidget $w.details.cb
+ grid [ttk::frame $w.details.b -height 1] ;# Work around minor bug
+ raise $w.details
+ raise $w.details.cb
+ grid rowconfigure $w.ctrl 50 -weight 1
+ trace add variable ::S(mode) write [list ActiveGUI $w]
+ trace add variable ::S(details) write [list ActiveGUI $w]
+ trace add variable ::S(speed) write [list ActiveGUI $w]
+
+ grid $w.message -in $w.ctrl -row 98 -sticky ew -pady {0 3p}
+ grid $w.message.e -sticky nsew
+ grid $w.speed -in $w.ctrl -row 99 -sticky ew -pady {0 3p}
+ pack $w.speed.scale -fill both -expand 1
+ grid $w.about -in $w.ctrl -row 100 -sticky ew
+ bind $w.reset <Button-3> {set S(mode) -1} ;# Debugging
+
+ ## See Code / Dismiss buttons hack!
+ grid [ttk::separator $w.ctrl.sep] -sticky ew -pady {3p 1.5p}
+ set btns {}
+ foreach b [winfo children [addSeeDismiss $w.ctrl.buttons $w]] {
+ if {[winfo class $b] eq "TButton"} {
+ set btns [linsert $btns 0 $b] ;# Prepend
+ }
+ }
+ set i 0
+ foreach b $btns {
+ grid [set b2 [ttk::button $w.ctrl.b[incr i]]] -sticky ew -pady {1.5p 0}
+ foreach b3 [$b configure] {
+ set b3 [lindex $b3 0]
+ # Some options are read-only; ignore those errors
+ catch {$b2 configure $b3 [$b cget $b3]}
+ }
+ }
+ destroy $btns
+}
+
+proc DoDetailFrame {w} {
+ set w2 $w.details.f
+ ttk::frame $w2
+
+ ttk::label $w2.l -textvariable S(cnt) -background white
+ grid $w2.l - - - -sticky ew -row 0
+ for {set i 1} {1} {incr i} {
+ if {[info procs "Move$i"] eq ""} break
+ ttk::label $w2.l$i -text $i -anchor e -width 2 -background white
+ ttk::label $w2.ll$i -textvariable STEP($i) -width 5 -background white
+ set row [expr {($i + 1) / 2}]
+ set col [expr {(($i + 1) & 1) * 2}]
+ grid $w2.l$i -sticky ew -row $row -column $col
+ grid $w2.ll$i -sticky ew -row $row -column [incr col]
+ }
+ grid columnconfigure $w2 1 -weight 1
+}
+
+# Map or unmap the ctrl window
+proc ShowCtrl {w} {
+ if {[winfo ismapped $w.ctrl]} {
+ pack forget $w.ctrl
+ $w.show config -text "▶"
+ } else {
+ pack $w.ctrl -side right -fill both -ipady 5
+ $w.show config -text "◀"
+ }
+}
+
+proc DrawAll {w} {
+ global scaleFactor
+ ResetStep
+ $w.c delete all
+ for {set i 0} {1} {incr i} {
+ set p "Draw$i"
+ if {[info procs $p] eq ""} break
+ $p $w
+ }
+
+ $w.c scale all 0 0 $scaleFactor $scaleFactor
+
+ # Tile the strike box with a 4x4 bitmap image derived
+ # from Tk's built-in 16x16 bitmap gray25. Adjust
+ # x1, y2 to make dimensions multiples of 4 pixels.
+
+ image create bitmap smallGray25 -data {
+ #define smallGray25_width 4
+ #define smallGray25_height 4
+ static unsigned char smallGray25_bits[] = {
+ 0x08, 0x02, 0x08, 0x02};
+ } -foreground $::C(fg)
+
+ lassign [$w.c coords StrikeBox] x1 y1 x2 y2
+ set oldMidY [expr {round(($y1 + $y2) / 2.0)}]
+
+ set rowCount [expr {round(($y2 - $y1) / 4.0)}]
+ set colCount [expr {round(($x2 - $x1) / 4.0)}]
+ set x2 [expr {round($x2)}]
+ set x1 [expr {$x2 - $colCount * 4}]
+ set y1 [expr {round($y1)}]
+ set y2 [expr {$y1 + $rowCount * 4}]
+
+ set newMidY [expr {round(($y1 + $y2) / 2.0)}]
+ set deltaY [expr {$oldMidY - $newMidY}]
+ incr y1 $deltaY; incr y2 $deltaY
+ $w.c coords StrikeBox $x1 $y1 $x2 $y2
+
+ for {set row 0; set y $y1} {$row < $rowCount} {incr row; incr y 4} {
+ for {set col 0; set x $x1} {$col < $colCount} {incr col; incr x 4} {
+ $w.c create image $x $y -image smallGray25 -anchor nw
+ }
+ }
+}
+
+proc ActiveGUI {w var1 var2 op} {
+ global S MGO MSTART MDONE
+ array set z {0 disabled 1 normal}
+
+ set m $S(mode)
+ set S(pause) [expr {$m == 2}]
+ $w.start config -state $z([expr {$m != $MGO}])
+ $w.pause config -state $z([expr {$m != $MSTART && $m != $MDONE}])
+ $w.step config -state $z([expr {$m != $MGO && $m != $MDONE}])
+ $w.bstep config -state $z([expr {$m != $MGO && $m != $MDONE}])
+ $w.reset config -state $z([expr {$m != $MSTART}])
+
+ if {$S(details)} {
+ grid $w.details.f -sticky ew
+ } else {
+ grid forget $w.details.f
+ }
+ set S(speed) [expr {round($S(speed))}]
+ $w.speed config -text "Speed: $S(speed)"
+}
+
+proc Start {} {
+ global S MGO
+ set S(mode) $MGO
+}
+
+proc DoButton {w what} {
+ global S MDONE MGO MSSTEP MBSTEP MPAUSE
+
+ if {$what == 0} { ;# Start
+ if {$S(mode) == $MDONE} {
+ Reset $w
+ }
+ set S(mode) $MGO
+ } elseif {$what == 1} { ;# Pause
+ set S(mode) [expr {$S(pause) ? $MPAUSE : $MGO}]
+ } elseif {$what == 2} { ;# Step
+ set S(mode) $MSSTEP
+ } elseif {$what == 3} { ;# Reset
+ Reset $w
+ } elseif {$what == 4} { ;# Big step
+ set S(mode) $MBSTEP
+ }
+}
+
+proc Go {w {who {}}} {
+ global S delays animationCallbacks MGO MPAUSE MSSTEP MBSTEP
+
+ set now [clock clicks -milliseconds]
+ catch {after cancel $animationCallbacks(goldberg)}
+ if {$who ne ""} { ;# Start here for debugging
+ set S(active) $who
+ set S(mode) $MGO
+ }
+ if {$S(mode) == -1} return ;# Debugging
+ set n 0
+ if {$S(mode) != $MPAUSE} { ;# Not paused
+ set n [NextStep $w] ;# Do the next move
+ }
+ if {$S(mode) == $MSSTEP} { ;# Single step
+ set S(mode) $MPAUSE
+ }
+ if {$S(mode) == $MBSTEP && $n} { ;# Big step
+ set S(mode) $MSSTEP
+ }
+
+ set elapsed [expr {[clock click -milliseconds] - $now}]
+ set delay [expr {$delays($S(speed)) - $elapsed}]
+ if {$delay <= 0} {
+ set delay 1
+ }
+ set animationCallbacks(goldberg) [after $delay [list Go $w]]
+}
+
+# NextStep: drives the next step of the animation
+proc NextStep {w} {
+ global S MSTART MDONE
+ set rval 0 ;# Return value
+
+ if {$S(mode) != $MSTART && $S(mode) != $MDONE} {
+ incr S(cnt)
+ }
+ set alive {}
+ foreach {who} $S(active) {
+ set n ["Move$who" $w]
+ if {$n & 1} { ;# This guy still alive
+ lappend alive $who
+ }
+ if {$n & 2} { ;# Next guy is active
+ lappend alive [expr {$who + 1}]
+ set rval 1
+ }
+ if {$n & 4} { ;# End of puzzle flag
+ set S(mode) $MDONE ;# Done mode
+ set S(active) {} ;# No more animation
+ return 1
+ }
+ }
+ set S(active) $alive
+ return $rval
+}
+
+proc About {w} {
+ set msg "$::S(title)\nby Keith Vetter, March 2003\n(Reproduced by kind\
+ permission of the author)\n\n\"Man will always find a difficult\
+ means to perform a simple task.\"\n - Rube Goldberg"
+ PlacedDialog $w.c.messframe $msg {Helvetica 12 bold}
+ return
+}
+################################################################
+#
+# All the drawing and moving routines
+#
+
+# START HERE! banner
+proc Draw0 {w} {
+ set color $::C(0)
+ set xy {699 119}
+ $w.c create text $xy -text "START HERE!" -fill $color -anchor e \
+ -tag {I0 I0_0} -font {Times 12 italic bold}
+ set xy {719 119 763 119}
+ $w.c create line $xy -tag {I0 I0_1} -fill $color -width 3.75p -arrow last \
+ -arrowshape {13.5p 13.5p 3.75p}
+ $w.c bind I0 <Button-1> Start
+}
+proc Move0 {w {step {}}} {
+ set step [GetStep 0 $step]
+
+ if {$::S(mode) > $::MSTART} { ;# Start the ball rolling
+ MoveAbs $w I0 {-100 -100} ;# Hide the banner
+ return 2
+ }
+
+ set pos [scl {
+ {719 119} {724 119} {729 119} {734 119}
+ {739 119} {734 119} {729 119} {724 119}
+ }]
+ set step [expr {$step % [llength $pos]}]
+ lassign [lindex $pos $step] x y
+ $w.c coords I0_0 [expr {$x - [scl 20]}] $y
+ $w.c coords I0_1 $x $y [expr {$x + [scl 44]}] $y
+ return 1
+}
+
+# Dropping ball
+proc Draw1 {w} {
+ set color $::C(1a)
+ set color2 $::C(1b)
+ set xy {844 133 800 133 800 346 820 346 820 168 844 168 844 133}
+ $w.c create poly $xy -width 2.25p -fill $color -outline {}
+ set xy {771 133 685 133 685 168 751 168 751 346 771 346 771 133}
+ $w.c create poly $xy -width 2.25p -fill $color -outline {}
+
+ set xy [box 812 122 9]
+ $w.c create oval $xy -tag I1 -fill $color2 -outline {}
+ $w.c bind I1 <Button-1> Start
+}
+proc Move1 {w {step {}}} {
+ set step [GetStep 1 $step]
+ set pos [scl {
+ {807 122} {802 122} {797 123} {793 124} {789 129} {785 153}
+ {785 203} {785 278 x} {785 367} {810 392} {816 438} {821 503}
+ {824 585 y} {838 587} {848 593} {857 601} {-100 -100}
+ }]
+ if {$step >= [llength $pos]} {
+ return 0
+ }
+ set where [lindex $pos $step]
+ MoveAbs $w I1 $where
+
+ if {[lindex $where 2] eq "y"} {
+ Move15a $w
+ }
+ if {[lindex $where 2] eq "x"} {
+ return 3
+ }
+ return 1
+}
+
+# Lighting the match
+proc Draw2 {w} {
+ set color red
+ set color $::C(2)
+ set xy {750 369 740 392 760 392} ;# Fulcrum
+ $w.c create poly $xy -fill $::C(fg) -outline $::C(fg)
+ set xy {628 335 660 383} ;# Strike box
+ $w.c create rect $xy -fill {} -outline $::C(fg) -tag StrikeBox
+
+ set xy {702 366 798 366} ;# Lever
+ $w.c create line $xy -fill $::C(fg) -width 5.25p -tag I2_0
+ set xy {712 363 712 355} ;# R strap
+ $w.c create line $xy -fill $::C(fg) -width 2.25p -tag I2_1
+ set xy {705 363 705 355} ;# L strap
+ $w.c create line $xy -fill $::C(fg) -width 2.25p -tag I2_2
+ set xy {679 356 679 360 717 360 717 356 679 356} ;# Match stick
+ $w.c create line $xy -fill $::C(fg) -tag I2_3
+
+ #set xy {662 352 680 365} ;# Match head
+ set xy {
+ 671 352 677.4 353.9 680 358.5 677.4 363.1 671 365 664.6 363.1
+ 662 358.5 664.6 353.9
+ }
+ $w.c create poly $xy -fill $color -outline $color -tag I2_4
+}
+proc Move2 {w {step {}}} {
+ set step [GetStep 2 $step]
+
+ set stages {0 0 1 2 0 2 1 0 1 2 0 2 1}
+ set xy(0) [scl {
+ 686 333 692 323 682 316 674 309 671 295 668 307 662 318 662 328
+ 671 336
+ }]
+ set xy(1) [scl {
+ 687 331 698 322 703 295 680 320 668 297 663 311 661 327 671 335}]
+ set xy(2) [scl {
+ 686 331 704 322 688 300 678 283 678 283 674 298 666 309 660 324
+ 672 336
+ }]
+
+ if {$step >= [llength $stages]} {
+ $w.c delete I2
+ return 0
+ }
+
+ if {$step == 0} { ;# Rotate the match
+ set beta 20
+ lassign [Anchor $w I2_0 s] Ox Oy ;# Where to pivot
+ for {set i 0} {[$w.c find withtag I2_$i] ne ""} {incr i} {
+ RotateItem $w I2_$i $Ox $Oy $beta
+ }
+ $w.c create poly -tag I2 -smooth 1 -fill $::C(2) ;# For the flame
+ return 1
+ }
+ $w.c coords I2 $xy([lindex $stages $step])
+ return [expr {$step == 7 ? 3 : 1}]
+}
+
+# Weight and pulleys
+proc Draw3 {w} {
+ set color $::C(3a)
+ set color2 $::C(3b)
+
+ set xy {602 296 577 174 518 174}
+ foreach {x y} $xy { ;# 3 Pulleys
+ $w.c create oval [box $x $y 13] -fill $color -outline $::C(fg) \
+ -width 2.25p
+ $w.c create oval [box $x $y 2] -fill $::C(fg) -outline $::C(fg)
+ }
+
+ set xy {750 309 670 309} ;# Wall to flame
+ $w.c create line $xy -tag I3_s -width 2.25p -fill $::C(fg) -smooth 1
+ set xy {670 309 650 309} ;# Flame to pulley 1
+ $w.c create line $xy -tag I3_0 -width 2.25p -fill $::C(fg)
+ set xy {650 309 600 309} ;# Flame to pulley 1
+ $w.c create line $xy -tag I3_1 -width 2.25p -fill $::C(fg)
+ set xy {589 296 589 235} ;# Pulley 1 half way to 2
+ $w.c create line $xy -tag I3_2 -width 2.25p -fill $::C(fg)
+ set xy {589 235 589 174} ;# Pulley 1 other half to 2
+ $w.c create line $xy -width 2.25p -fill $::C(fg)
+ set xy {577 161 518 161} ;# Across the top
+ $w.c create line $xy -width 2.25p -fill $::C(fg)
+ set xy {505 174 505 205} ;# Down to weight
+ $w.c create line $xy -tag I3_w -width 2.25p -fill $::C(fg)
+
+ # Draw the weight as 2 circles, two rectangles and 1 rounded rectangle
+ set xy {515 207 495 207}
+ foreach {x1 y1 x2 y2} $xy {
+ $w.c create oval [box $x1 $y1 6] -tag I3_ -fill $color2 \
+ -outline $color2
+ $w.c create oval [box $x2 $y2 6] -tag I3_ -fill $color2 \
+ -outline $color2
+ incr y1 -6; incr y2 6
+ $w.c create rect $x1 $y1 $x2 $y2 -tag I3_ -fill $color2 \
+ -outline $color2
+ }
+ set xy {492 220 518 263}
+ set xy [RoundRect $w $xy 15]
+ $w.c create poly $xy -smooth 1 -tag I3_ -fill $color2 -outline $color2
+ set xy {500 217 511 217}
+ $w.c create line $xy -tag I3_ -fill $color2 -width 7.5p
+
+ set xy {502 393 522 393 522 465} ;# Bottom weight target
+ $w.c create line $xy -tag I3__ -fill $::C(fg) -join miter -width 7.5p
+}
+proc Move3 {w {step {}}} {
+ set step [GetStep 3 $step]
+
+ set pos [scl {{505 247} {505 297} {505 386.5} {505 386.5}}]
+ set rope(0) [scl {750 309 729 301 711 324 690 300}]
+ set rope(1) [scl {750 309 737 292 736 335 717 315 712 320}]
+ set rope(2) [scl {750 309 737 309 740 343 736 351 725 340}]
+ set rope(3) [scl {750 309 738 321 746 345 742 356}]
+
+ if {$step >= [llength $pos]} {
+ return 0
+ }
+
+ $w.c delete "I3_$step" ;# Delete part of the rope
+ MoveAbs $w I3_ [lindex $pos $step] ;# Move weight down
+ $w.c coords I3_s $rope($step) ;# Flapping rope end
+ $w.c coords I3_w [concat [scl {505 174}] [lindex $pos $step]]
+ if {$step == 2} {
+ $w.c move I3__ 0 30
+ return 2
+ }
+ return 1
+}
+
+# Cage and door
+proc Draw4 {w} {
+ set color $::C(4)
+ lassign {527 356 611 464} x0 y0 x1 y1
+
+ for {set y $y0} {$y <= $y1} {incr y 12} { ;# Horizontal bars
+ $w.c create line $x0 $y $x1 $y -fill $color -width 0.75p
+ }
+ for {set x $x0} {$x <= $x1} {incr x 12} { ;# Vertical bars
+ $w.c create line $x $y0 $x $y1 -fill $color -width 0.75p
+ }
+
+ set xy {518 464 518 428} ;# Swing gate
+ $w.c create line $xy -tag I4 -fill $color -width 2.25p
+}
+proc Move4 {w {step {}}} {
+ set step [GetStep 4 $step]
+
+ set angles {-10 -20 -30 -30}
+ if {$step >= [llength $angles]} {
+ return 0
+ }
+ RotateItem $w I4 [scl 518] [scl 464] [lindex $angles $step]
+ $w.c raise I4
+ return [expr {$step == 3 ? 3 : 1}]
+}
+
+# Mouse
+proc Draw5 {w} {
+ set color $::C(5a)
+ set color2 $::C(5b)
+ set xy {377 248 410 248 410 465 518 465} ;# Mouse course
+ lappend xy 518 428 451 428 451 212 377 212
+ $w.c create poly $xy -fill $color2 -outline $::C(fg) -width 2.25p
+
+ set xy {
+ 534.5 445.5 541 440 552 436 560 436 569 440 574 446 575 452 574 454
+ 566 456 554 456 545 456 537 454 530 452
+ }
+ $w.c create poly $xy -tag {I5 I5_0} -fill $color
+ set xy {573 452 592 458 601 460 613 456} ;# Tail
+ $w.c create line $xy -tag {I5 I5_1} -fill $color -smooth 1 -width 2.25p
+ set xy [box 540 446 2] ;# Eye
+ set xy {540 444 541 445 541 447 540 448 538 447 538 445}
+ #.c create oval $xy -tag {I5 I5_2} -fill $::C(bg) -outline {}
+ $w.c create poly $xy -tag {I5 I5_2} -fill $::C(bg) -outline {} -smooth 1
+ set xy {538 454 535 461} ;# Front leg
+ $w.c create line $xy -tag {I5 I5_3} -fill $color -width 1.5p
+ set xy {566 455 569 462} ;# Back leg
+ $w.c create line $xy -tag {I5 I5_4} -fill $color -width 1.5p
+ set xy {544 455 545 460} ;# 2nd front leg
+ $w.c create line $xy -tag {I5 I5_5} -fill $color -width 1.5p
+ set xy {560 455 558 460} ;# 2nd back leg
+ $w.c create line $xy -tag {I5 I5_6} -fill $color -width 1.5p
+}
+proc Move5 {w {step {}}} {
+ set step [GetStep 5 $step]
+
+ set pos [scl {
+ {553 452} {533 452} {513 452} {493 452} {473 452}
+ {463 442 30} {445.5 441.5 30} {425.5 434.5 30} {422 414} {422 394}
+ {422 374} {422 354} {422 334} {422 314} {422 294}
+ {422 274 -30} {422 260.5 -30 x} {422.5 248.5 -28} {425 237}
+ }]
+ if {$step >= [llength $pos]} {
+ return 0
+ }
+
+ lassign [lindex $pos $step] x y beta next
+ MoveAbs $w I5 [list $x $y]
+ if {$beta ne ""} {
+ lassign [Centroid $w I5_0] Ox Oy
+ foreach id {0 1 2 3 4 5 6} {
+ RotateItem $w I5_$id $Ox $Oy $beta
+ }
+ }
+ if {$next eq "x"} {
+ return 3
+ }
+ return 1
+}
+
+# Dropping gumballs
+array set XY6 {
+ -1 {366 207} -2 {349 204} -3 {359 193} -4 {375 192} -5 {340 190}
+ -6 {349 177} -7 {366 177} -8 {380 176} -9 {332 172} -10 {342 161}
+ -11 {357 164} -12 {372 163} -13 {381 149} -14 {364 151} -15 {349 146}
+ -16 {333 148} 0 {357 219}
+ 1 {359 261} 2 {359 291} 3 {359 318} 4 {361 324} 5 {365 329} 6 {367 334}
+ 7 {367 340} 8 {366 346} 9 {364 350} 10 {361 355} 11 {359 370} 12 {359 391}
+ 13,0 {360 456} 13,1 {376 456} 13,2 {346 456} 13,3 {330 456}
+ 13,4 {353 444} 13,5 {368 443} 13,6 {339 442} 13,7 {359 431}
+ 13,8 {380 437} 13,9 {345 428} 13,10 {328 434} 13,11 {373 424}
+ 13,12 {331 420} 13,13 {360 417} 13,14 {345 412} 13,15 {376 410}
+ 13,16 {360 403}
+}
+proc Draw6 {w} {
+ set color $::C(6)
+ set xy {324 130 391 204} ;# Ball holder
+ set xy [RoundRect $w $xy 10]
+ $w.c create poly $xy -smooth 1 -outline $::C(fg) -width 2.25p -fill $color
+ set xy {339 204 376 253} ;# Below the ball holder
+ $w.c create rect $xy -fill {} -outline $::C(fg) -width 2.25p -fill $color \
+ -tag I6c
+ set xy [box 346 339 28]
+ $w.c create oval $xy -fill $color -outline {} ;# Rotor
+ $w.c create arc $xy -outline $::C(fg) -width 1.5p -style arc \
+ -start 80 -extent 205
+ $w.c create arc $xy -outline $::C(fg) -width 1.5p -style arc \
+ -start -41 -extent 85
+
+ set xy [box 346 339 15] ;# Center of rotor
+ $w.c create oval $xy -outline $::C(fg) -fill $::C(fg) -tag I6m
+ set xy {352 312 352 254 368 254 368 322} ;# Top drop to rotor
+ $w.c create poly $xy -fill $color -outline {}
+ $w.c create line $xy -fill $::C(fg) -width 1.5p
+
+ set xy {353 240 367 300} ;# Poke bottom hole
+ $w.c create rect $xy -fill $color -outline {}
+ set xy {341 190 375 210} ;# Poke another hole
+ $w.c create rect $xy -fill $color -outline {}
+
+ set xy {368 356 368 403 389 403 389 464 320 464 320 403 352 403 352 366}
+ $w.c create poly $xy -fill $color -outline {} -width 1.5p ;# Below rotor
+ $w.c create line $xy -fill $::C(fg) -width 1.5p
+ set xy [box 275 342 7] ;# On/off rotor
+ $w.c create oval $xy -outline $::C(fg) -fill $::C(fg)
+ set xy {276 334 342 325} ;# Fan belt top
+ $w.c create line $xy -fill $::C(fg) -width 2.25p
+ set xy {276 349 342 353} ;# Fan belt bottom
+ $w.c create line $xy -fill $::C(fg) -width 2.25p
+
+ set xy {337 212 337 247} ;# What the mouse pushes
+ $w.c create line $xy -fill $::C(fg) -width 2.25p -tag I6_
+ set xy {392 212 392 247}
+ $w.c create line $xy -fill $::C(fg) -width 2.25p -tag I6_
+ set xy {337 230 392 230}
+ $w.c create line $xy -fill $::C(fg) -width 5.25p -tag I6_
+
+ set who -1 ;# All the balls
+ set colors {red cyan orange green blue darkblue}
+ lappend colors {*}$colors {*}$colors
+
+ for {set i 0} {$i < 17} {incr i} {
+ set loc [expr {-1 * $i}]
+ set color [lindex $colors $i]
+ $w.c create oval [box {*}$::XY6($loc) 5] -fill $color \
+ -outline $color -tag I6_b$i
+ }
+ Draw6a $w 12 ;# The wheel
+}
+proc Draw6a {w beta {scale 0}} {
+ $w.c delete I6_0
+ if {$scale} {
+ lassign [scl {346 339}] Ox Oy
+ } else {
+ lassign {346 339} Ox Oy
+ }
+ for {set i 0} {$i < 4} {incr i} {
+ set b [expr {$beta + $i * 45}]
+ if {$scale} {
+ lassign [RotateC [scl 28] 0 0 0 $b] x y
+ } else {
+ lassign [RotateC 28 0 0 0 $b] x y
+ }
+ set xy [list [expr {$Ox+$x}] [expr {$Oy+$y}] \
+ [expr {$Ox-$x}] [expr {$Oy-$y}]]
+ $w.c create line $xy -tag I6_0 -fill $::C(fg) -width 1.5p
+ }
+}
+proc Move6 {w {step {}}} {
+ set step [GetStep 6 $step]
+ if {$step > 62} {
+ return 0
+ }
+
+ if {$step < 2} { ;# Open gate for balls to drop
+ $w.c move I6_ -5.25p 0
+ if {$step == 1} { ;# Poke a hole
+ set xy [scl {348 226 365 240}]
+ $w.c create rect $xy -fill [$w.c itemcget I6c -fill] -outline {}
+ }
+ return 1
+ }
+
+ set s [expr {$step - 1}] ;# Do the gumball drop dance
+ for {set i 0} {$i <= int(($s-1) / 3)} {incr i} {
+ set tag "I6_b$i"
+ if {[$w.c find withtag $tag] eq ""} break
+ set loc [expr {$s - 3 * $i}]
+
+ if {[info exists ::XY6($loc,$i)]} {
+ MoveAbs $w $tag [scl $::XY6($loc,$i)]
+ } elseif {[info exists ::XY6($loc)]} {
+ MoveAbs $w $tag [scl $::XY6($loc)]
+ }
+ }
+ if {($s % 3) == 1} {
+ set first [expr {($s + 2) / 3}]
+ for {set i $first} {1} {incr i} {
+ set tag "I6_b$i"
+ if {[$w.c find withtag $tag] eq ""} break
+ set loc [expr {$first - $i}]
+ MoveAbs $w $tag [scl $::XY6($loc)]
+ }
+ }
+ if {$s >= 3} { ;# Rotate the motor
+ set idx [expr {$s % 3}]
+ #Draw6a $w [lindex {12 35 64} $idx]
+ Draw6a $w [expr {12 + $s * 15}] 1
+ }
+ return [expr {$s == 3 ? 3 : 1}]
+}
+
+# On/off switch
+proc Draw7 {w} {
+ set color $::C(7)
+ set xy {198 306 277 374} ;# Box
+ $w.c create rect $xy -outline $::C(fg) -width 1.5p -fill $color -tag I7z
+ $w.c lower I7z
+ set xy {275 343 230 349}
+ $w.c create line $xy -tag I7 -fill $::C(fg) -arrow last \
+ -arrowshape {17.25p 17.25p 6p} -width 4.5p
+ set xy {225 324} ;# On button
+ $w.c create oval [box {*}$xy 3] -fill $::C(fg) -outline $::C(fg)
+ set xy {218 323} ;# On text
+ set font {Times 8}
+ $w.c create text $xy -text "on" -anchor e -fill $::C(fg) -font $font
+ set xy {225 350} ;# Off button
+ $w.c create oval [box {*}$xy 3] -fill $::C(fg) -outline $::C(fg)
+ set xy {218 349} ;# Off button
+ $w.c create text $xy -text "off" -anchor e -fill $::C(fg) -font $font
+}
+proc Move7 {w {step {}}} {
+ set step [GetStep 7 $step]
+ set numsteps 30
+ if {$step > $numsteps} {
+ return 0
+ }
+ set beta [expr {30.0 / $numsteps}]
+ RotateItem $w I7 [scl 275] [scl 343] $beta
+
+ return [expr {$step == $numsteps ? 3 : 1}]
+}
+
+# Electricity to the fan
+proc Draw8 {w} {
+ Sine $w 271 248 271 306 5 8 -tag I8_s -fill $::C(8) -width 2.25p
+}
+proc Move8 {w {step {}}} {
+ set step [GetStep 8 $step]
+
+ if {$step > 3} {
+ return 0
+ }
+ if {$step == 0} {
+ Sparkle $w [Anchor $w I8_s s] I8
+ return 1
+
+ } elseif {$step == 1} {
+ MoveAbs $w I8 [Anchor $w I8_s c]
+ } elseif {$step == 2} {
+ MoveAbs $w I8 [Anchor $w I8_s n]
+ } else {
+ $w.c delete I8
+ }
+ return [expr {$step == 2 ? 3 : 1}]
+}
+
+# Fan
+proc Draw9 {w} {
+ set color $::C(9)
+ set xy {266 194 310 220}
+ $w.c create oval $xy -outline $color -fill $color
+ set xy {280 209 296 248}
+ $w.c create oval $xy -outline $color -fill $color
+ set xy {288 249 252 249 260 240 280 234 296 234 316 240 324 249 288 249}
+ $w.c create poly $xy -fill $color -smooth 1
+
+ set xy {248 205 265 214 264 205 265 196} ;# Spinner
+ $w.c create poly $xy -fill $color
+
+ set xy {255 206 265 234} ;# Fan blades
+ $w.c create oval $xy -fill {} -outline $::C(fg) -width 2.25p -tag I9_0
+ set xy {255 176 265 204}
+ $w.c create oval $xy -fill {} -outline $::C(fg) -width 2.25p -tag I9_0
+ set xy {255 206 265 220}
+ $w.c create oval $xy -fill {} -outline $::C(fg) -width 0.75p -tag I9_1
+ set xy {255 190 265 204}
+ $w.c create oval $xy -fill {} -outline $::C(fg) -width 0.75p -tag I9_1
+}
+proc Move9 {w {step {}}} {
+ set step [GetStep 9 $step]
+
+ if {$step & 1} {
+ $w.c itemconfig I9_0 -width 3p
+ $w.c itemconfig I9_1 -width 0.75p
+ $w.c lower I9_1 I9_0
+ } else {
+ $w.c itemconfig I9_0 -width 0.75p
+ $w.c itemconfig I9_1 -width 3p
+ $w.c lower I9_0 I9_1
+ }
+ if {$step == 0} {
+ return 3
+ }
+ return 1
+}
+
+# Boat
+proc Draw10 {w} {
+ set color $::C(10a)
+ set color2 $::C(10b)
+ set xy {191 230 233 230 233 178 191 178} ;# Sail
+ $w.c create poly $xy -fill $color -width 2.25p -outline $::C(fg) -tag I10
+ set xy [box 209 204 31] ;# Front
+ $w.c create arc $xy -outline {} -fill $color -style pie \
+ -start 120 -extent 120 -tag I10
+ $w.c create arc $xy -outline $::C(fg) -width 2.25p -style arc \
+ -start 120 -extent 120 -tag I10
+ set xy [box 249 204 31] ;# Back
+ $w.c create arc $xy -outline {} -fill $::C(bg) -width 2.25p -style pie \
+ -start 120 -extent 120 -tag I10
+ $w.c create arc $xy -outline $::C(fg) -width 2.25p -style arc \
+ -start 120 -extent 120 -tag I10
+
+ set xy {200 171 200 249} ;# Mast
+ $w.c create line $xy -fill $::C(fg) -width 2.25p -tag I10
+ set xy {159 234 182 234} ;# Bow sprit
+ $w.c create line $xy -fill $::C(fg) -width 2.25p -tag I10
+ set xy {180 234 180 251 220 251} ;# Hull
+ $w.c create line $xy -fill $::C(fg) -width 4.5p -tag I10
+
+ set xy {92 255 221 255} ;# Waves
+ Sine $w {*}$xy 2 25 -fill $color2 -width 0.75p -tag I10w
+
+ set xy [lrange [$w.c coords I10w] 4 end-4] ;# Water
+ set xy [concat $xy 222 266 222 277 99 277]
+ $w.c create poly $xy -fill $color2 -outline $color2
+ set xy {222 266 222 277 97 277 97 266} ;# Water bottom
+ $w.c create line $xy -fill $::C(fg) -width 2.25p
+
+ set xy [box 239 262 17]
+ $w.c create arc $xy -outline $::C(fg) -width 2.25p -style arc \
+ -start 95 -extent 103
+ set xy [box 76 266 21]
+ $w.c create arc $xy -outline $::C(fg) -width 2.25p -style arc -extent 190
+}
+proc Move10 {w {step {}}} {
+ set step [GetStep 10 $step]
+ set pos [scl {
+ {195 212} {193 212} {190 212} {186 212} {181 212} {176 212}
+ {171 212} {166 212} {161 212} {156 212} {151 212} {147 212} {142 212}
+ {137 212} {132 212 x} {127 212} {121 212} {116 212} {111 212}
+ }]
+
+ if {$step >= [llength $pos]} {
+ return 0
+ }
+ set where [lindex $pos $step]
+ MoveAbs $w I10 $where
+
+ if {[lindex $where 2] eq "x"} {
+ return 3
+ }
+ return 1
+}
+
+# 2nd ball drop
+proc Draw11 {w} {
+ set color $::C(11a)
+ set color2 $::C(11b)
+ set xy {23 264 55 591} ;# Color the down tube
+ $w.c create rect $xy -fill $color -outline {}
+ set xy [box 71 460 48] ;# Color the outer loop
+ $w.c create oval $xy -fill $color -outline {}
+
+ set xy {55 264 55 458} ;# Top right side
+ $w.c create line $xy -fill $::C(fg) -width 2.25p
+ set xy {55 504 55 591} ;# Bottom right side
+ $w.c create line $xy -fill $::C(fg) -width 2.25p
+ set xy [box 71 460 48] ;# Outer loop
+ $w.c create arc $xy -outline $::C(fg) -width 2.25p -style arc \
+ -start 110 -extent -290 -tag I11i
+ set xy [box 71 460 16] ;# Inner loop
+ $w.c create oval $xy -outline $::C(fg) -fill {} -width 2.25p -tag I11i
+ $w.c create oval $xy -outline $::C(fg) -fill $::C(bg) -width 2.25p
+
+ set xy {23 264 23 591} ;# Left side
+ $w.c create line $xy -fill $::C(fg) -width 2.25p
+ set xy [box 1 266 23] ;# Top left curve
+ $w.c create arc $xy -outline $::C(fg) -width 2.25p -style arc -extent 90
+
+ set xy [box 75 235 9] ;# The ball
+ $w.c create oval $xy -fill $color2 -outline {} -width 2.25p -tag I11
+}
+proc Move11 {w {step {}}} {
+ set step [GetStep 11 $step]
+ set pos [scl {
+ {75 235} {70 235} {65 237} {56 240} {46 247} {38 266} {38 296}
+ {38 333} {38 399} {38 475} {74 496} {105 472} {100 437} {65 423}
+ {-100 -100} {38 505} {38 527 x} {38 591}
+ }]
+
+ if {$step >= [llength $pos]} {
+ return 0
+ }
+ set where [lindex $pos $step]
+ MoveAbs $w I11 $where
+ if {[lindex $where 2] eq "x"} {
+ return 3
+ }
+ return 1
+}
+
+# Hand
+proc Draw12 {w} {
+ set xy {20 637 20 617 20 610 20 590 40 590 40 590 60 590 60 610 60 610}
+ lappend xy 60 610 65 620 60 631 ;# Thumb
+ lappend xy 60 631 60 637 60 662 60 669 52 669 56 669 50 669 50 662 50 637
+
+ set y0 637 ;# Bumps for fingers
+ set y1 645
+ for {set x 50} {$x > 20} {incr x -10} {
+ set x1 [expr {$x - 5}]
+ set x2 [expr {$x - 10}]
+ lappend xy $x $y0 $x1 $y1 $x2 $y0
+ }
+ $w.c create poly $xy -fill $::C(12) -outline $::C(fg) -smooth 1 -tag I12 \
+ -width 2.25p
+}
+proc Move12 {w {step {}}} {
+ set step [GetStep 12 $step]
+ set pos [scl {{42 641 x}}]
+ if {$step >= [llength $pos]} {
+ return 0
+ }
+
+ set where [lindex $pos $step]
+ MoveAbs $w I12 $where
+ if {[lindex $where 2] eq "x"} {
+ return 3
+ }
+ return 1
+}
+
+# Fax
+proc Draw13 {w} {
+ set color $::C(13a)
+ set xy {86 663 149 663 149 704 50 704 50 681 64 681 86 671}
+ set xy2 {784 663 721 663 721 704 820 704 820 681 806 681 784 671}
+ set radii {2 9 9 8 5 5 2}
+
+ RoundPoly $w.c $xy $radii -width 2.25p -outline $::C(fg) -fill $color
+ RoundPoly $w.c $xy2 $radii -width 2.25p -outline $::C(fg) -fill $color
+
+ set xy {56 677}
+ $w.c create rect [box {*}$xy 4] -fill {} -outline $::C(fg) -width 2.25p \
+ -tag I13
+ set xy {809 677}
+ $w.c create rect [box {*}$xy 4] -fill {} -outline $::C(fg) -width 2.25p \
+ -tag I13R
+
+ set xy {112 687} ;# Label
+ $w.c create text $xy -text "FAX" -fill $::C(fg) -font {Times 12 bold}
+ set xy {762 687}
+ $w.c create text $xy -text "FAX" -fill $::C(fg) -font {Times 12 bold}
+
+ set xy {138 663 148 636 178 636} ;# Paper guide
+ $w.c create line $xy -smooth 1 -fill $::C(fg) -width 2.25p
+ set xy {732 663 722 636 692 636}
+ $w.c create line $xy -smooth 1 -fill $::C(fg) -width 2.25p
+
+ Sine $w 149 688 720 688 5 15 -tag I13_s -fill $::C(fg) -width 2.25p
+}
+proc Move13 {w {step {}}} {
+ set step [GetStep 13 $step]
+ set numsteps 7
+
+ if {$step == $numsteps+2} {
+ MoveAbs $w I13_star {-100 -100}
+ $w.c itemconfig I13R -fill $::C(13b) -width 1.5p
+ return 2
+ }
+ if {$step == 0} { ;# Button down
+ $w.c delete I13
+ Sparkle $w {-100 -100} I13_star ;# Create off screen
+ return 1
+ }
+ lassign [Anchor $w I13_s w] x0 y0
+ lassign [Anchor $w I13_s e] x1 y1
+ set x [expr {$x0 + ($x1-$x0) * ($step - 1) / double($numsteps)}]
+ MoveAbs $w I13_star [list $x $y0]
+ return 1
+}
+
+# Paper in fax
+proc Draw14 {w} {
+ set color $::C(14)
+ set xy {102 661 113 632 130 618} ;# Left paper edge
+ $w.c create line $xy -smooth 1 -fill $color -width 2.25p -tag I14L_0
+ set xy {148 629 125 640 124 662} ;# Right paper edge
+ $w.c create line $xy -smooth 1 -fill $color -width 2.25p -tag I14L_1
+ Draw14a $w L
+
+ set xy {
+ 768.0 662.5 767.991316225 662.433786215 767.926187912 662.396880171
+ }
+ $w.c create line $xy -smooth 1 -fill $color -width 2.25p -tag I14R_0
+ $w.c lower I14R_0
+ # NB. these numbers are VERY sensitive, you must start with final size
+ # and shrink down to get the values
+ set xy {
+ 745.947897349 662.428358855 745.997829056 662.452239237 746.0 662.5
+ }
+ $w.c create line $xy -smooth 1 -fill $color -width 2.25p -tag I14R_1
+ $w.c lower I14R_1
+}
+proc Draw14a {w side} {
+ set color $::C(14)
+ set xy [$w.c coords I14${side}_0]
+ set xy2 [$w.c coords I14${side}_1]
+ lassign $xy x0 y0 x1 y1 x2 y2
+ lassign $xy2 x3 y3 x4 y4 x5 y5
+ set zz [concat \
+ $x0 $y0 $x0 $y0 $xy $x2 $y2 $x2 $y2 \
+ $x3 $y3 $x3 $y3 $xy2 $x5 $y5 $x5 $y5]
+ $w.c delete I14$side
+ $w.c create poly $zz -tag I14$side -smooth 1 -fill $color -outline $color \
+ -width 2.25p
+ $w.c lower I14$side
+}
+proc Move14 {w {step {}}} {
+ set step [GetStep 14 $step]
+
+ # Paper going down
+ set sc [expr {.9 - .05*$step}]
+ if {$sc < .3} {
+ $w.c delete I14L
+ return 0
+ }
+
+ lassign [$w.c coords I14L_0] Ox Oy
+ $w.c scale I14L_0 $Ox $Oy $sc $sc
+ lassign [lrange [$w.c coords I14L_1] end-1 end] Ox Oy
+ $w.c scale I14L_1 $Ox $Oy $sc $sc
+ Draw14a $w L
+
+ # Paper going up
+ set sc [expr {.35 + .05*$step}]
+ set sc [expr {1 / $sc}]
+
+ lassign [$w.c coords I14R_0] Ox Oy
+ $w.c scale I14R_0 $Ox $Oy $sc $sc
+ lassign [lrange [$w.c coords I14R_1] end-1 end] Ox Oy
+ $w.c scale I14R_1 $Ox $Oy $sc $sc
+ Draw14a $w R
+
+ return [expr {$step == 10 ? 3 : 1}]
+}
+
+# Light beam
+proc Draw15 {w} {
+ set color $::C(15a)
+ set xy {824 599 824 585 820 585 829 585}
+ $w.c create line $xy -fill $::C(fg) -width 2.25p -tag I15a
+ set xy {789 599 836 643}
+ $w.c create rect $xy -fill $color -outline $::C(fg) -width 2.25p
+ set xy {778 610 788 632}
+ $w.c create rect $xy -fill $color -outline $::C(fg) -width 2.25p
+ set xy {766 617 776 625}
+ $w.c create rect $xy -fill $color -outline $::C(fg) -width 2.25p
+
+ set xy {633 600 681 640}
+ $w.c create rect $xy -fill $color -outline $::C(fg) -width 2.25p
+ set xy {635 567 657 599}
+ $w.c create rect $xy -fill $color -outline $::C(fg) -width 2.25p
+ set xy {765 557 784 583}
+ $w.c create rect $xy -fill $color -outline $::C(fg) -width 2.25p
+
+ Sine $w 658 580 765 580 3 15 -tag I15_s -fill $::C(fg) -width 2.25p
+}
+proc Move15a {w} {
+ set color $::C(15b)
+ $w.c scale I15a [scl 824] [scl 599] 1 .3 ;# Button down
+ set xy [scl {765 621 681 621}]
+ $w.c create line $xy -dash "-" -width 2.25p -fill $color -tag I15
+}
+proc Move15 {w {step {}}} {
+ set step [GetStep 15 $step]
+ set numsteps 6
+
+ if {$step == $numsteps+2} {
+ MoveAbs $w I15_star {-100 -100}
+ return 2
+ }
+ if {$step == 0} { ;# Break the light beam
+ Sparkle $w {-100 -100} I15_star
+ set xy [scl {765 621 745 621}]
+ $w.c coords I15 $xy
+ return 1
+ }
+ lassign [Anchor $w I15_s w] x0 y0
+ lassign [Anchor $w I15_s e] x1 y1
+ set x [expr {$x0 + ($x1-$x0) * ($step - 1) / double($numsteps)}]
+ MoveAbs $w I15_star [list $x $y0]
+ return 1
+}
+
+# Bell
+proc Draw16 {w} {
+ set color $::C(16)
+ set xy {722 485 791 556}
+ $w.c create rect $xy -fill {} -outline $::C(fg) -width 2.25p
+ set xy [box 752 515 25] ;# Bell
+ $w.c create oval $xy -fill $color -outline black -tag I16b -width 1.5p
+ set xy [box 752 515 5] ;# Bell button
+ $w.c create oval $xy -fill black -outline black -tag I16b
+
+ set xy {784 523 764 549} ;# Clapper
+ $w.c create line $xy -width 2.25p -tag I16c -fill $::C(fg)
+ set xy [box 784 523 4]
+ $w.c create oval $xy -fill $::C(fg) -outline $::C(fg) -tag I16d
+}
+proc Move16 {w {step {}}} {
+ set step [GetStep 16 $step]
+
+ # Note: we never stop
+ lassign [scl {760 553}] Ox Oy
+ if {$step & 1} {
+ set beta 12
+ $w.c move I16b 2.25p 0
+ } else {
+ set beta -12
+ $w.c move I16b -2.25p 0
+ }
+ RotateItem $w I16c $Ox $Oy $beta
+ RotateItem $w I16d $Ox $Oy $beta
+
+ return [expr {$step == 1 ? 3 : 1}]
+}
+
+# Cat
+proc Draw17 {w} {
+ set color $::C(17)
+
+ set xy {584 556 722 556}
+ $w.c create line $xy -fill $::C(fg) -width 2.25p
+ set xy {584 485 722 485}
+ $w.c create line $xy -fill $::C(fg) -width 2.25p
+
+ set xy {664 523 717 549} ;# Body
+ $w.c create arc $xy -outline $::C(fg) -fill $color -width 2.25p \
+ -style chord -start 128 -extent -260 -tag I17
+
+ set xy {709 554 690 543} ;# Paw
+ $w.c create oval $xy -outline $::C(fg) -fill $color -width 2.25p -tag I17
+ set xy {657 544 676 555}
+ $w.c create oval $xy -outline $::C(fg) -fill $color -width 2.25p -tag I17
+
+ set xy [box 660 535 15] ;# Lower face
+ $w.c create arc $xy -outline $::C(fg) -width 2.25p -style arc \
+ -start 150 -extent 240 -tag I17_
+ $w.c create arc $xy -outline {} -fill $color -width 0.75p -style chord \
+ -start 150 -extent 240 -tag I17_
+ set xy {674 529 670 513 662 521 658 521 650 513 647 529} ;# Ears
+ $w.c create line $xy -fill $::C(fg) -width 2.25p -tag I17_
+ $w.c create poly $xy -fill $color -outline {} -width 0.75p -tag {I17_ I17_c}
+ set xy {652 542 628 539} ;# Whiskers
+ $w.c create line $xy -fill $::C(fg) -width 2.25p -tag I17_
+ set xy {652 543 632 545}
+ $w.c create line $xy -fill $::C(fg) -width 2.25p -tag I17_
+ set xy {652 546 632 552}
+ $w.c create line $xy -fill $::C(fg) -width 2.25p -tag I17_
+
+ set xy {668 543 687 538}
+ $w.c create line $xy -fill $::C(fg) -width 2.25p -tag {I17_ I17w}
+ set xy {668 544 688 546}
+ $w.c create line $xy -fill $::C(fg) -width 2.25p -tag {I17_ I17w}
+ set xy {668 547 688 553}
+ $w.c create line $xy -fill $::C(fg) -width 2.25p -tag {I17_ I17w}
+
+ set xy {649 530 654 538 659 530} ;# Left eye
+ $w.c create line $xy -fill $::C(fg) -width 1.5p -smooth 1 -tag I17
+ set xy {671 530 666 538 661 530} ;# Right eye
+ $w.c create line $xy -fill $::C(fg) -width 1.5p -smooth 1 -tag I17
+ set xy {655 543 660 551 665 543} ;# Mouth
+ $w.c create line $xy -fill $::C(fg) -width 1.5p -smooth 1 -tag I17
+}
+proc Move17 {w {step {}}} {
+ set step [GetStep 17 $step]
+
+ if {$step == 0} {
+ $w.c delete I17 ;# Delete most of the cat
+ set xy [scl {655 543 660 535 665 543}] ;# Mouth
+ $w.c create line $xy -fill $::C(fg) -width 2.25p -smooth 1 -tag I17_
+ set xy [box [scl 654] [scl 530] [scl 4]] ;# Left eye
+ $w.c create oval $xy -outline $::C(fg) -width 2.25p -fill {} -tag I17_
+ set xy [box [scl 666] [scl 530] [scl 4]] ;# Right eye
+ $w.c create oval $xy -outline $::C(fg) -width 2.25p -fill {} -tag I17_
+
+ $w.c move I17_ 0 -15p ;# Move face up
+ set xy [scl {652 528 652 554}] ;# Front leg
+ $w.c create line $xy -fill $::C(fg) -width 2.25p -tag I17_
+ set xy [scl {670 528 670 554}] ;# 2nd front leg
+ $w.c create line $xy -fill $::C(fg) -width 2.25p -tag I17_
+
+ set xy [scl {
+ 675 506 694 489 715 513 715 513 715 513 716 525 716 525 716 525
+ 706 530 695 530 679 535 668 527 668 527 668 527 675 522 676 517
+ 677 512
+ }] ;# Body
+ $w.c create poly $xy -fill [$w.c itemcget I17_c -fill] \
+ -outline $::C(fg) -width 2.25p -smooth 1 -tag I17_
+ set xy [scl {716 514 716 554}] ;# Back leg
+ $w.c create line $xy -fill $::C(fg) -width 2.25p -tag I17_
+ set xy [scl {694 532 694 554}] ;# 2nd back leg
+ $w.c create line $xy -fill $::C(fg) -width 2.25p -tag I17_
+ set xy [scl {715 514 718 506 719 495 716 488}] ;# Tail
+ $w.c create line $xy -fill $::C(fg) -width 2.25p -smooth 1 -tag I17_
+
+ $w.c raise I17w ;# Make whiskers visible
+ $w.c move I17_ -3.75p 0 ;# Move away from wall a bit
+ return 2
+ }
+ return 0
+}
+
+# Sling shot
+proc Draw18 {w} {
+ set color $::C(18)
+ set xy {721 506 627 506} ;# Sling hold
+ $w.c create line $xy -width 3p -fill $::C(fg) -tag I18
+
+ set xy {607 500 628 513} ;# Sling rock
+ $w.c create oval $xy -fill $color -outline {} -tag I18a
+
+ set xy {526 513 606 507 494 502} ;# Sling band
+ $w.c create line $xy -fill $::C(fg) -width 3p -tag I18b
+ set xy { 485 490 510 540 510 575 510 540 535 491 } ;# Sling
+ $w.c create line $xy -fill $::C(fg) -width 4.5p
+}
+proc Move18 {w {step {}}} {
+ set step [GetStep 18 $step]
+
+ set pos [scl {
+ {587 506} {537 506} {466 506} {376 506} {266 506 x} {136 506}
+ {16 506} {-100 -100}
+ }]
+
+ set b(0) [scl {490 502 719 507 524 512}] ;# Band collapsing
+ set b(1) [scl {
+ 491 503 524 557 563 505 559 496 546 506 551 525 553 536 538 534
+ 532 519 529 499
+ }]
+ set b(2) [scl {491 503 508 563 542 533 551 526 561 539 549 550 530 500}]
+ set b(3) [scl {491 503 508 563 530 554 541 562 525 568 519 544 530 501}]
+
+ if {$step >= [llength $pos]} {
+ return 0
+ }
+
+ if {$step == 0} {
+ $w.c delete I18
+ $w.c itemconfig I18b -smooth 1
+ }
+ if {[info exists b($step)]} {
+ $w.c coords I18b $b($step)
+ }
+
+ set where [lindex $pos $step]
+ MoveAbs $w I18a $where
+ if {[lindex $where 2] eq "x"} {
+ return 3
+ }
+ return 1
+}
+
+# Water pipe
+proc Draw19 {w} {
+ set color $::C(19)
+ set xx {249 181 155 118 86 55 22 0}
+ foreach {x1 x2} $xx {
+ $w.c create rect $x1 453 $x2 467 -fill $color -outline {} -tag I19
+ $w.c create line $x1 453 $x2 453 -fill $::C(fg) -width 0.75p;# Pipe top
+ $w.c create line $x1 467 $x2 467 -fill $::C(fg) -width 0.75p;# Pipe btm
+ }
+ $w.c raise I11i
+
+ set xy [box 168 460 16] ;# Bulge by the joint
+ $w.c create oval $xy -fill $color -outline {}
+ $w.c create arc $xy -outline $::C(fg) -width 0.75p -style arc \
+ -start 21 -extent 136
+ $w.c create arc $xy -outline $::C(fg) -width 0.75p -style arc \
+ -start -21 -extent -130
+
+ set xy {249 447 255 473} ;# First joint 26x6
+ $w.c create rect $xy -fill $color -outline $::C(fg) -width 0.75p
+
+ set xy [box 257 433 34] ;# Bend up
+ $w.c create arc $xy -outline {} -fill $color -width 0.75p \
+ -style pie -start 0 -extent -91
+ $w.c create arc $xy -outline $::C(fg) -width 0.75p \
+ -style arc -start 0 -extent -90
+ set xy [box 257 433 20]
+ $w.c create arc $xy -outline {} -fill $::C(bg) -width 1 \
+ -style pie -start 0 -extent -92
+ $w.c create arc $xy -outline $::C(fg) -width 0.75p \
+ -style arc -start 0 -extent -90
+ set xy [box 257 421 34] ;# Bend left
+ $w.c create arc $xy -outline {} -fill $color -width 0.75p \
+ -style pie -start 1 -extent 91
+ $w.c create arc $xy -outline $::C(fg) -width 0.75p \
+ -style arc -start 0 -extent 90
+ set xy [box 257 421 20]
+ $w.c create arc $xy -outline {} -fill $::C(bg) -width 0.75p \
+ -style pie -start 0 -extent 90
+ $w.c create arc $xy -outline $::C(fg) -width 0.75p \
+ -style arc -start 0 -extent 90
+ set xy [box 243 421 34] ;# Bend down
+ $w.c create arc $xy -outline {} -fill $color -width 0.75p \
+ -style pie -start 90 -extent 90
+ $w.c create arc $xy -outline $::C(fg) -width 0.75p \
+ -style arc -start 90 -extent 90
+ set xy [box 243 421 20]
+ $w.c create arc $xy -outline {} -fill $::C(bg) -width 0.75p \
+ -style pie -start 90 -extent 90
+ $w.c create arc $xy -outline $::C(fg) -width 0.75p \
+ -style arc -start 90 -extent 90
+
+ set xy {270 427 296 433} ;# 2nd joint bottom
+ $w.c create rect $xy -fill $color -outline $::C(fg) -width 0.75p
+ set xy {270 421 296 427} ;# 2nd joint top
+ $w.c create rect $xy -fill $color -outline $::C(fg) -width 0.75p
+ set xy {249 382 255 408} ;# Third joint right
+ $w.c create rect $xy -fill $color -outline $::C(fg) -width 0.75p
+ set xy {243 382 249 408} ;# Third joint left
+ $w.c create rect $xy -fill $color -outline $::C(fg) -width 0.75p
+ set xy {203 420 229 426} ;# Last joint
+ $w.c create rect $xy -fill $color -outline $::C(fg) -width 0.75p
+
+ set xy [box 168 460 6] ;# Handle joint
+ $w.c create oval $xy -fill $::C(fg) -outline {} -tag I19a
+ set xy {168 460 168 512} ;# Handle bar
+ $w.c create line $xy -fill $::C(fg) -width 3.75p -tag I19b
+}
+proc Move19 {w {step {}}} {
+ set step [GetStep 19 $step]
+
+ set angles {30 30 30}
+ if {$step == [llength $angles]} {
+ return 2
+ }
+
+ RotateItem $w I19b {*}[Centroid $w I19a] [lindex $angles $step]
+ return 1
+}
+
+# Water pouring
+proc Draw20 {w} {
+}
+proc Move20 {w {step {}}} {
+ set step [GetStep 20 $step]
+
+ set pos [scl {451 462 473 484 496 504 513 523 532}]
+ set freq {20 40 40 40 40 40 40 40 40}
+ set pos [scl {
+ {451 20} {462 40} {473 40} {484 40} {496 40} {504 40} {513 40}
+ {523 40} {532 40 x}
+ }]
+ if {$step >= [llength $pos]} {
+ return 0
+ }
+
+ $w.c delete I20
+ set where [lindex $pos $step]
+ lassign $where y f
+ H2O $w $y $f
+ if {[lindex $where 2] eq "x"} {
+ return 3
+ }
+ return 1
+}
+proc H2O {w y f} {
+ set color $::C(20)
+ $w.c delete I20
+
+ Sine $w [scl 208] [scl 428] [scl 208] $y 4 $f -tag {I20 I20s} \
+ -width 2.25p -fill $color -smooth 1
+ $w.c create line [$w.c coords I20s] -width 2.25p -fill $color -smooth 1 \
+ -tag {I20 I20a}
+ $w.c create line [$w.c coords I20s] -width 2.25p -fill $color -smooth 1 \
+ -tag {I20 I20b}
+ $w.c move I20a 6p 0
+ $w.c move I20b 12p 0
+}
+
+# Bucket
+proc Draw21 {w} {
+ set color $::C(21)
+ set xy {217 451 244 490} ;# Right handle
+ $w.c create line $xy -fill $::C(fg) -width 1.5p -tag I21_a
+ set xy {201 467 182 490} ;# Left handle
+ $w.c create line $xy -fill $::C(fg) -width 1.5p -tag I21_a
+
+ set xy {245 490 237 535} ;# Right side
+ set xy2 {189 535 181 490} ;# Left side
+ $w.c create poly [concat $xy $xy2] -fill $color -outline {} \
+ -tag {I21 I21f}
+ $w.c create line $xy -fill $::C(fg) -width 1.5p -tag I21
+ $w.c create line $xy2 -fill $::C(fg) -width 1.5p -tag I21
+
+ set xy {182 486 244 498} ;# Top
+ $w.c create oval $xy -fill $color -outline {} -width 1.5p -tag {I21 I21f}
+ $w.c create oval $xy -fill {} -outline $::C(fg) -width 1.5p -tag {I21 I21t}
+ set xy {189 532 237 540} ;# Bottom
+ $w.c create oval $xy -fill $color -outline $::C(fg) -width 1.5p \
+ -tag {I21 I21b}
+}
+proc Move21 {w {step {}}} {
+ set step [GetStep 21 $step]
+
+ set numsteps 30
+ if {$step >= $numsteps} {
+ return 0
+ }
+
+ lassign [$w.c coords I21b] x1 y1 x2 y2
+ #lassign [$w.c coords I21t] X1 Y1 X2 Y2
+ lassign [scl {183 492 243 504}] X1 Y1 X2 Y2
+
+ set f [expr {$step / double($numsteps)}]
+ set y2 [expr {$y2 - [scl 3]}]
+ set xx1 [expr {$x1 + ($X1 - $x1) * $f}]
+ set yy1 [expr {$y1 + ($Y1 - $y1) * $f}]
+ set xx2 [expr {$x2 + ($X2 - $x2) * $f}]
+ set yy2 [expr {$y2 + ($Y2 - $y2) * $f}]
+ #H2O $w $yy1 40
+
+ $w.c itemconfig I21b -fill $::C(20)
+ $w.c delete I21w
+ $w.c create poly $x2 $y2 $x1 $y1 $xx1 $yy1 $xx2 $yy1 -tag {I21 I21w} \
+ -outline {} -fill $::C(20)
+ $w.c lower I21w I21
+ $w.c raise I21b
+ $w.c lower I21f
+
+ return [expr {$step == $numsteps-1 ? 3 : 1}]
+}
+
+# Bucket drop
+proc Draw22 {w} {
+}
+proc Move22 {w {step {}}} {
+ set step [GetStep 22 $step]
+ set pos [scl {{213 513} {213 523} {213 543 x} {213 583} {213 593}}]
+
+ if {$step == 0} {$w.c itemconfig I21f -fill $::C(22)}
+ if {$step >= [llength $pos]} {
+ return 0
+ }
+ set where [lindex $pos $step]
+ MoveAbs $w I21 $where
+ H2O $w [lindex $where 1] 40
+ $w.c delete I21_a ;# Delete handles
+
+ if {[lindex $where 2] eq "x"} {
+ return 3
+ }
+ return 1
+}
+
+# Blow dart
+proc Draw23 {w} {
+ set color $::C(23a)
+ set color2 $::C(23b)
+ set color3 $::C(23c)
+
+ set xy {185 623 253 650} ;# Block
+ $w.c create rect $xy -fill black -outline $::C(fg) -width 1.5p -tag I23a
+ set xy {187 592 241 623} ;# Balloon
+ $w.c create oval $xy -outline {} -fill $color -tag I23b
+ $w.c create arc $xy -outline $::C(fg) -width 2.25p -tag I23b \
+ -style arc -start 12 -extent 336
+ set xy {239 604 258 589 258 625 239 610} ;# Balloon nozzle
+ $w.c create poly $xy -outline {} -fill $color -tag I23b
+ $w.c create line $xy -fill $::C(fg) -width 2.25p -tag I23b
+
+ set xy {285 611 250 603} ;# Dart body
+ $w.c create oval $xy -fill $color2 -outline $::C(fg) -width 2.25p -tag I23d
+ set xy {249 596 249 618 264 607 249 596} ;# Dart tail
+ $w.c create poly $xy -fill $color3 -outline $::C(fg) -width 2.25p -tag I23d
+ set xy {249 607 268 607} ;# Dart detail
+ $w.c create line $xy -fill $::C(fg) -width 2.25p -tag I23d
+ set xy {285 607 305 607} ;# Dart needle
+ $w.c create line $xy -fill $::C(fg) -width 2.25p -tag I23d
+}
+proc Move23 {w {step {}}} {
+ set step [GetStep 23 $step]
+
+ set pos [scl {
+ {277 607} {287 607} {307 607 x} {347 607} {407 607} {487 607}
+ {587 607} {687 607} {787 607} {-100 -100}
+ }]
+
+ if {$step >= [llength $pos]} {
+ return 0
+ }
+ if {$step <= 1} {
+ $w.c scale I23b {*}[Anchor $w I23a n] .9 .5
+ }
+ set where [lindex $pos $step]
+ MoveAbs $w I23d $where
+
+ if {[lindex $where 2] eq "x"} {
+ return 3
+ }
+ return 1
+}
+
+# Balloon
+proc Draw24 {w} {
+ set color $::C(24a)
+ set xy {366 518 462 665} ;# Balloon
+ $w.c create oval $xy -fill $color -outline $::C(fg) -width 2.25p -tag I24
+ set xy {414 666 414 729} ;# String
+ $w.c create line $xy -fill $::C(fg) -width 2.25p -tag I24
+ set xy {410 666 404 673 422 673 418 666} ;# Nozzle
+ $w.c create poly $xy -fill $color -outline $::C(fg) -width 2.25p -tag I24
+
+ set xy {387 567 390 549 404 542} ;# Reflections
+ $w.c create line $xy -fill $::C(fg) -smooth 1 -width 1.5p -tag I24
+ set xy {395 568 399 554 413 547}
+ $w.c create line $xy -fill $::C(fg) -smooth 1 -width 1.5p -tag I24
+ set xy {403 570 396 555 381 553}
+ $w.c create line $xy -fill $::C(fg) -smooth 1 -width 1.5p -tag I24
+ set xy {408 564 402 547 386 545}
+ $w.c create line $xy -fill $::C(fg) -smooth 1 -width 1.5p -tag I24
+}
+proc Move24 {w {step {}}} {
+ global S Dims
+ set step [GetStep 24 $step]
+
+ if {$step > 4} {
+ return 0
+ } elseif {$step == 4} {
+ return 2
+ }
+
+ if {$step == 0} {
+ $w.c delete I24 ;# Exploding balloon
+ set xy [scl {
+ 347 465 361 557 271 503 272 503 342 574 259 594 259 593 362 626
+ 320 737 320 740 398 691 436 738 436 739 476 679 528 701 527 702
+ 494 627 548 613 548 613 480 574 577 473 577 473 474 538 445 508
+ 431 441 431 440 400 502 347 465 347 465
+ }]
+ $w.c create poly $xy -tag I24 -fill $::C(24b) -outline $::C(24a) \
+ -width 7.5p -smooth 1
+ set msg [subst $S(message)]
+ $w.c create text [Centroid $w I24] -text $msg -tag {I24 I24t} \
+ -fill $::C(24c) -justify center -font {Times 18 bold}
+ return 1
+ }
+
+ $w.c itemconfig I24t -font [list Times [expr {18 + 6*$step}] bold]
+ $w.c move I24 $Dims(MovX) $Dims(MovY)
+ $w.c scale I24 {*}[Centroid $w I24] 1.25 1.25
+ return 1
+}
+
+# Displaying the message
+proc Move25 {w {step {}}} {
+ global S
+ set step [GetStep 25 $step]
+ if {$step == 0} {
+ set ::XY(25) [clock clicks -milliseconds]
+ return 1
+ }
+ set elapsed [expr {[clock clicks -milliseconds] - $::XY(25)}]
+ if {$elapsed < 5000} {
+ return 1
+ }
+ return 2
+}
+
+# Collapsing balloon
+proc Move26 {w {step {}}} {
+ global S Dims
+ set step [GetStep 26 $step]
+
+ if {$step >= 3} {
+ $w.c delete I24 I26
+ $w.c create text $Dims(MsgX) $Dims(MsgY) -anchor s -tag I26 \
+ -fill $::C(26) -text "click to continue" -font {Times 24 bold}
+ bind $w.c <Button-1> [list Reset $w]
+ return 4
+ }
+
+ $w.c scale I24 {*}[Centroid $w I24] .8 .8
+ $w.c move I24 0 45p
+ $w.c itemconfig I24t -font [list Times [expr {30 - 6*$step}] bold]
+ return 1
+}
+
+################################################################
+#
+# Helper functions
+#
+
+proc box {x y r} {
+ return [list [expr {$x-$r}] [expr {$y-$r}] [expr {$x+$r}] [expr {$y+$r}]]
+}
+
+proc MoveAbs {w item xy} {
+ lassign $xy x y
+ lassign [Centroid $w $item] Ox Oy
+ set dx [expr {$x - $Ox}]
+ set dy [expr {$y - $Oy}]
+ $w.c move $item $dx $dy
+}
+
+proc RotateItem {w item Ox Oy beta} {
+ set xy [$w.c coords $item]
+ set xy2 {}
+ foreach {x y} $xy {
+ lappend xy2 {*}[RotateC $x $y $Ox $Oy $beta]
+ }
+ $w.c coords $item $xy2
+}
+
+proc RotateC {x y Ox Oy beta} {
+ # rotates vector (Ox,Oy)->(x,y) by beta degrees clockwise
+
+ set x [expr {$x - $Ox}] ;# Shift to origin
+ set y [expr {$y - $Oy}]
+
+ set beta [expr {$beta * atan(1) * 4 / 180.0}] ;# Radians
+ set xx [expr {$x * cos($beta) - $y * sin($beta)}] ;# Rotate
+ set yy [expr {$x * sin($beta) + $y * cos($beta)}]
+
+ set xx [expr {$xx + $Ox}] ;# Shift back
+ set yy [expr {$yy + $Oy}]
+
+ return [list $xx $yy]
+}
+
+proc Reset {w} {
+ global S
+ DrawAll $w
+ bind $w.c <Button-1> {}
+ set S(mode) $::MSTART
+ set S(active) 0
+}
+
+# Each Move## keeps its state info in STEP, this retrieves and increments it
+proc GetStep {who step} {
+ global STEP
+ if {$step ne ""} {
+ set STEP($who) $step
+ } elseif {![info exists STEP($who)] || $STEP($who) eq ""} {
+ set STEP($who) 0
+ } else {
+ incr STEP($who)
+ }
+ return $STEP($who)
+}
+
+proc ResetStep {} {
+ global STEP
+ set ::S(cnt) 0
+ foreach a [array names STEP] {
+ set STEP($a) ""
+ }
+}
+
+proc Sine {w x0 y0 x1 y1 amp freq args} {
+ set PI [expr {4 * atan(1)}]
+ set step 2
+ set xy {}
+ if {$y0 == $y1} { ;# Horizontal
+ for {set x $x0} {$x <= $x1} {incr x $step} {
+ set beta [expr {($x - $x0) * 2 * $PI / $freq}]
+ set y [expr {$y0 + $amp * sin($beta)}]
+ lappend xy $x $y
+ }
+ } else {
+ for {set y $y0} {$y <= $y1} {incr y $step} {
+ set beta [expr {($y - $y0) * 2 * $PI / $freq}]
+ set x [expr {$x0 + $amp * sin($beta)}]
+ lappend xy $x $y
+ }
+ }
+ return [$w.c create line $xy {*}$args]
+}
+
+proc RoundRect {w xy radius args} {
+ lassign $xy x0 y0 x3 y3
+ set r [winfo pixels $w.c $radius]
+ set d [expr {2 * $r}]
+
+ # Make sure that the radius of the curve is less than 3/8 size of the box!
+ set maxr 0.75
+ if {$d > $maxr * ($x3 - $x0)} {
+ set d [expr {$maxr * ($x3 - $x0)}]
+ }
+ if {$d > $maxr * ($y3 - $y0)} {
+ set d [expr {$maxr * ($y3 - $y0)}]
+ }
+
+ set x1 [expr { $x0 + $d }]
+ set x2 [expr { $x3 - $d }]
+ set y1 [expr { $y0 + $d }]
+ set y2 [expr { $y3 - $d }]
+
+ set xy [list $x0 $y0 $x1 $y0 $x2 $y0 $x3 $y0 $x3 $y1 $x3 $y2]
+ lappend xy $x3 $y3 $x2 $y3 $x1 $y3 $x0 $y3 $x0 $y2 $x0 $y1
+ return $xy
+}
+
+proc RoundPoly {canv xy radii args} {
+ set lenXY [llength $xy]
+ set lenR [llength $radii]
+ if {$lenXY != 2*$lenR} {
+ error "wrong number of vertices and radii"
+ }
+
+ set knots {}
+ lassign [lrange $xy end-1 end] x0 y0
+ lassign $xy x1 y1
+ lappend xy {*}[lrange $xy 0 1]
+
+ for {set i 0} {$i < $lenXY} {incr i 2} {
+ set radius [lindex $radii [expr {$i/2}]]
+ set r [winfo pixels $canv $radius]
+
+ lassign [lrange $xy [expr {$i + 2}] [expr {$i + 3}]] x2 y2
+ set z [_RoundPoly2 $x0 $y0 $x1 $y1 $x2 $y2 $r]
+ lappend knots {*}$z
+
+ lassign [list $x1 $y1] x0 y0
+ lassign [list $x2 $y2] x1 y1
+ }
+ set n [$canv create polygon $knots -smooth 1 {*}$args]
+ return $n
+}
+
+proc _RoundPoly2 {x0 y0 x1 y1 x2 y2 radius} {
+ set d [expr {2 * $radius}]
+ set maxr 0.75
+
+ set v1x [expr {$x0 - $x1}]
+ set v1y [expr {$y0 - $y1}]
+ set v2x [expr {$x2 - $x1}]
+ set v2y [expr {$y2 - $y1}]
+
+ set vlen1 [expr {sqrt($v1x*$v1x + $v1y*$v1y)}]
+ set vlen2 [expr {sqrt($v2x*$v2x + $v2y*$v2y)}]
+ if {$d > $maxr * $vlen1} {
+ set d [expr {$maxr * $vlen1}]
+ }
+ if {$d > $maxr * $vlen2} {
+ set d [expr {$maxr * $vlen2}]
+ }
+
+ lappend xy [expr {$x1 + $d * $v1x/$vlen1}] [expr {$y1 + $d * $v1y/$vlen1}]
+ lappend xy $x1 $y1
+ lappend xy [expr {$x1 + $d * $v2x/$vlen2}] [expr {$y1 + $d * $v2y/$vlen2}]
+
+ return $xy
+}
+
+proc Sparkle {w Oxy tag} {
+ set xy {299 283 298 302 295 314 271 331 239 310 242 292 256 274 281 273}
+ foreach {x y} $xy {
+ $w.c create line 271 304 $x $y -fill white -width 3 -tag $tag
+ }
+ MoveAbs $w $tag $Oxy
+}
+
+proc Centroid {w item} {
+ return [Anchor $w $item c]
+}
+
+proc Anchor {w item where} {
+ lassign [$w.c bbox $item] x1 y1 x2 y2
+ if {[string match *n* $where]} {
+ set y $y1
+ } elseif {[string match *s* $where]} {
+ set y $y2
+ } else {
+ set y [expr {($y1 + $y2) / 2.0}]
+ }
+ if {[string match *w* $where]} {
+ set x $x1
+ } elseif {[string match *e* $where]} {
+ set x $x2
+ } else {
+ set x [expr {($x1 + $x2) / 2.0}]
+ }
+ return [list $x $y]
+}
+
+proc scl {lst} {
+ global scaleFactor
+ set lst2 {}
+ foreach elem $lst {
+ set elem2 {}
+ set idx 0
+ foreach val $elem {
+ if {$idx < 2} {
+ set val [expr {round($val * $scaleFactor)}]
+ }
+ lappend elem2 $val
+ incr idx
+ }
+
+ lappend lst2 $elem2
+ }
+
+ return $lst2
+}
+
+# Simple placed dialog - stacked dialogs are not allowed,
+# the command does nothing if another grab already exists.
+
+proc PlacedDialog {w msg {labelFnt {Helvetica 10}}} {
+ if {[grab current] ne {}} {
+ return
+ }
+ destroy $w
+
+ frame $w -relief raised -bd 3p
+ label $w.lab -font $labelFnt -wraplength 3i -justify left -text $msg
+ ttk::button $w.but -text "OK" -underline 0 \
+ -command [list ClosePlacedDialog $w]
+
+ foreach key {Escape Return o O} {
+ bind $w.but "<KeyPress-${key}>" { ClosePlacedDialog [winfo parent %W] }
+ }
+ foreach child {{} .but .lab} {
+ bind $w$child <<NextWindow>> break
+ bind $w$child <<PrevWindow>> break
+ }
+
+ pack $w.lab -padx 10p -pady {10p 5p}
+ pack $w.but -padx 10p -pady {0p 10p}
+ place $w -anchor center -relx 0.5 -rely 0.5
+
+ set tl [winfo toplevel $w]
+ set ::PlacedDialogOldFocus [focus -lastfor $tl]
+ focus $w.but
+ grab set $w
+ return
+}
+
+proc ClosePlacedDialog {w} {
+ set tl [winfo toplevel $w]
+ if {![winfo exists $::PlacedDialogOldFocus]} {
+ set ::PlacedDialogOldFocus $tl
+ }
+ focus $::PlacedDialogOldFocus
+ set ::PlacedDialogOldFocus {}
+ grab release $w
+ destroy $w
+ return
+}
+
+
+DoDisplay $w
+Reset $w
+Go $w ;# Start everything going
+StartMessage $w ;# Message box at startup
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/goldberg.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/hello
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/hello (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/hello 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,22 @@
+#!/bin/sh
+# the next line restarts using wish \
+exec wish90 "$0" ${1+"$@"}
+
+# hello --
+# Simple Tk script to create a button that prints "Hello, world".
+# Click on the button to terminate the program.
+
+package require tk
+
+# 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
+
+# Local Variables:
+# mode: tcl
+# End:
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/hello
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/hscale.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/hscale.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/hscale.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,49 @@
+# hscale.tcl --
+#
+# This demonstration script shows an example with a horizontal scale.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+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
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+frame $w.frame -borderwidth 7.5p
+pack $w.frame -side top -fill x
+
+canvas $w.frame.canvas -width 37.5p -height 37.5p -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 213p -from 0 -to 250 \
+ -command "setWidth $w.frame.canvas" -tickinterval 50
+pack $w.frame.canvas -side top -expand yes -anchor s -fill x -padx 12p
+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
+
+ set scaleFactor [expr {$tk::scalingPct / 100.0}]
+ $w scale poly 0 0 $scaleFactor $scaleFactor
+ $w scale line 0 0 $scaleFactor $scaleFactor
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/hscale.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/icon.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/icon.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/icon.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,51 @@
+# icon.tcl --
+#
+# This demonstration script creates a toplevel window containing
+# buttons that display bitmaps instead of text.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+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
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+# Main widget program sets variable tk_demoDirectory
+image create bitmap flagup \
+ -file [file join $tk_demoDirectory images flagup.xbm] \
+ -maskfile [file join $tk_demoDirectory images flagup.xbm]
+image create bitmap flagdown \
+ -file [file join $tk_demoDirectory images flagdown.xbm] \
+ -maskfile [file join $tk_demoDirectory images flagdown.xbm]
+frame $w.frame -borderwidth 7.5p
+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_demoDirectory images letters.xbm] \
+ -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_demoDirectory images letters.xbm] \
+ -variable letters -value full
+radiobutton $w.frame.left.b4 \
+ -bitmap @[file join $tk_demoDirectory images noletter.xbm] \
+ -variable letters -value empty
+pack $w.frame.left.b3 $w.frame.left.b4 -side top -expand yes
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/icon.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/image1.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/image1.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/image1.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,44 @@
+# image1.tcl --
+#
+# This demonstration script displays two image widgets.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+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
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+# Main widget program sets variable tk_demoDirectory
+catch {image delete image1a}
+image create photo image1a -file [file join $tk_demoDirectory images earth.gif]
+catch {image delete image1b}
+image create photo image1b \
+ -file [file join $tk_demoDirectory images earthris.gif]
+
+# Create copies of the images just created, magnified according to the
+# display's DPI scaling level. Since the zooom factor must be an integer,
+# the copies will only be effectively magnified if $tk::scalingPct >= 200.
+set zoomFactor [expr {$tk::scalingPct / 100}]
+image create photo image1a2
+image1a2 copy image1a -zoom $zoomFactor
+image create photo image1b2
+image1b2 copy image1b -zoom $zoomFactor
+
+label $w.l1 -image image1a2 -bd 1 -relief sunken
+label $w.l2 -image image1b2 -bd 1 -relief sunken
+
+pack $w.l1 $w.l2 -side top -padx .5m -pady .5m
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/image1.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/image2.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/image2.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/image2.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,114 @@
+# image2.tcl --
+#
+# This demonstration script creates a simple collection of widgets
+# that allow you to select and view images in a Tk label.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+# 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 -type f -directory $dirName *]] {
+ $w.f.list insert end [file tail $i]
+ }
+}
+
+# selectAndLoadDir --
+# This procedure pops up a dialog to ask for a directory to load into
+# the listobx and (if the user presses OK) reloads the directory
+# listbox from the directory named in the demo's entry.
+#
+# Arguments:
+# w - Name of the toplevel window of the demo.
+
+proc selectAndLoadDir w {
+ global dirName
+ set dir [tk_chooseDirectory -initialdir $dirName -parent $w -mustexist 1]
+ if {$dir ne ""} {
+ set dirName $dir
+ loadDir $w
+ }
+}
+
+# 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]]
+ set opts [list -file $file]
+ if {[string tolower [file extension $file]] eq ".svg"} {
+ lappend opts -format $tk::svgFmt
+ } else {
+ lappend opts -format {}
+ }
+ if {[catch {
+ image2a configure {*}$opts
+ }]} then {
+ # Mark the file as not loadable
+ $w.f.list itemconfigure @$x,$y -bg \#c00000 -selectbackground \#ff0000
+ }
+}
+
+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
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+frame $w.mid
+pack $w.mid -fill both -expand 1
+
+labelframe $w.dir -text "Directory:"
+# Main widget program sets variable tk_demoDirectory
+set dirName [file join $tk_demoDirectory images]
+entry $w.dir.e -width 30 -textvariable dirName
+button $w.dir.b -pady 0 -padx 2m -text "Select Dir." \
+ -command "selectAndLoadDir $w"
+bind $w.dir.e <Return> "loadDir $w"
+pack $w.dir.e -side left -fill both -padx 2m -pady 2m -expand true
+pack $w.dir.b -side left -fill y -padx {0 2m} -pady 2m
+labelframe $w.f -text "File:" -padx 2m -pady 2m
+
+listbox $w.f.list -width 20 -height 10 -yscrollcommand "$w.f.scroll set"
+ttk::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 Tcl.svg
+bind $w.f.list <Double-Button-1> "loadImage $w %x %y"
+
+catch {image delete image2a}
+image create photo image2a
+labelframe $w.image -text "Image:"
+label $w.image.image -image image2a
+pack $w.image.image -padx 2m -pady 2m
+
+grid $w.dir - -sticky ew -padx 1m -pady 1m -in $w.mid
+grid $w.f $w.image -sticky nw -padx 1m -pady 1m -in $w.mid
+grid columnconfigure $w.mid 1 -weight 1
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/image2.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/Tcl.svg
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/Tcl.svg
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/Tcl.svg 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/Tcl.svg 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/Tcl.svg
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+image/svg+xml
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/Tk_feather.png
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/Tk_feather.png
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/Tk_feather.png 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/Tk_feather.png 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/Tk_feather.png
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+image/png
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/earth.gif
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/earth.gif
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/earth.gif 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/earth.gif 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/earth.gif
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+image/gif
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/earthmenu.png
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/earthmenu.png
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/earthmenu.png 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/earthmenu.png 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/earthmenu.png
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+image/png
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/earthris.gif
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/earthris.gif
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/earthris.gif 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/earthris.gif 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/earthris.gif
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+image/gif
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/flagdown.xbm
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/flagdown.xbm (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/flagdown.xbm 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,27 @@
+#define flagdown_width 48
+#define flagdown_height 48
+static char flagdown_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x1e, 0x00, 0x00,
+ 0x00, 0x00, 0x80, 0x7f, 0x00, 0x00, 0x00, 0x00, 0xe0, 0xe1, 0x00, 0x00,
+ 0x00, 0x00, 0x70, 0x80, 0x01, 0x00, 0x00, 0x00, 0x18, 0x00, 0x03, 0x00,
+ 0x00, 0x00, 0x0c, 0x00, 0x03, 0x00, 0x00, 0x00, 0x06, 0x00, 0x06, 0x04,
+ 0x00, 0x00, 0x03, 0x00, 0x06, 0x06, 0x00, 0x80, 0x01, 0x00, 0x06, 0x07,
+ 0x00, 0xc0, 0x1f, 0x00, 0x87, 0x07, 0x00, 0xe0, 0x7f, 0x80, 0xc7, 0x07,
+ 0x00, 0x70, 0xe0, 0xc0, 0xe5, 0x07, 0x00, 0x38, 0x80, 0xe1, 0x74, 0x07,
+ 0x00, 0x18, 0x80, 0x71, 0x3c, 0x07, 0x00, 0x0c, 0x00, 0x3b, 0x1e, 0x03,
+ 0x00, 0x0c, 0x00, 0x1f, 0x0f, 0x00, 0x00, 0x86, 0x1f, 0x8e, 0x07, 0x00,
+ 0x00, 0x06, 0x06, 0xc6, 0x05, 0x00, 0x00, 0x06, 0x00, 0xc6, 0x05, 0x00,
+ 0x00, 0x06, 0x00, 0xc6, 0x04, 0x00, 0x00, 0x06, 0x00, 0x06, 0x04, 0x00,
+ 0x7f, 0x06, 0x00, 0x06, 0xe4, 0xff, 0x00, 0x06, 0x00, 0x06, 0x04, 0x00,
+ 0x00, 0x06, 0x00, 0x06, 0x04, 0x00, 0x00, 0x06, 0x00, 0x06, 0x06, 0x00,
+ 0x00, 0x06, 0x00, 0x06, 0x03, 0x00, 0x00, 0x06, 0x00, 0x86, 0x01, 0x00,
+ 0x00, 0x06, 0x00, 0xc6, 0x00, 0x00, 0x00, 0x06, 0x00, 0x66, 0x00, 0x00,
+ 0x00, 0x06, 0x00, 0x36, 0x00, 0x00, 0x00, 0x06, 0x00, 0x3e, 0x00, 0x00,
+ 0x00, 0xfe, 0xff, 0x2f, 0x00, 0x00, 0x00, 0xfc, 0xff, 0x27, 0x00, 0x00,
+ 0x00, 0x00, 0x88, 0x20, 0x00, 0x00, 0x00, 0x00, 0x88, 0x20, 0x00, 0x00,
+ 0x00, 0x00, 0x88, 0x20, 0x00, 0x00, 0x00, 0x00, 0x88, 0x20, 0x00, 0x00,
+ 0x00, 0x00, 0x88, 0x20, 0x00, 0x00, 0x00, 0x00, 0x88, 0x20, 0x00, 0x00,
+ 0x00, 0x00, 0x88, 0x20, 0x00, 0x00, 0x00, 0x00, 0x88, 0x20, 0x00, 0x00,
+ 0xf7, 0xbf, 0x8e, 0xfc, 0xdf, 0xf8, 0x9d, 0xeb, 0x9b, 0x76, 0xd2, 0x7a,
+ 0x46, 0x30, 0xe2, 0x0f, 0xe1, 0x47, 0x55, 0x84, 0x48, 0x11, 0x84, 0x19};
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/flagdown.xbm
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/flagup.xbm
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/flagup.xbm (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/flagup.xbm 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,27 @@
+#define flagup_width 48
+#define flagup_height 48
+static char flagup_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x7f, 0x00,
+ 0x00, 0x00, 0x00, 0xe0, 0x7f, 0x00, 0x00, 0x00, 0x00, 0xef, 0x6a, 0x00,
+ 0x00, 0x00, 0xc0, 0x7b, 0x75, 0x00, 0x00, 0x00, 0xe0, 0xe0, 0x6a, 0x00,
+ 0x00, 0x00, 0x30, 0x60, 0x75, 0x00, 0x00, 0x00, 0x18, 0xe0, 0x7f, 0x00,
+ 0x00, 0x00, 0x0c, 0xe0, 0x7f, 0x00, 0x00, 0x00, 0x06, 0xe0, 0x04, 0x00,
+ 0x00, 0x00, 0x03, 0xe0, 0x04, 0x00, 0x00, 0x80, 0x01, 0xe0, 0x06, 0x00,
+ 0x00, 0xc0, 0x1f, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x7f, 0xe0, 0x07, 0x00,
+ 0x00, 0x70, 0xe0, 0xe0, 0x05, 0x00, 0x00, 0x38, 0x80, 0xe1, 0x04, 0x00,
+ 0x00, 0x18, 0x80, 0xf1, 0x04, 0x00, 0x00, 0x0c, 0x00, 0xfb, 0x04, 0x00,
+ 0x00, 0x0c, 0x00, 0xff, 0x04, 0x00, 0x00, 0x86, 0x1f, 0xee, 0x04, 0x00,
+ 0x00, 0x06, 0x06, 0xe6, 0x04, 0x00, 0x00, 0x06, 0x00, 0xe6, 0x04, 0x00,
+ 0x00, 0x06, 0x00, 0xe6, 0x04, 0x00, 0x00, 0x06, 0x00, 0x66, 0x04, 0x00,
+ 0x7f, 0x56, 0x52, 0x06, 0xe4, 0xff, 0x00, 0x76, 0x55, 0x06, 0x04, 0x00,
+ 0x00, 0x56, 0x57, 0x06, 0x04, 0x00, 0x00, 0x56, 0x55, 0x06, 0x06, 0x00,
+ 0x00, 0x56, 0xd5, 0x06, 0x03, 0x00, 0x00, 0x06, 0x00, 0x86, 0x01, 0x00,
+ 0x54, 0x06, 0x00, 0xc6, 0x54, 0x55, 0xaa, 0x06, 0x00, 0x66, 0xaa, 0x2a,
+ 0x54, 0x06, 0x00, 0x36, 0x55, 0x55, 0xaa, 0x06, 0x00, 0xbe, 0xaa, 0x2a,
+ 0x54, 0xfe, 0xff, 0x6f, 0x55, 0x55, 0xaa, 0xfc, 0xff, 0xa7, 0xaa, 0x2a,
+ 0x54, 0x01, 0x88, 0x60, 0x55, 0x55, 0xaa, 0xaa, 0x8a, 0xa0, 0xaa, 0x2a,
+ 0x54, 0x55, 0x8d, 0x60, 0x55, 0x55, 0xaa, 0xaa, 0x8a, 0xa0, 0xaa, 0x2a,
+ 0x54, 0x55, 0x8d, 0x60, 0x55, 0x55, 0xaa, 0xaa, 0x8a, 0xa0, 0xaa, 0x2a,
+ 0x54, 0x55, 0x8d, 0x50, 0x55, 0x55, 0xaa, 0xaa, 0x8a, 0xa8, 0xaa, 0x2a,
+ 0x54, 0x55, 0x95, 0x54, 0x55, 0x55, 0xaa, 0xaa, 0xaa, 0xaa, 0xaa, 0x2a,
+ 0x54, 0x55, 0x55, 0x55, 0x55, 0x15, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/flagup.xbm
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/gray25.xbm
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/gray25.xbm (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/gray25.xbm 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,6 @@
+#define grey_width 16
+#define grey_height 16
+static char grey_bits[] = {
+ 0x11, 0x11, 0x44, 0x44, 0x11, 0x11, 0x44, 0x44, 0x11, 0x11, 0x44, 0x44,
+ 0x11, 0x11, 0x44, 0x44, 0x11, 0x11, 0x44, 0x44, 0x11, 0x11, 0x44, 0x44,
+ 0x11, 0x11, 0x44, 0x44, 0x11, 0x11, 0x44, 0x44};
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/gray25.xbm
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/letters.xbm
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/letters.xbm (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/letters.xbm 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,27 @@
+#define letters_width 48
+#define letters_height 48
+static char letters_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0xfe, 0xff, 0xff, 0xff, 0x3f, 0x00, 0x02, 0x00, 0x00, 0x00, 0x20,
+ 0x00, 0xfa, 0x00, 0x00, 0x00, 0x2e, 0x00, 0x02, 0x00, 0x00, 0x00, 0x2a,
+ 0x00, 0x3a, 0x00, 0x00, 0x00, 0x2a, 0x00, 0x02, 0x00, 0x00, 0x00, 0x2e,
+ 0xe0, 0xff, 0xff, 0xff, 0xff, 0x21, 0x20, 0x00, 0x00, 0x00, 0x00, 0x21,
+ 0xa0, 0x03, 0x00, 0x00, 0x70, 0x21, 0x20, 0x00, 0x00, 0x00, 0x50, 0x21,
+ 0xa0, 0x1f, 0x00, 0x00, 0x50, 0x21, 0x20, 0x00, 0x00, 0x00, 0x70, 0x21,
+ 0xfe, 0xff, 0xff, 0xff, 0x0f, 0x21, 0x02, 0x00, 0x00, 0x00, 0x08, 0x21,
+ 0xfa, 0x01, 0x00, 0x80, 0x0b, 0x21, 0x02, 0x00, 0x00, 0x80, 0x0a, 0x21,
+ 0xba, 0x01, 0x00, 0x80, 0x0a, 0x21, 0x02, 0x00, 0x00, 0x80, 0x0b, 0x21,
+ 0x3a, 0x00, 0x00, 0x00, 0x08, 0x21, 0x02, 0x00, 0x00, 0x00, 0x08, 0x21,
+ 0x02, 0xc0, 0xfb, 0x03, 0x08, 0x21, 0x02, 0x00, 0x00, 0x00, 0x08, 0x3f,
+ 0x02, 0xc0, 0xbd, 0x0f, 0x08, 0x01, 0x02, 0x00, 0x00, 0x00, 0x08, 0x01,
+ 0x02, 0xc0, 0x7f, 0x7b, 0x08, 0x01, 0x02, 0x00, 0x00, 0x00, 0x08, 0x01,
+ 0x02, 0x00, 0x00, 0x00, 0xf8, 0x01, 0x02, 0x00, 0x00, 0x00, 0x08, 0x00,
+ 0x02, 0x00, 0x00, 0x00, 0x08, 0x00, 0x02, 0x00, 0x00, 0x00, 0x08, 0x00,
+ 0x02, 0x00, 0x00, 0x00, 0x08, 0x00, 0x02, 0x00, 0x00, 0x00, 0x08, 0x00,
+ 0xfe, 0xff, 0xff, 0xff, 0x0f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/letters.xbm
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/noletter.xbm
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/noletter.xbm (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/noletter.xbm 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,27 @@
+#define noletters_width 48
+#define noletters_height 48
+static char noletters_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xf0, 0x1f, 0x00, 0x00,
+ 0x00, 0x00, 0xff, 0xff, 0x01, 0x00, 0x00, 0xc0, 0xff, 0xff, 0x07, 0x00,
+ 0x00, 0xf0, 0x0f, 0xe0, 0x1f, 0x00, 0x00, 0xfc, 0x01, 0x00, 0x7f, 0x00,
+ 0x00, 0x3e, 0x00, 0x00, 0xf8, 0x00, 0x00, 0x1f, 0x00, 0x00, 0xf0, 0x01,
+ 0x80, 0x07, 0x00, 0x00, 0xc0, 0x03, 0xc0, 0x03, 0x00, 0x00, 0xe0, 0x07,
+ 0xe0, 0x01, 0x00, 0x00, 0xf0, 0x0f, 0xe0, 0x00, 0x00, 0x00, 0x78, 0x0e,
+ 0xf0, 0x00, 0x00, 0x00, 0x3c, 0x1e, 0x70, 0x00, 0x00, 0x00, 0x1e, 0x1c,
+ 0x38, 0x00, 0x00, 0x00, 0x0f, 0x38, 0x38, 0x00, 0x00, 0x80, 0x07, 0x38,
+ 0x3c, 0xfc, 0xff, 0xff, 0x7f, 0x78, 0x1c, 0x04, 0x00, 0xe0, 0x41, 0x70,
+ 0x1c, 0x04, 0x00, 0xf0, 0x40, 0x70, 0x1c, 0x74, 0x00, 0x78, 0x4e, 0x70,
+ 0x0e, 0x04, 0x00, 0x3c, 0x4a, 0xe0, 0x0e, 0x74, 0x03, 0x1e, 0x4a, 0xe0,
+ 0x0e, 0x04, 0x00, 0x0f, 0x4e, 0xe0, 0x0e, 0x04, 0x80, 0x07, 0x40, 0xe0,
+ 0x0e, 0x04, 0xf8, 0x0f, 0x40, 0xe0, 0x0e, 0x04, 0xe0, 0x01, 0x40, 0xe0,
+ 0x0e, 0x04, 0xf8, 0x00, 0x40, 0xe0, 0x0e, 0x04, 0x78, 0x00, 0x40, 0xe0,
+ 0x0e, 0x04, 0xfc, 0xf3, 0x40, 0xe0, 0x1c, 0x04, 0x1e, 0x00, 0x40, 0x70,
+ 0x1c, 0x04, 0x0f, 0x00, 0x40, 0x70, 0x1c, 0x84, 0x07, 0x00, 0x40, 0x70,
+ 0x3c, 0xfc, 0xff, 0xff, 0x7f, 0x78, 0x38, 0xe0, 0x01, 0x00, 0x00, 0x38,
+ 0x38, 0xf0, 0x00, 0x00, 0x00, 0x38, 0x70, 0x78, 0x00, 0x00, 0x00, 0x1c,
+ 0xf0, 0x3c, 0x00, 0x00, 0x00, 0x1e, 0xe0, 0x1e, 0x00, 0x00, 0x00, 0x0e,
+ 0xe0, 0x0f, 0x00, 0x00, 0x00, 0x0f, 0xc0, 0x07, 0x00, 0x00, 0x80, 0x07,
+ 0x80, 0x07, 0x00, 0x00, 0xc0, 0x03, 0x00, 0x1f, 0x00, 0x00, 0xf0, 0x01,
+ 0x00, 0x3e, 0x00, 0x00, 0xf8, 0x00, 0x00, 0xfc, 0x01, 0x00, 0x7f, 0x00,
+ 0x00, 0xf0, 0x0f, 0xe0, 0x1f, 0x00, 0x00, 0xc0, 0xff, 0xff, 0x07, 0x00,
+ 0x00, 0x00, 0xff, 0xff, 0x01, 0x00, 0x00, 0x00, 0xf0, 0x1f, 0x00, 0x00};
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/noletter.xbm
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/ouster.png
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/ouster.png
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/ouster.png 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/ouster.png 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/ouster.png
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+image/png
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/pattern.xbm
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/pattern.xbm (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/pattern.xbm 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,6 @@
+#define foo_width 16
+#define foo_height 16
+static char foo_bits[] = {
+ 0x60, 0x06, 0x90, 0x09, 0x90, 0x09, 0xb0, 0x0d, 0x4e, 0x72, 0x49, 0x92,
+ 0x71, 0x8e, 0x8e, 0x71, 0x8e, 0x71, 0x71, 0x8e, 0x49, 0x92, 0x4e, 0x72,
+ 0xb0, 0x0d, 0x90, 0x09, 0x90, 0x09, 0x60, 0x06};
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/pattern.xbm
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/plowed_field.png
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/plowed_field.png
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/plowed_field.png 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/plowed_field.png 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/plowed_field.png
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+image/png
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/starry_night.png
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/starry_night.png
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/starry_night.png 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/starry_night.png 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/starry_night.png
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+image/png
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/tcllogo.gif
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/tcllogo.gif
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/tcllogo.gif 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/tcllogo.gif 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/tcllogo.gif
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+image/gif
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/teapot.ppm
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/teapot.ppm
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/teapot.ppm 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/teapot.ppm 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/images/teapot.ppm
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+image/x-portable-pixmap
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/items.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/items.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/items.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,307 @@
+# items.tcl --
+#
+# This demonstration script creates a canvas that displays the
+# canvas item types.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+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 Left-Button drag:\tmoves item under pointer.\n Middle-Button drag:\trepositions view.\n Right-Button drag:\tstrokes out area.\n Ctrl+f:\t\tprints items under area."
+pack $w.msg -side top
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+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"
+ttk::scrollbar $w.frame.vscroll -command "$c yview"
+ttk::scrollbar $w.frame.hscroll -orient horizontal -command "$c xview"
+
+bind $c <TouchpadScroll> {
+ lassign [tk::PreciseScrollDeltas %D] deltaX deltaY
+ if {$deltaX != 0 || $deltaY != 0} {
+ tk::ScrollByPixels %W $deltaX $deltaY
+ }
+}
+
+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 1.5p
+$c create line 0c 8c 30c 8c -width 1.5p
+$c create line 0c 16c 30c 16c -width 1.5p
+$c create line 10c 0c 10c 24c -width 1.5p
+$c create line 20c 0c 20c 24c -width 1.5p
+
+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 2.25p -fill $red -tags item
+# Main widget program sets variable tk_demoDirectory
+$c create line 1c 5c 7c 5c 7c 7c 9c 7c -width .5c \
+ -stipple @[file join $tk_demoDirectory images gray25.xbm] \
+ -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 2.25p -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_demoDirectory images gray25.xbm] \
+ -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 {} -width 3p -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 -outline {} -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_demoDirectory images gray25.xbm] \
+ -fill $blue -outline {} -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_demoDirectory images gray25.xbm] \
+ -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_demoDirectory images gray25.xbm] \
+ -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
+catch {
+$c create text 25c 14c -font $font2 -anchor c -fill $red -angle 15 \
+ -text "Angled 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_demoDirectory images gray25.xbm]
+$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 and Images" -anchor n
+catch {
+image create photo items.ousterhout \
+ -file [file join $tk_demoDirectory images ouster.png]
+image create photo items.ousterhout.active -format "png -alpha 0.5" \
+ -file [file join $tk_demoDirectory images ouster.png]
+set zoomFactor [expr {$tk::scalingPct / 100}]
+foreach img {items.ousterhout items.ousterhout.active} {
+ image create photo ${img}2
+ ${img}2 copy $img -zoom $zoomFactor
+}
+$c create image 13c 20c -tags item -image items.ousterhout2 \
+ -activeimage items.ousterhout.active2
+}
+$c create bitmap 17c 18.5c -tags item \
+ -bitmap @[file join $tk_demoDirectory images noletter.xbm]
+$c create bitmap 17c 21.5c -tags item \
+ -bitmap @[file join $tk_demoDirectory images letters.xbm]
+
+$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 <Enter> "itemEnter $c"
+$c bind item <Leave> "itemLeave $c"
+bind $c <Button-2> "$c scan mark %x %y"
+bind $c <B2-Motion> "$c scan dragto %x %y"
+bind $c <Button-3> "itemMark $c %x %y"
+bind $c <B3-Motion> "itemStroke $c %x %y"
+bind $c <<NextChar>> "itemsUnderArea $c"
+bind $c <Button-1> "itemStartDrag $c %x %y"
+bind $c <B1-Motion> "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" || $type == "image"} {
+ set restoreCmd {}
+ return
+ } elseif {$type == "bitmap"} {
+ set bg [lindex [$c itemconf current -background] 4]
+ set restoreCmd [list $c itemconfig current -background $bg]
+ $c itemconfig current -background SteelBlue2
+ return
+ } elseif {$type == "image"} {
+ set restoreCmd [list $c itemconfig current -state normal]
+ $c itemconfig current -state active
+ 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] >= 0} {
+ 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] >= 0} {
+ 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 "Oooohhh!!" -fill $color -anchor n]
+ after 500 "$w delete $i"
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/items.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ixset
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ixset (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ixset 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,328 @@
+#!/bin/sh
+# the next line restarts using wish \
+exec wish90 "$0" ${1+"$@"}
+
+# ixset --
+# A nice interface to "xset" to change X server settings
+#
+# History :
+# 91/11/23 : pda at masi.ibp.fr, jt at ratp.fr : design
+# 92/08/01 : pda at masi.ibp.fr : cleaning
+
+package require tk
+
+#
+# Button actions
+#
+
+proc quit {} {
+ destroy .
+}
+
+proc ok {} {
+ writesettings
+ quit
+}
+
+proc cancel {} {
+ readsettings
+ dispsettings
+ .buttons.apply configure -state disabled
+ .buttons.cancel configure -state disabled
+}
+
+proc apply {} {
+ writesettings
+ .buttons.apply configure -state disabled
+ .buttons.cancel configure -state disabled
+}
+
+#
+# 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] >= 0} {
+ switch -- [lindex $line 0] {
+ auto {
+ set rpt [lindex $line 1]
+ if {$rpt eq "repeat:"} {
+ 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 eq "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 {$kbdrep eq "on"} {
+ 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.tim.entry get]
+ set screencyc [.screen.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 eq "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.blank [expr {$screenbla eq "blank" ? "select" : "deselect"}]
+ .screen.pat [expr {$screenbla ne "blank" ? "select" : "deselect"}]
+ .screen.tim.entry delete 0 end
+ .screen.tim.entry insert 0 $screentim
+ .screen.cyc.entry delete 0 end
+ .screen.cyc.entry insert 0 $screencyc
+}
+
+
+#
+# Create all windows, and pack them
+#
+
+proc labelentry {path text length {range {}}} {
+ frame $path
+ label $path.label -text $text
+ if {[llength $range]} {
+ spinbox $path.entry -width $length -relief sunken \
+ -from [lindex $range 0] -to [lindex $range 1]
+ } else {
+ entry $path.entry -width $length -relief sunken
+ }
+ pack $path.label -side left
+ pack $path.entry -side right -expand y -fill x
+}
+
+proc createwindows {} {
+ #
+ # Buttons
+ #
+
+ frame .buttons
+ button .buttons.ok -default active -command ok -text "Ok"
+ button .buttons.apply -default normal -command apply -text "Apply" \
+ -state disabled
+ button .buttons.cancel -default normal -command cancel -text "Cancel" \
+ -state disabled
+ button .buttons.quit -default normal -command quit -text "Quit"
+
+ pack .buttons.ok .buttons.apply .buttons.cancel .buttons.quit \
+ -side left -expand yes -pady 3p
+
+ bind . <Return> {.buttons.ok flash; .buttons.ok invoke}
+ bind . <Escape> {.buttons.quit flash; .buttons.quit invoke}
+ bind . <Button-1> {
+ if {![string match .buttons* %W]} {
+ .buttons.apply configure -state normal
+ .buttons.cancel configure -state normal
+ }
+ }
+ bind . <Key> {
+ if {![string match .buttons* %W]} {
+ switch -glob %K {
+ Return - Escape - Tab - *Shift* {}
+ default {
+ .buttons.apply configure -state normal
+ .buttons.cancel configure -state normal
+ }
+ }
+ }
+ }
+
+ #
+ # Bell settings
+ #
+
+ labelframe .bell -text "Bell Settings" -padx 1.5m -pady 1.5m
+ scale .bell.vol \
+ -from 0 -to 100 -length 150p -tickinterval 20 \
+ -label "Volume (%)" -orient horizontal
+
+ frame .bell.val
+ labelentry .bell.val.pit "Pitch (Hz)" 6 {25 20000}
+ labelentry .bell.val.dur "Duration (ms)" 6 {1 10000}
+ pack .bell.val.pit -side left -padx 3p
+ pack .bell.val.dur -side right -padx 3p
+ pack .bell.vol .bell.val -side top -expand yes
+
+ #
+ # Keyboard settings
+ #
+
+ labelframe .kbd -text "Keyboard Repeat Settings" -padx 1.5m -pady 1.5m
+
+ 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 150p -tickinterval 20 \
+ -label "Click Volume (%)" -orient horizontal
+ pack .kbd.val.onoff -side left -fill x -expand yes -padx {0 1m}
+ pack .kbd.val.cli -side left -expand yes -fill x -padx {1m 0}
+
+ pack .kbd.val -side top -expand yes -pady 1.5p -fill x
+
+ #
+ # Mouse settings
+ #
+
+ labelframe .mouse -text "Mouse Settings" -padx 1.5m -pady 1.5m
+
+ frame .mouse.hor
+ labelentry .mouse.hor.acc "Acceleration" 5
+ labelentry .mouse.hor.thr "Threshold (pixels)" 3 {1 2000}
+
+ pack .mouse.hor.acc -side left -padx {0 1m}
+ pack .mouse.hor.thr -side right -padx {1m 0}
+
+ pack .mouse.hor -side top -expand yes
+
+ #
+ # Screen Saver settings
+ #
+
+ labelframe .screen -text "Screen-saver Settings" -padx 1.5m -pady 1.5m
+
+ radiobutton .screen.blank \
+ -variable screenblank -text "Blank" -relief flat \
+ -value "blank" -variable screenbla -anchor w
+ radiobutton .screen.pat \
+ -variable screenblank -text "Pattern" -relief flat \
+ -value "noblank" -variable screenbla -anchor w
+ labelentry .screen.tim "Timeout (s)" 5 {1 100000}
+ labelentry .screen.cyc "Cycle (s)" 5 {1 100000}
+
+ grid .screen.blank .screen.tim -sticky e
+ grid .screen.pat .screen.cyc -sticky e
+ grid configure .screen.blank .screen.pat -sticky ew
+
+ #
+ # Main window
+ #
+
+ pack .buttons -side top -fill both
+ pack .bell .kbd .mouse .screen -side top -fill both -expand yes \
+ -padx 1m -pady 1m
+
+ #
+ # 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...
+#
+
+# Local Variables:
+# mode: tcl
+# End:
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ixset
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/knightstour.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/knightstour.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/knightstour.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,274 @@
+# Copyright © 2008 Pat Thoyts <patthoyts at users.sourceforge.net>
+#
+# Calculate a Knight's tour of a chessboard.
+#
+# This uses Warnsdorff's rule to calculate the next square each
+# time. This specifies that the next square should be the one that
+# has the least number of available moves.
+#
+# Using this rule it is possible to get to a position where
+# there are no squares available to move into. In this implementation
+# this occurs when the starting square is d6.
+#
+# To solve this fault an enhancement to the rule is that if we
+# have a choice of squares with an equal score, we should choose
+# the one nearest the edge of the board.
+#
+# If the call to the Edgemost function is commented out you can see
+# this occur.
+#
+# You can drag the knight to a specific square to start if you wish.
+# If you let it repeat then it will choose random start positions
+# for each new tour.
+
+package require tk
+
+# Return a list of accessible squares from a given square
+proc ValidMoves {square} {
+ set moves {}
+ foreach pair {{-1 -2} {-2 -1} {-2 1} {-1 2} {1 2} {2 1} {2 -1} {1 -2}} {
+ set col [expr {($square % 8) + [lindex $pair 0]}]
+ set row [expr {($square / 8) + [lindex $pair 1]}]
+ if {$row >= 0 && $row < 8 && $col >= 0 && $col < 8} {
+ lappend moves [expr {$row * 8 + $col}]
+ }
+ }
+ return $moves
+}
+
+# Return the number of available moves for this square
+proc CheckSquare {square} {
+ variable visited
+ set moves 0
+ foreach test [ValidMoves $square] {
+ if {[lsearch -exact -integer $visited $test] < 0} {
+ incr moves
+ }
+ }
+ return $moves
+}
+
+# Select the next square to move to. Returns -1 if there are no available
+# squares remaining that we can move to.
+proc Next {square} {
+ variable visited
+ set minimum 9
+ set nextSquare -1
+ foreach testSquare [ValidMoves $square] {
+ if {[lsearch -exact -integer $visited $testSquare] < 0} {
+ set count [CheckSquare $testSquare]
+ if {$count < $minimum} {
+ set minimum $count
+ set nextSquare $testSquare
+ } elseif {$count == $minimum} {
+ # to remove the enhancement to Warnsdorff's rule
+ # remove the next line:
+ set nextSquare [Edgemost $nextSquare $testSquare]
+ }
+ }
+ }
+ return $nextSquare
+}
+
+# Select the square nearest the edge of the board
+proc Edgemost {a b} {
+ set colA [expr {3-int(abs(3.5-($a%8)))}]
+ set colB [expr {3-int(abs(3.5-($b%8)))}]
+ set rowA [expr {3-int(abs(3.5-($a/8)))}]
+ set rowB [expr {3-int(abs(3.5-($b/8)))}]
+ return [expr {($colA * $rowA) < ($colB * $rowB) ? $a : $b}]
+}
+
+# Display a square number as a standard chess square notation.
+proc N {square} {
+ return [format %c%d [expr {97 + $square % 8}] [expr {$square / 8 + 1}]]
+}
+
+# Perform a Knight's move and schedule the next move.
+proc MovePiece {dlg last square} {
+ variable visited
+ variable delay
+ variable continuous
+ set line [format "%2d. %s .. %s" [llength $visited] [N $last] [N $square]]
+ $dlg.f.txt insert end $line\n
+ $dlg.f.txt see end
+ $dlg.f.c itemconfigure [expr {1+$last}] -state normal -outline black
+ $dlg.f.c itemconfigure [expr {1+$square}] -state normal -outline red
+ $dlg.f.c moveto knight {*}[lrange [$dlg.f.c coords [expr {1+$square}]] 0 1]
+ lappend visited $square
+ set next [Next $square]
+ if {$next ne -1} {
+ variable aid [after $delay [list MovePiece $dlg $square $next]]
+ } else {
+ $dlg.tf.b1 configure -state normal
+ if {[llength $visited] == 64} {
+ variable initial
+ if {$initial == $square} {
+ $dlg.f.txt insert end "Closed tour!"
+ } else {
+ $dlg.f.txt insert end "Success"
+ if {$continuous} {
+ after [expr {$delay * 2}] [namespace code \
+ [list Tour $dlg [expr {int(rand() * 64)}]]]
+ }
+ }
+ } else {
+ $dlg.f.txt insert end "FAILED!"
+ }
+ }
+}
+
+# Begin a new tour of the board given a random start position
+proc Tour {dlg {square {}}} {
+ variable visited {}
+ $dlg.f.txt delete 1.0 end
+ $dlg.tf.b1 configure -state disabled
+ for {set n 0} {$n < 64} {incr n} {
+ $dlg.f.c itemconfigure $n -state disabled -outline black
+ }
+ if {$square eq {}} {
+ set coords [lrange [$dlg.f.c coords knight] 0 1]
+ set square [expr {[$dlg.f.c find closest {*}$coords 0 65]-1}]
+ }
+ variable initial $square
+ after idle [list MovePiece $dlg $initial $initial]
+}
+
+proc Stop {} {
+ variable aid
+ catch {after cancel $aid}
+}
+
+proc Exit {dlg} {
+ Stop
+ destroy $dlg
+}
+
+proc SetDelay {new} {
+ variable speed [expr {int($new)}]
+ variable delay [expr {2000 - $speed}]
+}
+
+proc DragStart {w x y} {
+ $w dtag selected
+ $w addtag selected withtag current
+ variable dragging [list $x $y]
+}
+proc DragMotion {w x y} {
+ variable dragging
+ if {[info exists dragging]} {
+ $w move selected [expr {$x - [lindex $dragging 0]}] \
+ [expr {$y - [lindex $dragging 1]}]
+ variable dragging [list $x $y]
+ }
+}
+proc DragEnd {w x y} {
+ set square [$w find closest $x $y 0 65]
+ $w moveto selected {*}[lrange [$w coords $square] 0 1]
+ $w dtag selected
+ variable dragging ; unset dragging
+}
+
+proc CreateGUI {} {
+ catch {destroy .knightstour}
+ set dlg [toplevel .knightstour]
+ wm title $dlg "Knight's Tour"
+ wm withdraw $dlg
+ set f [ttk::frame $dlg.f]
+ set c [canvas $f.c -width 192p -height 192p]
+ text $f.txt -width 12 -height 1 -padx 3p \
+ -yscrollcommand [list $f.vs set] -font TkFixedFont
+ ttk::scrollbar $f.vs -command [list $f.txt yview]
+
+ variable speed 1400
+ variable delay [expr {2000 - $speed}]
+ variable continuous 0
+ ttk::frame $dlg.tf
+ ttk::checkbutton $dlg.tf.cc -text Repeat \
+ -variable [namespace which -variable continuous]
+ ttk::scale $dlg.tf.sc -from 0 -to 1992 -command [list SetDelay] \
+ -variable [namespace which -variable speed]
+ ttk::label $dlg.tf.ls -text Speed
+ ttk::button $dlg.tf.b1 -text Start -command [list Tour $dlg]
+ ttk::button $dlg.tf.b2 -text Exit -command [list Exit $dlg]
+ set square 0
+ for {set row 7} {$row >= 0} {incr row -1} {
+ for {set col 0} {$col < 8} {incr col} {
+ if {(($col & 1) ^ ($row & 1))} {
+ set fill tan3 ; set dfill tan4
+ } else {
+ set fill bisque ; set dfill bisque3
+ }
+ set coords [list [expr {$col * 24 + 3}]p \
+ [expr {$row * 24 + 3}]p \
+ [expr {$col * 24 + 24}]p \
+ [expr {$row * 24 + 24}]p]
+ $c create rectangle $coords -fill $fill -disabledfill $dfill \
+ -width 1.5p -state disabled -outline black
+ }
+ }
+ if {[tk windowingsystem] ne "x11"} {
+ catch {eval font create KnightFont -size 18}
+ $c create text 0 0 -font KnightFont -text "♞" \
+ -anchor nw -tags knight -fill black -activefill "#600000"
+ } else {
+ # On X11 we cannot reliably tell if the ♞ glyph is available
+ # so just use a polygon
+ set pts {
+ 2 25 24 25 21 19 20 8 14 0 10 0 0 13 0 16
+ 2 17 4 14 5 15 3 17 5 17 9 14 10 15 5 21
+ }
+ $c create polygon $pts -tag knight -offset 8 \
+ -fill black -activefill "#600000"
+ set scaleFactor [expr {$tk::scalingPct / 100.0}]
+ $c scale knight 0 0 $scaleFactor $scaleFactor
+ }
+ $c moveto knight {*}[lrange [$c coords [expr {1 + int(rand() * 64)}]] 0 1]
+ $c bind knight <Button-1> [namespace code [list DragStart %W %x %y]]
+ $c bind knight <Motion> [namespace code [list DragMotion %W %x %y]]
+ $c bind knight <ButtonRelease-1> [namespace code [list DragEnd %W %x %y]]
+
+ grid $c $f.txt $f.vs -sticky news
+ grid rowconfigure $f 0 -weight 1
+ grid columnconfigure $f 1 -weight 1
+
+ grid $f - - - - - -sticky news
+ set things [list $dlg.tf.cc $dlg.tf.sc $dlg.tf.ls $dlg.tf.b1]
+ if {![info exists ::widgetDemo]} {
+ lappend things $dlg.tf.b2
+ if {[tk windowingsystem] ne "aqua"} {
+ set things [linsert $things 0 [ttk::sizegrip $dlg.tf.sg]]
+ }
+ }
+ pack {*}$things -side right -padx 3p
+ if {[tk windowingsystem] eq "aqua"} {
+ pack configure {*}$things -padx {4 4} -pady {12 12}
+ pack configure [lindex $things 0] -padx {4 24}
+ pack configure [lindex $things end] -padx {16 4}
+ }
+ grid $dlg.tf - - - - - -sticky ew
+ if {[info exists ::widgetDemo]} {
+ grid [addSeeDismiss $dlg.buttons $dlg] - - - - - -sticky ew
+ }
+
+ grid rowconfigure $dlg 0 -weight 1
+ grid columnconfigure $dlg 0 -weight 1
+
+ bind $dlg <Control-F2> {console show}
+ bind $dlg <Return> [list $dlg.tf.b1 invoke]
+ bind $dlg <Escape> [list $dlg.tf.b2 invoke]
+ bind $dlg <Destroy> [namespace code [list Stop]]
+ wm protocol $dlg WM_DELETE_WINDOW [namespace code [list Exit $dlg]]
+
+ wm deiconify $dlg
+ tkwait window $dlg
+}
+
+if {![winfo exists .knightstour]} {
+ if {![info exists widgetDemo]} { wm withdraw . }
+ set r [catch [linsert $argv 0 CreateGUI] err]
+ if {$r} {
+ tk_messageBox -icon error -title "Error" -message $err
+ }
+ if {![info exists widgetDemo]} { exit $r }
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/knightstour.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/label.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/label.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/label.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,47 @@
+# label.tcl --
+#
+# This demonstration script creates a toplevel window containing
+# several label widgets.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+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 an image 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
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+frame $w.left
+frame $w.right
+pack $w.left $w.right -side left -expand yes -padx 7.5p -pady 7.5p -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 1.5p -anchor w
+
+# Main widget program sets variable tk_demoDirectory
+image create photo label.ousterhout \
+ -file [file join $tk_demoDirectory images ouster.png]
+
+# Create a copy of the image just created, magnified according to the
+# display's DPI scaling level. Since the zooom factor must be an integer,
+# the copy will only be effectively magnified if $tk::scalingPct >= 200.
+image create photo label.ousterhout2
+label.ousterhout2 copy label.ousterhout -zoom [expr {$tk::scalingPct / 100}]
+
+label $w.right.picture -borderwidth 2 -relief sunken -image label.ousterhout2
+label $w.right.caption -text "Tcl/Tk Creator"
+pack $w.right.picture $w.right.caption -side top
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/label.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/labelframe.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/labelframe.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/labelframe.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,76 @@
+# labelframe.tcl --
+#
+# This demonstration script creates a toplevel window containing
+# several labelframe widgets.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+set w .labelframe
+catch {destroy $w}
+toplevel $w
+wm title $w "Labelframe Demonstration"
+wm iconname $w "labelframe"
+positionWindow $w
+
+# Some information
+
+label $w.msg -font $font -wraplength 4i -justify left -text "Labelframes are\
+ used to group related widgets together. The label may be either \
+ plain text or another widget."
+pack $w.msg -side top
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+# Demo area
+
+frame $w.f
+pack $w.f -side bottom -fill both -expand 1
+set w $w.f
+
+# A group of radiobuttons in a labelframe
+
+labelframe $w.f -text "Value" -padx 1.5p -pady 1.5p
+grid $w.f -row 0 -column 0 -pady 2m -padx 2m
+
+foreach value {1 2 3 4} {
+ radiobutton $w.f.b$value -text "This is value $value" \
+ -variable lfdummy -value $value
+ pack $w.f.b$value -side top -fill x -pady 1.5p
+}
+
+
+# Using a label window to control a group of options.
+
+proc lfEnableButtons {w} {
+ foreach child [winfo children $w] {
+ if {$child == "$w.cb"} continue
+ if {$::lfdummy2} {
+ $child configure -state normal
+ } else {
+ $child configure -state disabled
+ }
+ }
+}
+
+labelframe $w.f2 -pady 1.5p -padx 1.5p
+checkbutton $w.f2.cb -text "Use this option." -variable lfdummy2 \
+ -command "lfEnableButtons $w.f2" -padx 0
+$w.f2 configure -labelwidget $w.f2.cb
+grid $w.f2 -row 0 -column 1 -pady 2m -padx 2m
+
+set t 0
+foreach str {Option1 Option2 Option3} {
+ checkbutton $w.f2.b$t -text $str
+ pack $w.f2.b$t -side top -fill x -pady 1.5p
+ incr t
+}
+lfEnableButtons $w.f2
+
+
+grid columnconfigure $w {0 1} -weight 1
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/labelframe.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/license.terms
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/license.terms (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/license.terms 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,40 @@
+This software is copyrighted by the Regents of the University of
+California, Sun Microsystems, Inc., Scriptics Corporation, ActiveState
+Corporation, Apple Inc. and other parties. The following terms apply to
+all files associated with the software unless explicitly disclaimed in
+individual files.
+
+The authors hereby grant permission to use, copy, modify, distribute,
+and license this software and its documentation for any purpose, provided
+that existing copyright notices are retained in all copies and that this
+notice is included verbatim in any distributions. No written agreement,
+license, or royalty fee is required for any of the authorized uses.
+Modifications to this software may be copyrighted by their authors
+and need not follow the licensing terms described here, provided that
+the new terms are clearly indicated on the first page of each file where
+they apply.
+
+IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
+FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
+ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
+DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.
+
+THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
+IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
+NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
+MODIFICATIONS.
+
+GOVERNMENT USE: If you are acquiring this software on behalf of the
+U.S. government, the Government shall have only "Restricted Rights"
+in the software and related documentation as defined in the Federal
+Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
+are acquiring the software on behalf of the Department of Defense, the
+software shall be classified as "Commercial Computer Software" and the
+Government shall have only "Restricted Rights" as defined in Clause
+252.227-7013 (b) (3) of DFARs. Notwithstanding the foregoing, the
+authors grant the U.S. Government and others acting in its behalf
+permission to use and distribute the software in accordance with the
+terms specified in this license.
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/license.terms
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/mac_styles.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/mac_styles.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/mac_styles.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,266 @@
+# mac_styles.tcl --
+#
+# This demonstration script creates a toplevel window containing a notebook
+# whose pages provide examples of the various mac-specific widgets that are
+# provided via special values for the -style option.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+set w .mac_styles
+catch {destroy $w}
+toplevel $w
+package require tk
+wm title $w "Tk Aqua Widgets"
+wm iconname $w "mac_styles"
+positionWindow $w
+##
+# System images we use in our buttons
+
+set featherImg [file join $tk_demoDirectory images Tk_feather.png]
+set starryImg [file join $tk_demoDirectory images starry_night.png]
+set fieldImg [file join $tk_demoDirectory images plowed_field.png]
+image create nsimage action -source NSAction -width 48 -height 48
+image create nsimage bonjour -source NSBonjour -width 48 -height 48
+image create nsimage bonjour1 -source NSBonjour -width 48 -height 48 -pressed 1
+image create nsimage tkfeather -source $featherImg -as file -width 48 -height 48
+image create nsimage tkfeather1 -source $featherImg -as file -width 48 -height 48 -pressed 1
+image create nsimage starry -source $starryImg -as file -width 96 -radius 10
+image create nsimage starry1 -source $starryImg -as file -width 96 -radius 10 -pressed 1
+image create nsimage starry2 -source $starryImg -as file -width 96 -radius 10 -ring 3
+image create nsimage field -source $fieldImg -as file -width 96 -radius 10
+image create nsimage field1 -source $fieldImg -as file -width 96 -radius 10 -pressed 1
+image create nsimage field2 -source $fieldImg -as file -width 96 -radius 10 -ring 3
+image create nsimage add -source NSAddTemplate -width 20 -height 20
+image create nsimage remove -source NSRemoveTemplate -width 18 -height 4
+
+# Off state and variables for checkbuttons and radio buttons
+set off {!selected !alternate}
+variable $w.checkVar
+variable $w.radioVar
+variable $w.triangleVar
+variable $w.popupVar
+variable $w.stepVar
+variable $w.comboVar
+
+# Make a disclosure triangle change state when clicked.
+proc toggleTriangle {tri} {
+ $tri instate {user1} {
+ $tri state {!user1}
+ return
+ }
+ $tri instate {!user1} {
+ $tri state {user1}
+ }
+}
+
+proc popupButton {win varName firstValue args} {
+ upvar #0 $varName var
+ if {![info exists var]} {
+ set var $firstValue
+ }
+ ttk::menubutton $win -textvariable $varName -menu $win.menu -direction flush
+ menu $win.menu -tearoff 0
+ $win.menu add radiobutton -label $firstValue -variable $varName
+ foreach i $args {
+ $win.menu add radiobutton -label $i -variable $varName
+ }
+ return $win.menu
+}
+
+set mag [encoding convertfrom utf-8 "\xf0\x9f\x94\x8d"]
+
+proc searchFocusOut {e} {
+ global mag
+ if {[$e get] eq ""} {
+ $e configure -foreground gray60
+ $e insert 0 "Search"
+ }
+}
+
+proc searchFocusIn {e} {
+ if {[$e cget -foreground] == {gray60}} {
+ $e delete 0 end
+ $e configure -foreground black
+ }
+}
+
+## Make the notebook and set up Ctrl+Tab traversal
+ttk::notebook $w.notebook
+ttk::notebook::enableTraversal $w.notebook
+
+# Frames pane
+set framesFrame [ttk::frame $w.notebook.frames -padding {40 35 40 50}]
+$w.notebook add $framesFrame -text "Frames"
+pack [ttk::labelframe $framesFrame.darker -text Darker -padding {50 30 50 50}] \
+ -fill both -expand 1
+pack [ttk::label $framesFrame.darker.label -padding {0 0 0 6} \
+ -text "This Group Box is nested to depth 2"] \
+ -fill x
+pack [ttk::labelframe $framesFrame.darker.darker -text "Darker Still" -padding 24] \
+ -fill both -expand 1
+pack [ttk::label $framesFrame.darker.darker.label \
+ -text "This Group Box is nested to depth 3"] -fill x
+pack [button $framesFrame.darker.darker.tkbutton -text "Tk Button" -width 7 \
+ -highlightbackground systemWindowBackgroundColor3] -pady 10
+pack [ttk::button $framesFrame.darker.darker.ttkbutton -text "Ttk Button" \
+ -width 7 -padding {-4 0 -4 0}] \
+ -pady 3
+# Button pane
+set buttonFrame [ttk::frame $w.notebook.buttons -padding {100 20 0 20}]
+$w.notebook add $buttonFrame -text "Buttons"
+grid columnconfigure $buttonFrame 0 -minsize 100
+grid columnconfigure $buttonFrame 1 -minsize 100
+
+set plain [ttk::button $buttonFrame.plain -text Button -padding {-12 0}]
+popupButton $buttonFrame.options .popupVar "Item 1" "Item 2" "Item 3"
+set options $buttonFrame.options
+set check [ttk::checkbutton $buttonFrame.check -text Check -variable .checkVar]
+set radio [ttk::frame $buttonFrame.radio]
+pack [ttk::radiobutton $radio.r1 -text "Radio 1" -variable .radioVar -value 1] -pady 4
+pack [ttk::radiobutton $radio.r2 -text "Radio 2" -variable .radioVar -value 2] -pady 4
+set triangle [ttk::checkbutton $buttonFrame.triangle -style Item -variable TriangleVar]
+bind $triangle <Button-1> {toggleTriangle %W}
+set bonjour [ttk::button $buttonFrame.bonjour -style ImageButton -text Bonjour \
+ -image {bonjour pressed bonjour1}]
+set feather [ttk::button $buttonFrame.feather -style ImageButton -text Tk \
+ -image {tkfeather pressed tkfeather1}]
+set gradient [ttk::frame $buttonFrame.gradient]
+pack [ttk::button $buttonFrame.gradient.add -style GradientButton \
+ -image add -padding {2 0}] -side left
+pack [ttk::button $buttonFrame.gradient.remove -style GradientButton \
+ -image remove -padding {2 8}] -side left
+set disclosure [ttk::checkbutton $buttonFrame.disclosure -style DisclosureButton]
+set help [ttk::button $buttonFrame.help -style HelpButton];
+
+$check state $off
+$radio.r1 state $off
+$radio.r2 state $off
+
+grid [ttk::label $buttonFrame.plainLabel -text "Push Button:"]\
+ -row 0 -column 0 -padx 4 -sticky e
+grid $plain -pady 4 -row 0 -column 1 -sticky w
+grid [ttk::label $buttonFrame.optionsLabel -text "Pop-up Button:"]\
+ -row 1 -column 0 -padx 4 -sticky e
+grid $options -pady 4 -row 1 -column 1 -sticky w
+grid [ttk::label $buttonFrame.checkLabel -text "Check Button:"]\
+ -row 2 -column 0 -padx 4 -sticky e
+grid $check -pady 4 -row 2 -column 1 -sticky w
+grid [ttk::label $buttonFrame.radioLabel -text "Radio Buttons:"]\
+ -row 3 -column 0 -padx 4 -sticky e
+grid $radio -pady 4 -row 3 -column 1 -sticky w
+grid [ttk::label $buttonFrame.triangleLabel -text "Disclosure Triangle:"]\
+ -row 4 -column 0 -padx 4 -sticky e
+grid $triangle -pady 4 -row 4 -column 1 -sticky w
+grid [ttk::label $buttonFrame.disclosureLabel -text "Disclosure Button:"]\
+ -row 5 -column 0 -padx 4 -sticky e
+grid $disclosure -row 5 -column 1 -sticky w
+grid [ttk::label $buttonFrame.imageLabel -text "Image Buttons:"]\
+ -row 7 -column 0 -padx 4 -sticky e
+grid $bonjour -pady 4 -row 6 -rowspan 4 -column 1 -sticky w
+grid $feather -padx 10 -pady 4 -row 6 -rowspan 4 -column 2
+grid [ttk::label $buttonFrame.gradentLabel -text "Gradient Buttons:"]\
+-row 10 -column 0 -padx 4 -sticky e
+grid $gradient -pady 4 -row 10 -column 1 -sticky w
+grid [ttk::label $buttonFrame.helpLabel -text "Help Button:"]\
+-row 11 -column 0 -padx 4 -sticky e
+grid $help -row 11 -column 1 -sticky w
+
+#ttk::button .f.b1 -style Toolbutton -image action
+#pack $buttonFrame
+
+# Entries Frame
+set entryFrame [ttk::frame $w.notebook.entries -padding {0 30 80 0}]
+grid columnconfigure $entryFrame 0 -minsize 200
+$w.notebook add $entryFrame -text "Entries"
+
+set textfield [ttk::entry $entryFrame.text -width 17]
+set searchfield [ttk::entry $entryFrame.search -width 1]
+set combo [ttk::combobox $entryFrame.combo -width 1 -textvariable comboVar \
+ -values {"Item 1" "Item 2" "Item 3"}]
+set stepper [ttk::spinbox $entryFrame.stepper -width 1 -textvariable stepVar \
+ -from 99000 -to 101000 -increment 1]
+set stepVar 100000
+searchFocusOut $searchfield
+bind $searchfield <FocusIn> {searchFocusIn %W}
+bind $searchfield <FocusOut> {searchFocusOut %W}
+
+grid [ttk::label $entryFrame.l0 -text "Text Field"] -row 0 -column 0 -padx 20 -sticky e
+grid $textfield -sticky ew -row 0 -column 1 -pady 13
+grid [ttk::label $entryFrame.l1 -text "Search Field"] -row 1 -column 0 -padx 20 -sticky e
+grid $searchfield -sticky ew -row 1 -column 1 -pady 13
+grid [ttk::label $entryFrame.l2 -text "Combo Box"] -row 2 -column 0 -padx 20 -sticky e
+grid $combo -sticky ew -row 2 -column 1 -pady 13
+grid [ttk::label $entryFrame.l3 -text "Stepper"] -row 3 -column 0 -padx 20 -sticky e
+grid $stepper -sticky ew -row 3 -column 1 -pady 13
+
+#Scales Frame
+set scaleFrame [ttk::frame $w.notebook.scales -padding {0 40 0 80}]
+$w.notebook add $scaleFrame -text "Scales"
+
+variable topVar 50
+set topSlider [ttk::scale $scaleFrame.topSlider -from 0 -to 100 \
+ -length 280 -variable topVar]
+set topProgress [ttk::progressbar $scaleFrame.topProgress \
+ -maximum 100 -variable topVar]
+
+variable bottomVar 50
+set bottomSlider [ttk::scale $scaleFrame.bottomSlider -from 0 -to 100 \
+ -length 280 -variable bottomVar]
+$bottomSlider state alternate
+set bottomProgress [ttk::progressbar $scaleFrame.bottomProgress \
+ -maximum 100 -variable bottomVar]
+
+
+grid $topSlider -padx 80 -pady 12 -sticky ew -row 0 -column 0 -columnspan 2
+grid $topProgress -padx 120 -pady 15 -sticky ew -row 1 -column 0 -columnspan 2
+grid [ttk::frame $scaleFrame.spacer] -row 2 -column 0 -columnspan 2 -pady 32
+
+grid $bottomSlider -padx 80 -sticky new -row 3 -column 0 -columnspan 2
+grid [ttk::label $scaleFrame.low -text Low -padding {70 0 0 0}] \
+ -row 4 -column 0 -sticky sw
+grid [ttk::label $scaleFrame.high -text High -padding {0 0 70 0}] \
+ -row 4 -column 1 -sticky se
+grid $bottomProgress -padx 120 -pady 15 -sticky ew -row 5 -column 0 -columnspan 2
+
+#Appearance Frame
+set appearanceFrame [ttk::frame $w.notebook.appearance -padding {0 40 0 80}]
+grid [ttk::label $w.notebook.appearance.info -justify left -padding {0 20 0 40}\
+ -text "Use the image buttons below to view this demo in light or dark mode."] \
+ -row 0 -column 0 -columnspan 3
+set light [ttk::button $appearanceFrame.light -style ImageButton -text Light \
+ -image {field pressed field1 selected field2} \
+ -command "beLight $appearanceFrame $w"]
+grid columnconfigure $appearanceFrame 1 -minsize 10
+grid $light -row 1 -column 0 -sticky e
+set dark [ttk::button $appearanceFrame.dark -style ImageButton -text Dark \
+ -image {starry pressed starry1 selected starry2} \
+ -command "beDark $appearanceFrame $w"]
+grid $dark -row 1 -column 2 -sticky w
+if { [wm attributes $w -isdark] } {
+ $dark state selected
+} else {
+ $light state selected
+}
+proc beLight {f w} {
+ wm attributes $w -appearance aqua
+ # A small delay is needed for the appearance change to complete.
+ after 10 [list $f.dark state !selected]
+ after 10 [list $f.light state selected]
+}
+
+proc beDark {f w} {
+ wm attributes $w -appearance darkaqua
+ # A small delay is needed for the appearance change to complete.
+ after 10 [list $f.light state !selected]
+ after 10 [list $f.dark state selected]
+}
+$w.notebook add $appearanceFrame -text "Appearance"
+
+## See Code / Dismiss
+pack [addSeeDismiss $w.buttons $w] -side bottom -fill x
+
+## Notebook
+pack $w.notebook -side bottom -fill both -expand 1 -padx 16 -pady 16
+
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/mac_styles.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/mac_tabs.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/mac_tabs.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/mac_tabs.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,76 @@
+# mac_tabs.tcl --
+#
+# This demonstration script creates three tabbable windows and allows the
+# wm attributes tabbingid and tabbingmode to be manipulated for the third
+# window, to demonstrate the effects of those attributes.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+catch {font create giant -family {Times New Roman} -size 64}
+set w .mac_tabs
+catch {destroy $w}
+toplevel $w
+wm title $w "Tabbed Windows in Aqua"
+wm iconname $w "mac_tabs"
+positionWindow $w
+set suffix 0
+set winlist {}
+##
+
+## See Code / Dismiss
+pack [addSeeDismiss $w.buttons $w] -side bottom -fill x
+##
+set info "\
+This demo shows 3 toplevels, A, B, and C. \
+Each of these has tabbingmode set to preferred. \
+The tabbingid of Window A is groupA, the \
+tabbingid of Window B is groupB and the tabbingid \
+of Window C is groupC. Use the menubuttons below \
+to see the effect of changing the tabbingid and \
+tabbingmode attributes for Window C. \
+"
+pack [message $w.info -text $info -width 300]
+wm geometry $w +450+350
+
+ttk::frame $w.f
+menu $w.idmenu -tearoff 0
+foreach id {groupA groupB groupC} {
+ $w.idmenu add command -label $id \
+ -command [list wm attributes $w.c -tabbingid $id]
+}
+menu $w.modemenu -tearoff 0
+foreach mode {auto preferred disallowed} {
+ $w.modemenu add command -label $mode \
+ -command [list wm attributes $w.c -tabbingmode $mode]
+}
+ttk::menubutton $w.f.idbutton -menu $w.idmenu -text "tabbingid"\
+ -direction below
+grid $w.f.idbutton -row 0 -column 0
+ttk::menubutton $w.f.modebutton -menu $w.modemenu -text "tabbingmode"\
+ -direction below
+grid $w.f.modebutton -row 1 -column 0
+pack $w.f
+
+wm attributes $w.a -tabbingid groupA
+wm attributes $w.a -tabbingmode preferred
+toplevel $w.a
+wm geometry $w.a +50+100
+wm title $w.a "Window A"
+pack [ttk::label $w.a.l -text A -font giant] -padx 100 -pady 30
+
+wm attributes $w.b -tabbingid groupB
+wm attributes $w.b -tabbingmode preferred
+toplevel $w.b
+wm geometry $w.b +400+100
+wm title $w.b "Window B"
+pack [ttk::label $w.b.l -text B -font giant] -padx 100 -pady 30
+
+wm attributes $w.c -tabbingid groupC
+wm attributes $w.c -tabbingmode preferred
+toplevel $w.c
+wm geometry $w.c +750+100
+wm title $w.c "Window C"
+pack [ttk::label $w.c.l -text C -font giant] -padx 100 -pady 30
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/mac_tabs.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/mac_wm.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/mac_wm.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/mac_wm.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,227 @@
+# mac_window_styles.tcl --
+#
+# This demonstration script creates a toplevel window containing a notebook
+# whose pages provide examples of the various mac-specific widgets that are
+# provided via special values for the -style option.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+set w .mac_wm
+catch {destroy $w}
+toplevel $w
+wm title $w "Tk Aqua Window Styles"
+wm iconname $w "mac_wm"
+positionWindow $w
+set suffix 0
+set winlist {}
+##
+
+## See Code / Dismiss
+pack [addSeeDismiss $w.buttons $w] -side bottom -fill x
+
+proc launch {name windowInfo class} {
+ if {[winfo exists $name]} {
+ wm deiconify $name
+ focus -force $name
+ return
+ }
+ wm attributes $name -class $class; toplevel $name
+ wm title $name $class
+ set f $name.f
+ ttk::frame $f
+ set t $f.t
+ text $t -background systemWindowBackgroundColor \
+ -highlightcolor systemWindowBackgroundColor \
+ -font systemDefaultFont\
+ -wrap word -width 50 -height 6
+ $t insert insert $windowInfo
+ $t configure -state disabled
+ grid columnconfigure $f 0 -weight 1
+ grid $t -row 0 -column 0 -columnspan 2 -sticky NSEW
+ ttk::labelframe $f.stylemask -text "styleMask bits"
+ # titled
+ if {$class == "nswindow"} {
+ ttk::checkbutton $f.stylemask.titled -text titled -variable $name.titled \
+ -command [list setbit $name $f.stylemask.titled titled]
+ $f.stylemask.titled state selected
+ grid $f.stylemask.titled -row 0 -column 0 -sticky w
+ }
+ # closable
+ ttk::checkbutton $f.stylemask.closable -text closable -variable $name.closable \
+ -command [list setbit $name $f.stylemask.closable closable]
+ $f.stylemask.closable state selected
+ grid $f.stylemask.closable -row 1 -column 0 -sticky w
+ # miniaturizableable
+ ttk::checkbutton $f.stylemask.miniaturizable -text miniaturizable \
+ -variable $name.miniaturizable \
+ -command [list setbit $name $f.stylemask.miniaturizable miniaturizable]
+ if {$class == "nswindow"} {
+ $f.stylemask.miniaturizable state selected
+ } else {
+ $f.stylemask.miniaturizable state !alternate
+ }
+ grid $f.stylemask.miniaturizable -row 2 -column 0 -sticky w
+ # resizable
+ ttk::checkbutton $f.stylemask.resizable -text resizable -variable $name.resizable \
+ -command [list setbit $name $f.stylemask.resizable resizable]
+ $f.stylemask.resizable state selected
+ grid $f.stylemask.resizable -row 3 -column 0 -sticky w
+ # docmodal
+ ttk::checkbutton $f.stylemask.docmodal -text docmodal -variable $name.docmodal \
+ -command [list setbit $name $f.stylemask.docmodal docmodal]
+ $f.stylemask.docmodal state !alternate
+ grid $f.stylemask.docmodal -row 4 -column 0 -sticky w
+
+ grid $f.stylemask -row 1 -column 0
+ pack $name.f -side bottom -fill both -expand 1 -padx 16 -pady 16
+}
+
+set info "The command wm attributes window -stylemask ?bitnames? can \
+be used to modify bits in the stylemask property of the NSWindow or \
+NSPanel underlying a Tk Window. Changing these bits causes the \
+style of the window to change. This demo allows you to see the \
+effects of changing the bits. (Note that buttons in the title bar \
+can also be enabled or disabled with the ::tk::unsupported::MacWindowStyle \
+command.)"
+
+set panelInfo "A toplevel based on an NSPanel has a narrower title bar\
+than one based on an NSWindow. In addition the panel remains above all\
+windows on the screen, regardless of which app is active. These are\
+intended to be used as modal windows."
+
+set windowInfo "This is a standard Apple document window, based on an\
+NSWindow. It has a larger title bar and behaves normally with respect\
+to other windows from the same or another app."
+
+## background frame
+set f $w.f
+ttk::frame $f
+set t $f.t
+text $t -background systemWindowBackgroundColor \
+ -highlightcolor systemWindowBackgroundColor \
+ -font systemDefaultFont\
+ -wrap word -width 50 -height 8
+$t insert insert $info
+$t configure -state disabled
+grid columnconfigure $f 0 -weight 1
+grid $t -row 0 -column 0 -columnspan 2 -sticky NSEW
+ttk::labelframe $f.stylemask -text "styleMask"
+grid $f.stylemask -row 1 -column 0
+grid [ttk::button $f.wbw -text "Open an NSWindow" -width 20 \
+ -command [list launch .nswindow $windowInfo nswindow]] -row 2 -column 0
+grid [ttk::button $f.wbp -text "Open an NSPanel" -width 20 \
+ -command [list launch .nspanel $panelInfo nspanel]] -row 3 -column 0
+grid [ttk::button $f.wbm -text "Open a modern window" -width 20 \
+ -command launchModernWindow] -row 4 -column 0
+pack $w.f -side bottom -fill both -expand 1 -padx 16 -pady 16
+
+proc setbit {win cb bitname} {
+ set state [$cb instate selected]
+ set bits [wm attributes $win -stylemask]
+ set index [lsearch $bits $bitname]
+ if {$index >= 0 && !$state} {
+ set bits [lreplace $bits $index $index]
+ }
+ if {$index < 0 && $state} {
+ lappend bits $bitname
+ }
+ wm attributes $win -stylemask $bits
+}
+
+set aboutText \
+"Most of the apps which ship with a contemporary version of macOS \
+feature a window similar to this one, with a left sidebar that \
+allows selecting the content to be shown on the right hand side of \
+the window. These windows do not have a (visible) titlebar.\
+\n\nApps that use such windows include the Finder and the App Store as \
+well as Notes, Messages, Books, Maps and many others.\
+\n\nTo create a window like this one in Tk simply set the fullsizecontent bit \
+in the stylemask. For example:\n\n"
+
+set aboutCode \
+"wm attributes .t -stylemask {titled \\\
+\nfullsizecontent closable miniaturizable \\\
+\nresizable}\n\n"
+
+set detailsText \
+"(1) In the Apple API, setting the fullsizecontent bit in the stylemask \
+only allows content to be drawn in the part of the window covered by \
+the titlebar. In order for that content to be visible the title bar \
+must be transparent. Since it would be pointless to draw content under \
+an opaque title bar, Tk makes the title bar transparent whenever the \
+fullsizecontent bit is set.\
+
+\n\n\(2) Each radio button in the sidebar is a standard ttk::radiobutton \
+but created with a special value for its -style option. The value of the \
+-style option used to create these buttons is SidebarButton.\n"
+
+set whichPage 1
+trace add variable whichPage write "flipPage whichPage"
+proc flipPage {varname args} {
+ global whichPage
+ set newpage [set $varname]
+ grid remove [grid content .mod.right -row 0 -column 0]
+ switch $newpage\
+ 1 {grid .mod.right.about -padx 30 -pady 30 -row 0 -column 0 -sticky nsew}\
+ 2 {grid .mod.right.details -padx 30 -pady 30 -row 0 -column 0 -sticky nsew}
+ update idletasks
+}
+
+proc launchModernWindow {} {
+ global whichPage
+ global aboutText
+ global aboutCode
+ global detailsText
+ if {[winfo exists .mod]} {
+ wm deiconify .mod
+ focus -force .mod
+ return
+ }
+ toplevel .mod
+ wm title .mod {}
+ wm attributes .mod -stylemask {titled fullsizecontent closable \
+ miniaturizable resizable}
+ .mod configure -background white
+ grid columnconfigure .mod 0 -weight 0
+ grid columnconfigure .mod 1 -weight 1
+ grid rowconfigure .mod 0 -weight 1
+ frame .mod.left -width 220 -height 400 -background systemWindowBackgroundColor
+ catch {
+ font create leftFont -family .AppleSystemUIFont -size 11
+ font create rightFont -family .AppleSystemUIFont -size 16
+ font create codeFont -family Courier -size 16
+ }
+ grid [ttk::label .mod.left.spacer -padding {220 30 0 0}] -row 0 -column 0
+ grid [ttk::radiobutton .mod.left.about -text About -style SidebarButton \
+ -variable whichPage -value 1] \
+ -row 1 -column 0 -sticky nsew -padx 14
+ grid [ttk::radiobutton .mod.left.details -text Details -style SidebarButton \
+ -variable whichPage -value 2] \
+ -row 2 -column 0 -sticky nsew -padx 14
+ grid .mod.left -row 0 -column 0 -sticky nsew
+ frame .mod.right -width 500 -background systemTextBackgroundColor
+ grid rowconfigure .mod.right 0 -weight 0
+ text .mod.right.about -highlightcolor systemTextBackgroundColor \
+ -background systemTextBackgroundColor -font rightFont \
+ -highlightthickness 0 -wrap word -width 40
+ .mod.right.about tag configure code -font codeFont
+ .mod.right.about insert end $aboutText
+ .mod.right.about insert end $aboutCode code
+ .mod.right.about configure -state disabled
+
+ text .mod.right.details -highlightcolor systemTextBackgroundColor \
+ -background systemTextBackgroundColor -font rightFont\
+ -highlightthickness 0 -wrap word -width 40
+ .mod.right.details insert end $detailsText
+ .mod.right.details configure -state disabled
+
+ grid .mod.right.about -padx 30 -pady 30 -row 0 -column 0 -sticky nsew
+ grid .mod.right -row 0 -column 1 -sticky nsew
+ wm geometry .mod 800x500
+ update idletasks
+}
+
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/mac_wm.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/mclist.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/mclist.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/mclist.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,170 @@
+# mclist.tcl --
+#
+# This demonstration script creates a toplevel window containing a Ttk
+# tree widget configured as a multi-column listbox.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+set w .mclist
+catch {destroy $w}
+toplevel $w -class MCList
+wm title $w "Multi-Column List"
+wm iconname $w "mclist"
+positionWindow $w
+
+## Explanatory text
+ttk::label $w.msg -font $font -wraplength 4i -justify left -anchor n -padding {10 2 10 6} -text "Ttk is the new Tk themed widget set. One of the widgets it includes is a tree widget, which can be configured to display multiple columns of informational data without displaying the tree itself. This is a simple way to build a listbox that has multiple columns. Clicking on the heading for a column will sort the data by that column. You can also change the width of the columns by dragging the boundary between them."
+pack $w.msg -fill x
+
+## See Code / Dismiss
+pack [addSeeDismiss $w.seeDismiss $w {} {
+ ttk::checkbutton $w.seeDismiss.cb1 -text Grid -variable mclistGrid -command tglGrid
+}] -side bottom -fill x
+
+
+ttk::frame $w.container
+ttk::treeview $w.tree -columns {country capital currency} -show headings \
+ -yscroll "$w.vsb set" -xscroll "$w.hsb set"
+ttk::scrollbar $w.vsb -orient vertical -command "$w.tree yview"
+ttk::scrollbar $w.hsb -orient horizontal -command "$w.tree xview"
+pack $w.container -fill both -expand 1
+grid $w.tree $w.vsb -in $w.container -sticky nsew
+grid $w.hsb -in $w.container -sticky nsew
+grid column $w.container 0 -weight 1
+grid row $w.container 0 -weight 1
+
+set upArrowData {
+ <?xml version="1.0" encoding="UTF-8"?>
+ <svg width="16" height="4" version="1.1" xmlns="http://www.w3.org/2000/svg">
+ <path d="m4 4 4-4 4 4z" fill="#000000"/>
+ </svg>
+}
+
+set downArrowData {
+ <?xml version="1.0" encoding="UTF-8"?>
+ <svg width="16" height="4" version="1.1" xmlns="http://www.w3.org/2000/svg">
+ <path d="m4 0 4 4 4-4z" fill="#000000"/>
+ </svg>
+}
+
+proc createArrowImages {} {
+ set fgColor [ttk::style lookup . -foreground {} black]
+ lassign [winfo rgb . $fgColor] r g b
+ set fgColor [format "#%02x%02x%02x" \
+ [expr {$r >> 8}] [expr {$g >> 8}] [expr {$b >> 8}]]
+
+ foreach dir {up down} {
+ upvar ${dir}ArrowData imgData
+ set idx1 [string first "#000000" $imgData]
+ set idx2 [expr {$idx1 + 6}]
+ set data [string replace $imgData $idx1 $idx2 $fgColor]
+
+ image create photo ${dir}Arrow -format $::tk::svgFmt -data $data]
+ }
+}
+
+createArrowImages
+foreach event {<<ThemeChanged>> <<LightAqua>> <<DarkAqua>>} {
+ bind MCList $event { createArrowImages }
+}
+unset event
+
+image create photo noArrow -format $tk::svgFmt -data {
+ <?xml version="1.0" encoding="UTF-8"?>
+ <svg width="16" height="4" version="1.1" xmlns="http://www.w3.org/2000/svg">
+ </svg>
+}
+
+## The data we're going to insert
+set data {
+ Argentina {Buenos Aires} ARS
+ Australia Canberra AUD
+ Brazil Brazilia BRL
+ Canada Ottawa CAD
+ China Beijing CNY
+ France Paris EUR
+ Germany Berlin EUR
+ India {New Delhi} INR
+ Italy Rome EUR
+ Japan Tokyo JPY
+ Mexico {Mexico City} MXN
+ Russia Moscow RUB
+ {South Africa} Pretoria ZAR
+ {United Kingdom} London GBP
+ {United States} {Washington, D.C.} USD
+}
+
+## Code to insert the data nicely
+set font [ttk::style lookup Heading -font {} TkDefaultFont]
+set morePx [expr {[image width noArrow] + round(4 * $tk::scalingPct / 100.0)}]
+foreach col {country capital currency} name {Country Capital Currency} {
+ $w.tree heading $col -text $name -image noArrow -anchor w \
+ -command [list SortBy $w.tree $col 0]
+ $w.tree column $col -width [expr {[font measure $font $name] + $morePx}]
+}
+set font [ttk::style lookup Treeview -font {} TkDefaultFont]
+foreach {country capital currency} $data {
+ $w.tree insert {} end -values [list $country $capital $currency]
+ foreach col {country capital currency} {
+ set len [font measure $font "[set $col] "]
+ if {[$w.tree column $col -width] < $len} {
+ $w.tree column $col -width $len
+ }
+ }
+}
+
+## Code to do the sorting of the tree contents when clicked on
+proc SortBy {tree col direction} {
+ # Determine currently sorted column and its sort direction
+ foreach c {country capital currency} {
+ set s [$tree heading $c state]
+ if {("selected" in $s || "alternate" in $s) && $col ne $c} {
+ # Sorted column has changed
+ $tree heading $c -image noArrow state {!selected !alternate !user1}
+ set direction [expr {"alternate" in $s}]
+ }
+ }
+
+ # Build something we can sort
+ set data {}
+ foreach row [$tree children {}] {
+ lappend data [list [$tree set $row $col] $row]
+ }
+
+ set dir [expr {$direction ? "-decreasing" : "-increasing"}]
+ set r -1
+
+ # Now reshuffle the rows into the sorted order
+ foreach info [lsort -dictionary -index 0 $dir $data] {
+ $tree move [lindex $info 1] {} [incr r]
+ }
+
+ # Switch the heading so that it will sort in the opposite direction
+ $tree heading $col -command [list SortBy $tree $col [expr {!$direction}]] \
+ state [expr {$direction?"!selected alternate":"selected !alternate"}]
+ if {[ttk::style theme use] eq "aqua"} {
+ # Aqua theme displays native sort arrows when user1 state is set
+ $tree heading $col state "user1"
+ } else {
+ $tree heading $col -image [expr {$direction?"upArrow":"downArrow"}]
+ }
+}
+
+set mclistGrid 0
+proc tglGrid {} {
+ if {$::mclistGrid} {
+ .mclist.tree configure -stripe 1
+ foreach col [.mclist.tree cget -columns] {
+ .mclist.tree column $col -separator 1
+ }
+ } else {
+ .mclist.tree configure -stripe 0
+ foreach col [.mclist.tree cget -columns] {
+ .mclist.tree column $col -separator 0
+ }
+ }
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/mclist.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/menu.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/menu.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/menu.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,184 @@
+# menu.tcl --
+#
+# This demonstration script creates a window with a bunch of menus
+# and cascaded menus using menubars.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+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 {[tk windowingsystem] eq "aqua"} {
+ $w.msg configure -text "This window has 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 selecting the first item in the menu."
+} 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
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+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 {[tk windowingsystem] eq "aqua"} {
+ set modifier Command
+} elseif {[tk windowingsystem] eq "win32"} {
+ 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 $modifier+$i -command "puts $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
+# Main widget program sets variable tk_demoDirectory
+image create photo lilearth -file [file join $tk_demoDirectory \
+images earthmenu.png]
+$m add command -image lilearth \
+ -hidemargin 1 -command [list \
+ tk_dialog $w.pattern {Bitmap Menu Entry} \
+ "The menu entry you invoked displays a photoimage 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 -hidemargin 1 -command [list \
+ puts "You invoked the $i bitmap" ]
+}
+$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} {Does almost nothing also} {Make life meaningful}} {
+ $m add command -label $i -command [list puts "You invoked \"$i\""]
+}
+set emojiLabel [encoding convertfrom utf-8 "\xF0\x9F\x98\x8D Make friends"]
+$m add command -label $emojiLabel -command [list puts "Menu labels can include non-BMP characters."]
+$m entryconfigure "Does almost nothing" -bitmap questhead -compound left \
+ -command [list \
+ tk_dialog $w.compound {Compound Menu Entry} \
+ "The menu entry you invoked displays both a bitmap and a\
+ text string. Other than this, it is just like any other\
+ menu entry." {} 0 OK ]
+
+$m entryconfigure "Does almost nothing also" -image lilearth -compound left \
+ -command [list \
+ tk_dialog $w.compound {Compound Menu Entry} \
+ "The menu entry you invoked displays both a image and a\
+ text string. Other than this, it is just like any other\
+ menu entry." {} 0 OK ]
+
+set m $w.menu.colors
+$w.menu add cascade -label "Colors" -menu $m -underline 1
+menu $m -tearoff 1
+if {[tk windowingsystem] eq "aqua"} {
+ # Aqua ignores the -background and -foreground options, but a compound
+ # button can be used for selecting colors.
+ foreach i {red orange yellow green blue} {
+ image create photo image_$i -height 16 -width 16
+ image_$i put black -to 0 0 16 1
+ image_$i put black -to 0 1 1 16
+ image_$i put black -to 0 15 16 16
+ image_$i put black -to 15 1 16 16
+ image_$i put $i -to 1 1 15 15
+ $m add command -label $i -image image_$i -compound left -command [list \
+ puts "You invoked \"$i\"" ]
+ }
+} else {
+ 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 <<MenuSelect>> {
+ global $menustatus
+ if {[catch {%W entrycget active -label} label]} {
+ set label " "
+ }
+ set menustatus $label
+ update idletasks
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/menu.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/menubu.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/menubu.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/menubu.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,90 @@
+# menubu.tcl --
+#
+# This demonstration script creates a window with a bunch of menus
+# and cascaded menus using menubuttons.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+set w .menubu
+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
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+set body $w.body.center
+label $body.label -wraplength 225p -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 18p -pady 18p
+frame $body.buttons
+pack $body.buttons -padx 18p -pady 18p
+tk_optionMenu $body.buttons.options menubuttonoptions one two three
+pack $body.buttons.options -side left -padx 18p -pady 18p
+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 {[tk windowingsystem] eq "aqua"} {
+ set topBorderColor Black
+ set bottomBorderColor Black
+} else {
+ set topBorderColor gray50
+ set bottomBorderColor gray75
+}
+set dim [expr {round(16 * $tk::scalingPct / 100.0)}]
+set dim1 [expr {$dim - 1}]
+set dim2 [expr {$dim - 2}]
+for {set i 0} {$i <= [$m index last]} {incr i} {
+ set name [$m entrycget $i -label]
+ image create photo image_$name -height $dim -width $dim
+ image_$name put $topBorderColor -to 0 0 $dim 1
+ image_$name put $topBorderColor -to 0 1 1 $dim
+ image_$name put $bottomBorderColor -to 0 $dim1 $dim $dim
+ image_$name put $bottomBorderColor -to $dim1 1 $dim $dim
+ image_$name put $name -to 1 1 $dim1 $dim1
+
+ image create photo image_${name}_s -height $dim -width $dim
+ image_${name}_s put Black -to 0 0 $dim 2
+ image_${name}_s put Black -to 0 2 2 $dim
+ image_${name}_s put Black -to 2 $dim2 $dim $dim
+ image_${name}_s put Black -to $dim2 2 $dim $dim2
+ image_${name}_s put $name -to 2 2 $dim2 $dim2
+
+ $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 18p -pady 18p
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/menubu.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/msgbox.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/msgbox.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/msgbox.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,62 @@
+# msgbox.tcl --
+#
+# This demonstration script creates message boxes of various type
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+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
+
+pack [addSeeDismiss $w.buttons $w {} {
+ ttk::button $w.buttons.vars -text "Message Box" -command "showMessageBox $w"
+}] -side bottom -fill x
+#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 1.5p -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 1.5p -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
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/msgbox.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/nl.msg
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/nl.msg (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/nl.msg 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,132 @@
+::msgcat::mcset nl "Widget Demonstration" "Demonstratie van widgets"
+::msgcat::mcset nl "tkWidgetDemo"
+::msgcat::mcset nl "&File" "&Bestand"
+::msgcat::mcset nl "About..." "Info..."
+::msgcat::mcset nl "&About..." "&Info..."
+::msgcat::mcset nl "<F1>" "<F1>"
+::msgcat::mcset nl "&Quit" "&Einde"
+::msgcat::mcset nl "Meta+Q" "Meta+E" ;# Displayed hotkey
+::msgcat::mcset nl "Meta-q" "Meta-e" ;# Actual binding sequence
+::msgcat::mcset nl "Ctrl+Q" "Ctrl+E" ;# Displayed hotkey
+::msgcat::mcset nl "Control-q" "Control-e" ;# Actual binding sequence
+::msgcat::mcset nl "See Variables" "Bekijk Variabelen"
+::msgcat::mcset nl "Variable values" "Waarden variabelen"
+::msgcat::mcset nl "Variable values:" "Waarden variabelen"
+::msgcat::mcset nl "OK"
+::msgcat::mcset nl "Run the \"%s\" sample program" "Start voorbeeld \"%s\""
+::msgcat::mcset nl "Dismiss" "Sluiten"
+::msgcat::mcset nl "Rerun Demo" "Herstart Demo" ;# This is also button text!
+::msgcat::mcset nl "Print Code" "Code Afdrukken"
+::msgcat::mcset nl "Demo code: %s" "Code van Demo %s"
+::msgcat::mcset nl "About Widget Demo" "Over deze demonstratie"
+::msgcat::mcset nl "Tk widget demonstration" "Demonstratie van Tk widgets"
+::msgcat::mcset nl "Copyright © %s"
+
+::msgcat::mcset nl "Tk Widget Demonstrations" "Demonstratie van Tk widgets"
+::msgcat::mcset nl "This application provides a front end for several short scripts" \
+ "Dit programma is een schil rond enkele korte scripts waarmee"
+::msgcat::mcset nl "that demonstrate what you can do with Tk widgets. Each of the" \
+ "gedemonstreerd wordt wat je kunt doen met Tk widgets. Elk van de"
+::msgcat::mcset nl "numbered lines below describes a demonstration; you can click on" \
+ "genummerde regels hieronder omschrijft een demonstratie; je kunt de"
+::msgcat::mcset nl "it to invoke the demonstration. Once the demonstration window" \
+ "demonstratie starten door op de regel te klikken."
+::msgcat::mcset nl "appears, you can click the" \
+ "Zodra het nieuwe venster verschijnt, kun je op de knop"
+::msgcat::mcset nl "See Code" "Bekijk Code" ;# This is also button text!
+::msgcat::mcset nl "button to see the Tcl/Tk code that created the demonstration. If" \
+ "drukken om de achterliggende Tcl/Tk code te zien. Als je dat wilt,"
+::msgcat::mcset nl "you wish, you can edit the code and click the" \
+ "kun je de code wijzigen en op de knop"
+::msgcat::mcset nl "button in the code window to reinvoke the demonstration with the" \
+ "drukken in het codevenster om de demonstratie uit te voeren met de"
+::msgcat::mcset nl "modified code." \
+ "nieuwe code."
+
+::msgcat::mcset nl "Labels, buttons, checkbuttons, and radiobuttons" \
+ "Labels, knoppen, vinkjes/aankruishokjes en radioknoppen"
+::msgcat::mcset nl "Labels (text and bitmaps)" "Labels (tekst en plaatjes)"
+::msgcat::mcset nl "Labels and UNICODE text" "Labels en tekst in UNICODE"
+::msgcat::mcset nl "Buttons" "Buttons (drukknoppen)"
+::msgcat::mcset nl "Check-buttons (select any of a group)" \
+ "Check-buttons (een of meer uit een groep)"
+::msgcat::mcset nl "Radio-buttons (select one of a group)" \
+ "Radio-buttons (een van een groep)"
+::msgcat::mcset nl "A 15-puzzle game made out of buttons" \
+ "Een schuifpuzzel van buttons"
+::msgcat::mcset nl "Iconic buttons that use bitmaps" \
+ "Buttons met pictogrammen"
+::msgcat::mcset nl "Two labels displaying images" \
+ "Twee labels met plaatjes in plaats van tekst"
+::msgcat::mcset nl "A simple user interface for viewing images" \
+ "Een eenvoudige user-interface voor het bekijken van plaatjes"
+::msgcat::mcset nl "Labelled frames" \
+ "Kaders met bijschrift"
+
+::msgcat::mcset nl "Listboxes" "Keuzelijsten"
+::msgcat::mcset nl "The 50 states" "De 50 staten van de VS"
+::msgcat::mcset nl "Colors: change the color scheme for the application" \
+ "Kleuren: verander het kleurenschema voor het programma"
+::msgcat::mcset nl "A collection of famous and infamous sayings" \
+ "Beroemde en beruchte citaten en gezegden"
+
+::msgcat::mcset nl "Entries and Spin-boxes" "Invulvelden en Spinboxen"
+::msgcat::mcset nl "Entries without scrollbars" "Invulvelden zonder schuifbalk"
+::msgcat::mcset nl "Entries with scrollbars" "Invulvelden met schuifbalk"
+::msgcat::mcset nl "Validated entries and password fields" \
+ "Invulvelden met controle of wachtwoorden"
+::msgcat::mcset nl "Spin-boxes" "Spinboxen"
+::msgcat::mcset nl "Simple Rolodex-like form" "Simpel kaartsysteem"
+
+::msgcat::mcset nl "Text" "Tekst"
+::msgcat::mcset nl "Basic editable text" "Voorbeeld met te wijzigen tekst"
+::msgcat::mcset nl "Text display styles" "Tekst met verschillende stijlen"
+::msgcat::mcset nl "Hypertext (tag bindings)" \
+ "Hypertext (verwijzingen via \"tags\")"
+::msgcat::mcset nl "A text widget with embedded windows" \
+ "Tekstwidget met windows erin"
+::msgcat::mcset nl "A search tool built with a text widget" \
+ "Zoeken in tekst met behulp van een tekstwidget"
+
+::msgcat::mcset nl "Canvases" "Canvaswidgets"
+::msgcat::mcset nl "The canvas item types" "Objecten in een canvas"
+::msgcat::mcset nl "A simple 2-D plot" "Eenvoudige 2D-grafiek"
+::msgcat::mcset nl "Text items in canvases" "Tekstobjecten in een canvas"
+::msgcat::mcset nl "An editor for arrowheads on canvas lines" \
+ "Editor voor de vorm van de pijl (begin/eind van een lijn)"
+::msgcat::mcset nl "A ruler with adjustable tab stops" \
+ "Een meetlat met aanpasbare ruiters"
+::msgcat::mcset nl "A building floor plan" "Plattegrond van een gebouw"
+::msgcat::mcset nl "A simple scrollable canvas" "Een schuifbaar canvas"
+
+::msgcat::mcset nl "Scales" "Schaalverdelingen"
+::msgcat::mcset nl "Horizontal scale" "Horizontale schaal"
+::msgcat::mcset nl "Vertical scale" "Verticale schaal"
+
+::msgcat::mcset nl "Paned Windows" "Vensters opgedeeld in stukken"
+::msgcat::mcset nl "Horizontal paned window" "Horizontaal gedeeld venster"
+::msgcat::mcset nl "Vertical paned window" "Verticaal gedeeld venster"
+::msgcat::mcset nl "Menus" "Menu's"
+::msgcat::mcset nl "Menus and cascades (sub-menus)" \
+ "Menu's en cascades (submenu's)"
+::msgcat::mcset nl "Menu-buttons" "Menu-buttons"
+::msgcat::mcset nl "Common Dialogs" "Veel voorkomende dialoogvensters"
+::msgcat::mcset nl "Message boxes" "Mededeling (message box)"
+::msgcat::mcset nl "File selection dialog" "Selectie van bestanden"
+::msgcat::mcset nl "Color picker" "Kleurenpalet"
+::msgcat::mcset nl "Font selection dialog" "Selectie van fonts"
+::msgcat::mcset nl "System tray icon and notification" "Systeemvakpictogram en melding"
+::msgcat::mcset nl "Printing from canvas and text widgets" "Afdrukken van canvas en tekst widgets"
+::msgcat::mcset nl "Animation" "Animaties"
+::msgcat::mcset nl "Animated labels" "Geanimeerde labels"
+::msgcat::mcset nl "Animated wave" "Geanimeerde golf"
+::msgcat::mcset nl "Pendulum simulation" "Pendulum simulatie"
+::msgcat::mcset nl "A celebration of Rube Goldberg" "Een viering van Rube Goldberg"
+::msgcat::mcset nl "Miscellaneous" "Diversen"
+::msgcat::mcset nl "The built-in bitmaps" "Ingebouwde plaatjes"
+::msgcat::mcset nl "A dialog box with a local grab" \
+ "Een dialoogvenster met een locale \"grab\""
+::msgcat::mcset nl "A dialog box with a global grab" \
+ "Een dialoogvenster met een globale \"grab\""
+::msgcat::mcset nl "Window icons and badges" "Vensterpictogrammen en badges"
+
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/nl.msg
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/paned1.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/paned1.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/paned1.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,32 @@
+# paned1.tcl --
+#
+# This demonstration script creates a toplevel window containing
+# a paned window that separates two windows horizontally.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+set w .paned1
+catch {destroy $w}
+toplevel $w
+wm title $w "Horizontal Paned Window Demonstration"
+wm iconname $w "paned1"
+positionWindow $w
+
+label $w.msg -font $font -wraplength 4i -justify left -text "The sash between the two coloured windows below can be used to divide the area between them. Use the left mouse button to resize without redrawing by just moving the sash, and use the middle mouse button to resize opaquely (always redrawing the windows in each position.)"
+pack $w.msg -side top
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+panedwindow $w.pane
+pack $w.pane -side top -expand yes -fill both -pady 1.5p -padx 2m
+
+label $w.pane.left -text "This is the\nleft side" -fg black -bg yellow
+label $w.pane.right -text "This is the\nright side" -fg black -bg cyan
+
+$w.pane add $w.pane.left $w.pane.right -stretch always
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/paned1.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/paned2.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/paned2.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/paned2.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,74 @@
+# paned2.tcl --
+#
+# This demonstration script creates a toplevel window containing
+# a paned window that separates two windows vertically.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+set w .paned2
+catch {destroy $w}
+toplevel $w
+wm title $w "Vertical Paned Window Demonstration"
+wm iconname $w "paned2"
+positionWindow $w
+
+label $w.msg -font $font -wraplength 4i -justify left -text "The sash between the two scrolled windows below can be used to divide the area between them. Use the left mouse button to resize without redrawing by just moving the sash, and use the middle mouse button to resize opaquely (always redrawing the windows in each position.)"
+pack $w.msg -side top
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+# Create the pane itself
+panedwindow $w.pane -orient vertical
+pack $w.pane -side top -expand yes -fill both -pady 1.5p -padx 2m
+
+# The top window is a listbox with scrollbar
+set paneList {
+ {List of Tk Widgets}
+ button
+ canvas
+ checkbutton
+ entry
+ frame
+ label
+ labelframe
+ listbox
+ menu
+ menubutton
+ message
+ panedwindow
+ radiobutton
+ scale
+ scrollbar
+ spinbox
+ text
+ toplevel
+}
+set f [frame $w.pane.top]
+listbox $f.list -listvariable paneList -yscrollcommand "$f.scr set"
+# Invert the first item to highlight it
+$f.list itemconfigure 0 \
+ -background [$f.list cget -fg] -foreground [$f.list cget -bg]
+ttk::scrollbar $f.scr -orient vertical -command "$f.list yview"
+pack $f.scr -side right -fill y
+pack $f.list -fill both -expand 1
+
+# The bottom window is a text widget with scrollbar
+set f [frame $w.pane.bottom]
+text $f.text -xscrollcommand "$f.xscr set" -yscrollcommand "$f.yscr set" \
+ -width 30 -height 8 -wrap none
+ttk::scrollbar $f.xscr -orient horizontal -command "$f.text xview"
+ttk::scrollbar $f.yscr -orient vertical -command "$f.text yview"
+grid $f.text $f.yscr -sticky nsew
+grid $f.xscr -sticky nsew
+grid columnconfigure $f 0 -weight 1
+grid rowconfigure $f 0 -weight 1
+$f.text insert 1.0 "This is just a normal text widget"
+
+# Now add our contents to the paned window
+$w.pane add $w.pane.top $w.pane.bottom -stretch always
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/paned2.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/pendulum.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/pendulum.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/pendulum.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,206 @@
+# pendulum.tcl --
+#
+# This demonstration illustrates how Tcl/Tk can be used to construct
+# simulations of physical systems.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+set w .pendulum
+catch {destroy $w}
+toplevel $w
+wm title $w "Pendulum Animation Demonstration"
+wm iconname $w "pendulum"
+positionWindow $w
+
+label $w.msg -font $font -wraplength 4i -justify left -text "This demonstration shows how Tcl/Tk can be used to carry out animations that are linked to simulations of physical systems. In the left canvas is a graphical representation of the physical system itself, a simple pendulum, and in the right canvas is a graph of the phase space of the system, which is a plot of the angle (relative to the vertical) against the angular velocity. The pendulum bob may be repositioned by clicking and dragging anywhere on the left canvas."
+pack $w.msg
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+# Create some structural widgets
+pack [panedwindow $w.p] -fill both -expand 1
+$w.p add [labelframe $w.p.l1 -text "Pendulum Simulation"] -stretch always
+$w.p add [labelframe $w.p.l2 -text "Phase Space"] -stretch always
+
+# Create the canvas containing the graphical representation of the
+# simulated system.
+canvas $w.c -width 240p -height 150p -background white -bd 1.5p -relief sunken
+$w.c create text 3p 3p -anchor nw -text "Click to Adjust Bob Start Position"
+# Coordinates of these items don't matter; they will be set properly below
+$w.c create line 0 25 320 25 -tags plate -fill grey50 -width 1.5p
+$w.c create oval 155 20 165 30 -tags pivot -fill grey50 -outline {}
+$w.c create line 1 1 1 1 -tags rod -fill black -width 2.25p
+$w.c create oval 1 1 2 2 -tags bob -fill yellow -outline black
+pack $w.c -in $w.p.l1 -fill both -expand true
+
+# Create the canvas containing the phase space graph; this consists of
+# a line that gets gradually paler as it ages, which is an extremely
+# effective visual trick.
+canvas $w.k -width 240p -height 150p -background white -bd 1.5p -relief sunken
+$w.k create line 120p 150p 120p 0 -fill grey75 -arrow last -tags y_axis
+$w.k create line 0 75p 240p 75p -fill grey75 -arrow last -tags x_axis
+for {set i 90} {$i>=0} {incr i -10} {
+ # Coordinates of these items don't matter; they will be set properly below
+ $w.k create line 0 0 1 1 -smooth true -tags graph$i -fill grey$i
+}
+
+$w.k create text 0 0 -anchor ne -text "θ" -tags label_theta
+$w.k create text 0 0 -anchor ne -text "δθ" -tags label_dtheta
+pack $w.k -in $w.p.l2 -fill both -expand true
+
+# Initialize some variables
+set points {}
+set Theta 45.0
+set dTheta 0.0
+set pi 3.1415926535897933
+set tkScl [tk scaling]
+set length [expr {round(111*$tkScl)}] ;# 111p -> pixels
+set xHome [expr {round(120*$tkScl)}] ;# 120p -> pixels
+set yHome [expr {round( 18*$tkScl)}] ;# 18p -> pixels
+set rBob [expr {round( 12*$tkScl)}] ;# 12p -> pixels
+set rPivot [expr {round( 3*$tkScl)}] ;# 3p -> pixels
+
+# This procedure makes the pendulum appear at the correct place on the
+# canvas. If the additional arguments "at $x $y" are passed (the 'at'
+# is really just syntactic sugar) instead of computing the position of
+# the pendulum from the length of the pendulum rod and its angle, the
+# length and angle are computed in reverse from the given location
+# (which is taken to be the centre of the pendulum bob.)
+proc showPendulum {canvas {at {}} {x {}} {y {}}} {
+ global Theta dTheta pi length xHome yHome rBob
+
+ if {$at eq "at" && ($x!=$xHome || $y!=$yHome)} {
+ set dTheta 0.0
+ set x2 [expr {$x - $xHome}]
+ set y2 [expr {$y - $yHome}]
+ set length [expr {hypot($x2, $y2)}]
+ set Theta [expr {atan2($x2, $y2) * 180/$pi}]
+ } else {
+ set angle [expr {$Theta * $pi/180}]
+ set x [expr {$xHome + $length*sin($angle)}]
+ set y [expr {$yHome + $length*cos($angle)}]
+ }
+ $canvas coords rod $xHome $yHome $x $y
+ $canvas coords bob [expr {$x - $rBob}] [expr {$y - $rBob}] \
+ [expr {$x + $rBob}] [expr {$y + $rBob}]
+}
+showPendulum $w.c
+
+# Update the phase-space graph according to the current angle and the
+# rate at which the angle is changing (the first derivative with
+# respect to time.)
+proc showPhase {canvas} {
+ global Theta dTheta points psw psh
+ set sclFactor [expr {$tk::scalingPct / 100.0}]
+
+ lappend points [expr {$Theta + $psw}] [expr {-20*$sclFactor*$dTheta + $psh}]
+ if {[llength $points] > 100} {
+ set points [lrange $points end-99 end]
+ }
+ for {set i 0} {$i<100} {incr i 10} {
+ set list [lrange $points end-[expr {$i-1}] end-[expr {$i-12}]]
+ if {[llength $list] >= 4} {
+ $canvas coords graph$i $list
+ $canvas scale graph$i $psw $psh $sclFactor $sclFactor
+ }
+ }
+}
+
+# Set up some bindings on the canvases. Note that when the user
+# clicks we stop the animation until they release the mouse
+# button. Also note that both canvases are sensitive to <Configure>
+# events, which allows them to find out when they have been resized by
+# the user.
+bind $w.c <Destroy> {
+ after cancel $animationCallbacks(pendulum)
+ unset animationCallbacks(pendulum)
+}
+bind $w.c <Button-1> {
+ after cancel $animationCallbacks(pendulum)
+ showPendulum %W at %x %y
+}
+bind $w.c <B1-Motion> {
+ showPendulum %W at %x %y
+}
+bind $w.c <ButtonRelease-1> {
+ showPendulum %W at %x %y
+ set animationCallbacks(pendulum) [after 15 repeat [winfo toplevel %W]]
+}
+bind $w.c <Configure> {
+ %W coords plate 0 18p %w 18p
+ set xHome [expr {%w/2}]
+ %W coords pivot [expr {$xHome - $rPivot}] 15p [expr {$xHome + $rPivot}] 21p
+}
+bind $w.k <Configure> {
+ set psh [expr {%h/2}]
+ set psw [expr {%w/2}]
+ %W coords x_axis 1.5p $psh [expr {%w - round(1.5*$tkScl)}] $psh
+ %W coords y_axis $psw [expr {%h - round(1.5*$tkScl)}] $psw 1.5p
+ %W coords label_dtheta [expr {$psw - round(3*$tkScl)}] 4.5p
+ %W coords label_theta [expr {%w - round(4.5*$tkScl)}] \
+ [expr {$psh + round(3*$tkScl)}]
+}
+
+# This procedure is the "business" part of the simulation that does
+# simple numerical integration of the formula for a simple rotational
+# pendulum.
+proc recomputeAngle {} {
+ global Theta dTheta pi length
+ set scaling [expr {3000.0/$length/$length}]
+
+ # To estimate the integration accurately, we really need to
+ # compute the end-point of our time-step. But to do *that*, we
+ # need to estimate the integration accurately! So we try this
+ # technique, which is inaccurate, but better than doing it in a
+ # single step. What we really want is bound up in the
+ # differential equation:
+ # .. - sin theta
+ # theta + theta = -----------
+ # length
+ # But my math skills are not good enough to solve this!
+
+ # first estimate
+ set firstDDTheta [expr {-sin($Theta * $pi/180)*$scaling}]
+ set midDTheta [expr {$dTheta + $firstDDTheta}]
+ set midTheta [expr {$Theta + ($dTheta + $midDTheta)/2}]
+ # second estimate
+ set midDDTheta [expr {-sin($midTheta * $pi/180)*$scaling}]
+ set midDTheta [expr {$dTheta + ($firstDDTheta + $midDDTheta)/2}]
+ set midTheta [expr {$Theta + ($dTheta + $midDTheta)/2}]
+ # Now we do a double-estimate approach for getting the final value
+ # first estimate
+ set midDDTheta [expr {-sin($midTheta * $pi/180)*$scaling}]
+ set lastDTheta [expr {$midDTheta + $midDDTheta}]
+ set lastTheta [expr {$midTheta + ($midDTheta + $lastDTheta)/2}]
+ # second estimate
+ set lastDDTheta [expr {-sin($lastTheta * $pi/180)*$scaling}]
+ set lastDTheta [expr {$midDTheta + ($midDDTheta + $lastDDTheta)/2}]
+ set lastTheta [expr {$midTheta + ($midDTheta + $lastDTheta)/2}]
+ # Now put the values back in our globals
+ set dTheta $lastDTheta
+ set Theta $lastTheta
+}
+
+# This method ties together the simulation engine and the graphical
+# display code that visualizes it.
+proc repeat w {
+ global animationCallbacks
+
+ # Simulate
+ recomputeAngle
+
+ # Update the display
+ showPendulum $w.c
+ showPhase $w.k
+
+ # Reschedule ourselves
+ set animationCallbacks(pendulum) [after 15 [list repeat $w]]
+}
+# Start the simulation after a short pause
+set animationCallbacks(pendulum) [after 500 [list repeat $w]]
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/pendulum.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/plot.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/plot.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/plot.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,97 @@
+# plot.tcl --
+#
+# This demonstration script creates a canvas widget showing a 2-D
+# plot with data points that can be dragged with the mouse.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+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
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+canvas $c -relief raised -width 337.5p -height 225p
+pack $w.c -side top -fill x
+
+set plotFont {Helvetica 16}
+
+$c create line 75p 187.5p 300p 187.5p -width 1.5p
+$c create line 75p 187.5p 75p 37.5p -width 1.5p
+$c create text 168.75p 15p -text "A Simple Plot" -font $plotFont -fill brown
+
+for {set i 0} {$i <= 10} {incr i} {
+ set x [expr {75 + ($i*22.5)}] ;# in points
+ $c create line ${x}p 187.5p ${x}p 183.75p -width 1.5p
+ $c create text ${x}p 190.5p -text [expr {10*$i}] -anchor n -font $plotFont
+}
+for {set i 0} {$i <= 5} {incr i} {
+ set y [expr {187.5 - ($i*30)}] ;# in points
+ $c create line 75p ${y}p 78.75p ${y}p -width 1.5p
+ $c create text 72p ${y}p -text [expr {$i*50}].0 -anchor e -font $plotFont
+}
+
+foreach point {
+ {9 42} {15 70.5} {24.75 73.5} {24 90} {45.75 135} {56.25 120} {73.5 167.25}
+} {
+ set x [expr {75 + (2.25*[lindex $point 0])}] ;# in points
+ set y [expr {187.5 - (3*[lindex $point 1])/5}] ;# in points
+ set item [$c create oval [expr {$x-4.5}]p [expr {$y-4.5}]p \
+ [expr {$x+4.5}]p [expr {$y+4.5}]p -width 0.75p -outline black \
+ -fill SkyBlue2]
+ $c addtag point withtag $item
+}
+
+$c bind point <Enter> "$c itemconfig current -fill red"
+$c bind point <Leave> "$c itemconfig current -fill SkyBlue2"
+$c bind point <Button-1> "plotDown $c %x %y"
+$c bind point <ButtonRelease-1> "$c dtag selected"
+bind $c <B1-Motion> "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
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/plot.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/print.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/print.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/print.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,90 @@
+# print.tcl --
+#
+# This demonstration script showcases the tk print commands.
+#
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+set w .print
+destroy $w
+toplevel $w
+wm title $w "Printing Demonstration"
+positionWindow $w
+
+pack [label $w.l -text "This demonstration showcases
+the tk print command. Clicking the buttons below
+prints the data from the canvas and text widgets
+using platform-native dialogs."] -side top
+
+## See Code / Dismiss buttons
+pack [addSeeDismiss $w.buttons $w] -side bottom -fill x
+
+frame $w.m
+
+image create photo logo -data {
+R0lGODlhMABLAPUAAP//////zP//mf//AP/MzP/Mmf/MAP+Zmf+ZZv+ZAMz//8zM/8zMzMyZzMyZ
+mcyZZsyZAMxmZsxmM8xmAMwzM8wzAJnMzJmZzJmZmZlmmZlmZplmM5kzZpkzM5kzAGaZzGZmzGZm
+mWYzZmYzMzNmzDNmmTMzmTMzZgAzmQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH+BSAtZGwtACH5BAEKAAIALAAAAAAw
+AEsAAAb+QIFwSCwahY9HRMI8Op/JJVNSqVqv2OvjyRU8slbIJGwYg60S5ZR6jRi/4ITBOhkYIOd8
+dltEnAdmFQMJeoVXCEd/VnKGjRVOZ3NVgHlsjpBxVRCEYBIEAAARl4lgZmVgEQAKFx8Mo0ZnpqgA
+Fyi2JqKGmGebWRIAILbCIo27cYFWASTCtievRXqSVwQfzLYeeYESxlnSVRIW1igjWHJmjBXbpKXe
+FQTizlh1eJNVHbYf0LGc39XW2PIoVZE0whasWPSqFBBHrkKEA3QG0DFTEMXBUsjCWesg4oMFAGwg
+tKsiwqA+jGiCiRPGAM6pLCVLGKHQ6EGJlc0IuDxzAgX+CCOW9DjAaUsEyAoT+GHpeSRoHgxEUWgA
+UEUpFhMWgTbKEPUBAU15TBZxekYD0RMEqCDLIpYIWTAcmGEd9rWQBxQyjeQqdK/ZTWEO3mK5l+9N
+o75SrcHhm9WwnlzNoA5zdM+JHz0HCPQdUauZowoFnSw+c2CBvw6dUXT4LMKE6EIHUqMexgCiIREk
+nOwl7Q+FhNQoLuzOc6Kw3kIIVOLqjYKBYCwinmgo9CBEswfMAziK7mRDoQhcUZxwoBKFibq3n3jX
+I0GyCPLC0DrS8GR1oaEoRBRYVhT99/qG4DcCA/yNU4Ajbjhhnx4P2DJggR3YZog6RyyYxwM9PSgM
+BaP+sQdgIRL0JAKBwnTooRMAFWLdiPyJ8JwvTnyQoh5midCASh149ZkTIFAmHnzOZOBfIU6U4Mhd
+4zF34DNEoDAhARGY50BvJkioyxFOGkKAShGkFsJwejiR5Xf8aZAaBp89coQJjuDXAQOApekEm45A
+NaAtIbyYxREf0OlICCK841uaahZBQjyfjXCACYjuaASjhFagRKSFNtloHg+hYWIxRohnBQWCSSAh
+BVZ+hkgRnlbxwJIVgIqGlaU6wkeTxHxjm6gVLImrFbHWVEQ1taZjWxJX7KqqnqgUEUxDwtqajrOa
+RkqhEDcxWwECbEjxTYe9gojqOJQ6JO231ob72bSqAjh4RgfsjiDCCfDCK8K8I9TL7r33nvGtCO7C
+O1dUAONk3LcBFxzwwEMwZ/DC4iAsRIE+CWNCbzeV8FfEtoDwVwnlacxMkcKQYIE/F5TQ2QcedUZC
+agyc3NsFGrXVZMipWVBCzKv4Q0JvCviDsjAwf4ylxBeX0KcwGs81ccgqGS3MBxc3RjDDVAvdBRcf
+eFy1MFd3bcQHJEQdlddkP5E1Cf9yXfbaV2d9RBAAOw==
+}
+
+# Create a copy of the image just created, magnified according to the
+# display's DPI scaling level. Since the zooom factor must be an integer,
+# the copy will only be effectively magnified if $tk::scalingPct >= 200.
+image create photo logo2
+logo2 copy logo -zoom [expr {$tk::scalingPct / 100}]
+
+set c [canvas $w.m.c -bg white]
+pack $c -fill both -expand yes -fill both -side left
+
+# For scaling-awareness specify the coordinates of the canvas items in points
+# rather than pixels. Create the items with a left and top padding of 15 pt.
+$c create rectangle 15p 15p 165p 60p -fill blue -outline black ;# 150p x 45p
+$c create oval 15p 75p 165p 120p -fill green ;# 150p x 45p
+set imgId [$c create image 90p 135p -image logo2 -anchor n]
+
+# Compute the scaled y coordinate of the next canvas item's top edge in pixels
+lassign [$c bbox $imgId] x1 y1 x2 y2 ;# x1, y1, x2, y2 are in pixels
+incr y2 [expr {round(15 * [tk scaling])}] ;# convert 15 pt to pixels
+
+$c create text 15p $y2 -anchor nw -font {Helvetica 12} \
+ -text "A short demo of simple canvas elements."
+
+set txt {
+Tcl, or Tool Command Language, is an open-source multi-purpose C library which includes a powerful dynamic scripting language. Together they provide ideal cross-platform development environment for any programming project. It has served for decades as an essential system component in organizations ranging from NASA to Cisco Systems, is a must-know language in the fields of EDA, and powers companies such as FlightAware and F5 Networks.
+
+Tcl is fit for both the smallest and largest programming tasks, obviating the need to decide whether it is overkill for a given job or whether a system written in Tcl will scale up as needed. Wherever a shell script might be used Tcl is a better choice, and entire web ecosystems and mission-critical control and testing systems have also been written in Tcl. Tcl excels in all these roles due to the minimal syntax of the language, the unique programming paradigm exposed at the script level, and the careful engineering that has gone into the design of the Tcl internals.
+}
+
+set t [text $w.m.t -wrap word]
+pack $t -side right -expand yes -fill both
+$t insert end $txt
+
+frame $w.f
+
+pack [button $w.f.c -text "Print Canvas" -command [list tk print $w.m.c]] \
+ -side left -anchor w -padx 3p
+pack [button $w.f.t -text "Print Text" -command [list tk print $w.m.t]] \
+ -side right -anchor e -padx 3p
+
+pack $w.f -side bottom -fill x
+pack $w.m -expand yes -fill both -side top
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/print.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/puzzle.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/puzzle.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/puzzle.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,82 @@
+# puzzle.tcl --
+#
+# This demonstration script creates a 15-puzzle game using a collection
+# of buttons.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+# 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 the
+# 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
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+# Special trick: select a darker color for the space by creating a
+# scrollbar widget and using its trough color.
+
+scrollbar $w.s
+
+# The button metrics are a bit bigger in Aqua, and since we are
+# using place which doesn't autosize, then we need to have a
+# slightly larger frame here...
+
+if {[tk windowingsystem] eq "aqua"} {
+ set frameSize 126p
+} else {
+ set frameSize 90p
+}
+
+frame $w.frame -width $frameSize -height $frameSize -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 -bd 0 -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
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/puzzle.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/radio.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/radio.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/radio.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,66 @@
+# radio.tcl --
+#
+# This demonstration script creates a toplevel window containing
+# several radiobutton widgets.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+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 "Three 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. When the 'Tristate' button is pressed, the radio buttons will display the tri-state mode. Selecting any radio button will return the buttons to their respective on/off state. Click the \"See Variables\" button to see the current values of the variables."
+grid $w.msg -row 0 -column 0 -columnspan 3 -sticky nsew
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w [list size color align]]
+grid $btns -row 3 -column 0 -columnspan 3 -sticky ew
+
+labelframe $w.left -pady 1.5p -text "Point Size" -padx 1.5p
+labelframe $w.mid -pady 1.5p -text "Color" -padx 1.5p
+labelframe $w.right -pady 1.5p -text "Alignment" -padx 1.5p
+button $w.tristate -text Tristate -command "set size multi; set color multi" \
+ -pady 1.5p -padx 1.5p
+if {[tk windowingsystem] eq "aqua"} {
+ $w.tristate configure -padx 7.5p
+}
+grid $w.left -column 0 -row 1 -pady .5c -padx .5c -rowspan 2
+grid $w.mid -column 1 -row 1 -pady .5c -padx .5c -rowspan 2
+grid $w.right -column 2 -row 1 -pady .5c -padx .5c
+grid $w.tristate -column 2 -row 2 -pady .5c -padx .5c
+
+foreach i {10 12 14 18 24} {
+ radiobutton $w.left.b$i -text "Point Size $i" -variable size \
+ -relief flat -value $i -tristatevalue "multi"
+ pack $w.left.b$i -side top -pady 1.5p -anchor w -fill x
+}
+
+foreach c {Red Green Blue Yellow Orange Purple} {
+ set lower [string tolower $c]
+ radiobutton $w.mid.$lower -text $c -variable color \
+ -relief flat -value $lower -anchor w \
+ -command "$w.mid configure -fg \$color" \
+ -tristatevalue "multi"
+ pack $w.mid.$lower -side top -pady 1.5p -fill x
+}
+
+
+label $w.right.l -text "Label" -bitmap questhead -compound left
+$w.right.l configure -width [winfo reqwidth $w.right.l] -compound top
+$w.right.l configure -height [winfo reqheight $w.right.l]
+foreach a {Top Left Right Bottom} {
+ set lower [string tolower $a]
+ radiobutton $w.right.$lower -text $a -variable align \
+ -relief flat -value $lower -indicatoron 0 -width 7 \
+ -command "$w.right.l configure -compound \$align"
+}
+
+grid x $w.right.top
+grid $w.right.left $w.right.l $w.right.right
+grid x $w.right.bottom
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/radio.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/rmt
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/rmt (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/rmt 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,210 @@
+#!/bin/sh
+# the next line restarts using wish \
+exec wish90 "$0" ${1+"$@"}
+
+# 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.
+
+package require tk
+
+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.
+
+. configure -menu [menu .menu]
+menu .menu.file
+menu .menu.file.apps -postcommand fillAppsMenu
+.menu add cascade -label "File" -underline 0 -menu .menu.file
+.menu.file add cascade -label "Select Application" -underline 0 \
+ -menu .menu.file.apps
+.menu.file add command -label "Quit" -command "destroy ." -underline 0
+
+# Create text window and scrollbar.
+
+text .t -yscrollcommand ".s set" -setgrid true
+scrollbar .s -command ".t yview"
+grid .t .s -sticky nsew
+grid rowconfigure . 0 -weight 1
+grid columnconfigure . 0 -weight 1
+
+# 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 <Return> {
+ .t mark set insert {end - 1c}
+ .t insert insert \n
+ invoke
+ break
+}
+bind .t <Delete> {
+ catch {.t tag remove sel sel.first promptEnd}
+ if {[.t tag nextrange sel 1.0 end] eq ""} {
+ if {[.t compare insert < promptEnd]} {
+ break
+ }
+ }
+}
+bind .t <BackSpace> {
+ catch {.t tag remove sel sel.first promptEnd}
+ if {[.t tag nextrange sel 1.0 end] eq ""} {
+ if {[.t compare insert <= promptEnd]} {
+ break
+ }
+ }
+}
+bind .t <Control-d> {
+ if {[.t compare insert < promptEnd]} {
+ break
+ }
+}
+bind .t <Control-k> {
+ if {[.t compare insert < promptEnd]} {
+ .t mark set insert promptEnd
+ }
+}
+bind .t <Control-t> {
+ if {[.t compare insert < promptEnd]} {
+ break
+ }
+}
+bind .t <Meta-d> {
+ if {[.t compare insert < promptEnd]} {
+ break
+ }
+}
+bind .t <Meta-BackSpace> {
+ if {[.t compare insert <= promptEnd]} {
+ break
+ }
+}
+bind .t <Control-h> {
+ if {[.t compare insert <= promptEnd]} {
+ break
+ }
+}
+### This next bit *isn't* nice - DKF ###
+auto_load tk::TextInsert
+proc tk::TextInsert {w s} {
+ if {$s eq ""} {
+ return
+ }
+ catch {
+ if {
+ [$w compare sel.first <= insert] && [$w compare sel.last >= insert]
+ } then {
+ $w tag remove sel sel.first promptEnd
+ $w delete sel.first sel.last
+ }
+ }
+ $w insert insert $s
+ $w see insert
+}
+
+.t configure -font {Courier 12}
+.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 eq "!!\n"} {
+ set cmd $lastCommand
+ } else {
+ set lastCommand $cmd
+ }
+ if {$app eq "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"
+ } elseif {$msg ne ""} {
+ .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 {} {
+ set m .menu.file.apps
+ catch {$m delete 0 last}
+ foreach i [lsort [winfo interps]] {
+ $m add command -label $i -command [list newApp $i]
+ }
+ $m add command -label local -command {newApp local}
+}
+
+set app [winfo name .]
+prompt
+focus .t
+
+# Local Variables:
+# mode: tcl
+# End:
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/rmt
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/rolodex
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/rolodex (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/rolodex 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,204 @@
+#!/bin/sh
+# the next line restarts using wish \
+exec wish90 "$0" ${1+"$@"}
+
+# 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.
+
+package require tk
+
+foreach i [winfo children .] {
+ catch {destroy $i}
+}
+
+set version 1.2
+
+#------------------------------------------
+# 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} {
+ label .frame.label$i -text [lindex $names $i] -anchor e
+ entry .frame.entry$i -width 35
+ grid .frame.label$i .frame.entry$i -sticky ew -pady 1.5p -padx 0.75p
+}
+
+frame .buttons
+pack .buttons -side bottom -pady 1.5p -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 1.5p
+
+#------------------------------------------
+# Phase 1: Add menus, dialog boxes
+#------------------------------------------
+
+# DKF - note that this is an old-style menu bar; I just have not yet
+# got around to converting the context help code to work with the new
+# menu system and its <<MenuSelect>> virtual event.
+
+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.entry$i get]]
+ }
+}
+.buttons.add config -command addAction
+
+#------------------------------------------
+# Phase 4: Miscellaneous other actions
+#------------------------------------------
+
+proc clearAction {} {
+ foreach i {1 2 3 4 5 6 7} {
+ .frame.entry$i delete 0 end
+ }
+}
+.buttons.clear config -command clearAction
+
+proc fillCard {} {
+ clearAction
+ .frame.entry1 insert 0 "John Ousterhout"
+ .frame.entry2 insert 0 "CS Division, Department of EECS"
+ .frame.entry3 insert 0 "University of California"
+ .frame.entry4 insert 0 "Berkeley, CA 94720"
+ .frame.entry5 insert 0 "private"
+ .frame.entry6 insert 0 "510-642-0865"
+ .frame.entry7 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 . <Control-c> clearAction
+.buttons.add config -text "Add Ctrl+A"
+bind . <Control-a> addAction
+.buttons.search config -text "Search Ctrl+S"
+bind . <Control-s> "addAction; fillCard"
+.buttons.delete config -text "Delete... Ctrl+D"
+bind . <Control-d> deleteAction
+
+.menu.file.m entryconfig 1 -accel Ctrl+F
+bind . <Control-f> fileAction
+.menu.file.m entryconfig 2 -accel Ctrl+Q
+bind . <Control-q> {destroy .}
+
+focus .frame.entry1
+
+#----------------------------------------------------
+# 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]}]]
+}
+
+event add <<Help>> <F1> <Help>
+bind . <<Help>> {Help [winfo containing %X %Y] %X %Y}
+bind Menu <<Help>> {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.1) {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.2) {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.entry1) {In this field of the rolodex entry you should type the person's name}
+set helpTopics(.frame.entry2) {In this field of the rolodex entry you should type the first line of the person's address}
+set helpTopics(.frame.entry3) {In this field of the rolodex entry you should type the second line of the person's address}
+set helpTopics(.frame.entry4) {In this field of the rolodex entry you should type the third line of the person's address}
+set helpTopics(.frame.entry5) {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.entry6) {In this field of the rolodex entry you should type the person's work phone number}
+set helpTopics(.frame.entry7) {In this field of the rolodex entry you should type the phone number for the person's FAX machine}
+
+set helpCmds(.frame.label1) {set topic .frame.entry1}
+set helpCmds(.frame.label2) {set topic .frame.entry2}
+set helpCmds(.frame.label3) {set topic .frame.entry3}
+set helpCmds(.frame.label4) {set topic .frame.entry4}
+set helpCmds(.frame.label5) {set topic .frame.entry5}
+set helpCmds(.frame.label6) {set topic .frame.entry6}
+set helpCmds(.frame.label7) {set topic .frame.entry7}
+
+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 $version."
+
+# 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
+
+# Local Variables:
+# mode: tcl
+# End:
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/rolodex
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ruler.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ruler.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ruler.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,175 @@
+# ruler.tcl --
+#
+# This demonstration script creates a canvas widget that displays a ruler
+# with tab stops that can be set, moved, and deleted.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+# 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
+ set newTab [$c create polygon $x $y \
+ [expr {$x+$v(size)}] [expr {$y+$v(size)}] \
+ [expr {$x-$v(size)}] [expr {$y+$v(size)}]]
+ set fill [$c itemcget $newTab -outline]
+ $c itemconfigure $newTab -fill $fill -outline {}
+ set v(normalStyle) "-fill $fill"
+ return $newTab
+}
+
+set w .ruler
+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
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+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]
+# Main widget program sets variable tk_demoDirectory
+if {[winfo depth $c] > 1} {
+ set demo_rulerInfo(activeStyle) "-fill red -stipple {}"
+ set demo_rulerInfo(deleteStyle) [list -fill red \
+ -stipple @[file join $tk_demoDirectory images gray25.xbm]]
+} else {
+ set demo_rulerInfo(activeStyle) "-fill black -stipple {}"
+ set demo_rulerInfo(deleteStyle) [list -fill black \
+ -stipple @[file join $tk_demoDirectory images gray25.xbm]]
+}
+
+$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 \
+ -fill [lindex [$c config -bg] 4]]
+$c addtag well withtag [rulerMkTab $c [winfo pixels $c 13.5c] \
+ [winfo pixels $c .65c]]
+
+$c bind well <Button-1> "rulerNewTab $c %x %y"
+$c bind tab <Button-1> "rulerSelectTab $c %x %y"
+bind $c <B1-Motion> "rulerMoveTab $c %x %y"
+bind $c <ButtonRelease-1> "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) != $v(top)+2} {
+ $c delete active
+ } else {
+ eval "$c itemconf active $v(normalStyle)"
+ $c dtag active
+ }
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ruler.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/sayings.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/sayings.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/sayings.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,44 @@
+# sayings.tcl --
+#
+# This demonstration script creates a listbox that can be scrolled
+# both horizontally and vertically. It displays a collection of
+# well-known sayings.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+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
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+frame $w.frame -borderwidth 7.5p
+pack $w.frame -side top -expand yes -fill both -padx 1c
+
+
+ttk::scrollbar $w.frame.yscroll -command "$w.frame.list yview"
+ttk::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 "Don't speculate, measure" "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" "Measure twice, cut once"
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/sayings.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/search.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/search.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/search.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,139 @@
+# 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.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+# 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
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+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 3p -padx 7.5p
+bind $w.file.entry <Return> "
+ 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 3p -padx 7.5p
+bind $w.string.entry <Return> "textSearch $w.text \$searchString search"
+
+text $w.text -yscrollcommand "$w.scroll set" -setgrid true
+ttk::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 <Return> or click on "Load File". Then
+type a string in the lower entry and type <Return> 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 ""
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/search.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/spin.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/spin.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/spin.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,45 @@
+# spin.tcl --
+#
+# This demonstration script creates several spinbox widgets.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+set w .spin
+catch {destroy $w}
+toplevel $w
+wm title $w "Spinbox Demonstration"
+wm iconname $w "spin"
+positionWindow $w
+
+label $w.msg -font $font -wraplength 5i -justify left -text "Three different\
+ spin-boxes 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 values that are too large to fit in the\
+ window all at once, you can scan through the value by dragging with\
+ mouse button2 pressed. Note that the first spin-box will only permit\
+ you to type in integers, and the third selects from a list of\
+ Australian cities."
+pack $w.msg -side top
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+set australianCities {
+ Canberra Sydney Melbourne Perth Adelaide Brisbane
+ Hobart Darwin "Alice Springs"
+}
+
+spinbox $w.s1 -from 1 -to 10 -width 10 -validate key \
+ -validatecommand {string is integer %P}
+spinbox $w.s2 -from 0 -to 3 -increment .5 -format %05.2f -width 10
+spinbox $w.s3 -values $australianCities -width 10
+
+pack $w.s1 $w.s2 $w.s3 -side top -pady 3p -padx 7.5p
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/spin.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/states.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/states.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/states.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,54 @@
+# states.tcl --
+#
+# This demonstration script creates a listbox widget that displays
+# the names of the 50 states in the United States of America.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+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
+
+labelframe $w.justif -text Justification
+foreach c {Left Center Right} {
+ set lower [string tolower $c]
+ radiobutton $w.justif.$lower -text $c -variable just \
+ -relief flat -value $lower -anchor w \
+ -command "$w.frame.list configure -justify \$just" \
+ -tristatevalue "multi"
+ pack $w.justif.$lower -side left -pady 1.5p -fill x
+}
+pack $w.justif
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+frame $w.frame -borderwidth .5c
+pack $w.frame -side top -expand yes -fill y
+
+ttk::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
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/states.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/style.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/style.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/style.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,155 @@
+# style.tcl --
+#
+# This demonstration script creates a text widget that illustrates the
+# various display styles that may be set for tags.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+set w .style
+catch {destroy $w}
+toplevel $w
+wm title $w "Text Demonstration - Display Styles"
+wm iconname $w "style"
+positionWindow $w
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+# Only set the font family in one place for simplicity and consistency
+
+set family Courier
+
+text $w.text -yscrollcommand "$w.scroll set" -setgrid true \
+ -width 70 -height 32 -wrap word -font "$family 12"
+ttk::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 "$family 12 bold italic"
+$w.text tag configure big -font "$family 14 bold"
+$w.text tag configure verybig -font "Helvetica 24 bold"
+$w.text tag configure tiny -font "Times 8 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 1
+$w.text tag configure overstrike -overstrike 1
+$w.text tag configure right -justify right
+$w.text tag configure center -justify center
+$w.text tag configure super -offset 4p -font "$family 10"
+$w.text tag configure sub -offset -2p -font "$family 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 system font, "
+$w.text insert end large verybig
+$w.text insert end " or "
+$w.text insert end "small" tiny ".\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
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/style.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/systray.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/systray.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/systray.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,89 @@
+# systray.tcl --
+#
+# This demonstration script showcases the tk systray and tk sysnotify commands.
+#
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+set w .systray
+destroy $w
+toplevel $w
+wm title $w "System Tray Demonstration"
+positionWindow $w
+
+## See Code / Dismiss buttons
+pack [addSeeDismiss $w.buttons $w] -side bottom -fill x
+
+catch {tk systray destroy}
+set trayIconExists false
+
+set iconmenu .menubar
+destroy $iconmenu
+menu $iconmenu
+$iconmenu add command -label "Status" -command { puts "status icon clicked" }
+$iconmenu add command -label "Exit" -command exit
+
+pack [label $w.l -text "This demonstration showcases
+ the tk systray and tk sysnotify commands.
+ Running this demo creates the systray icon.
+ Clicking the buttons below modifies and destroys the icon
+ and displays the notification."]
+
+image create photo book -data R0lGODlhDwAPAKIAAP//////AP8AAMDAwICAgAAAAAAAAAAAACwAAAAADwAPAAADSQhA2u5ksPeKABKSCaya29d4WKgERFF0l1IMQCAKatvBJ0OTdzzXI1xMB3TBZAvATtB6NSLKleXi3OBoLqrVgc0yv+DVSEUuFxIAOw==
+
+labelframe $w.f -text "Tray Icon"
+button $w.f.b0 -text "Create" -command create
+button $w.f.b1 -text "Modify" -command modify
+button $w.f.b2 -text "Destroy" -command remove
+pack $w.f.b0 $w.f.b1 $w.f.b2 -padx 3p -pady 3p -side left -expand true -fill x
+
+button $w.b3 -text "Display Notification" -command notify
+pack $w.f $w.b3 -fill x -padx 3p -pady 3p
+
+proc create {} {
+ global trayIconExists
+ if {$trayIconExists} {
+ tk_messageBox -message "Systray icon already exists"
+ return
+ }
+ tk systray create -image book -text "Systray sample" \
+ -button1 {puts "foo"} \
+ -button3 {tk_popup $iconmenu [winfo pointerx .] [winfo pointery .]}
+ set trayIconExists true
+}
+
+proc modify {} {
+ global trayIconExists
+ if {!$trayIconExists} {
+ tk_messageBox -message "Please create systray icon first"
+ return
+ }
+ image create photo page -data R0lGODlhCwAPAKIAAP//////AMDAwICAgAAA/wAAAAAAAAAAACwAAAAACwAPAAADMzi6CzAugiAgDGE68aB0RXgRJBFVX0SNpQlUWfahQOvSsgrX7eZJMlQMWBEYj8iQchlKAAA7
+ tk systray configure -image page
+ tk systray configure -text "Modified text"
+ tk systray configure -button1 {puts "this is a different output"}
+ tk systray configure -button3 {puts "hello yall"}
+}
+
+proc notify {} {
+ global trayIconExists
+ if {!$trayIconExists} {
+ tk_messageBox -message "Please create systray icon first"
+ return
+ }
+ tk sysnotify "Alert" "This is an alert"
+}
+
+proc remove {} {
+ global trayIconExists
+ if {!$trayIconExists} {
+ tk_messageBox -message "Systray icon was already destroyed"
+ return
+ }
+ tk systray destroy
+ set trayIconExists false
+}
+
+create
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/systray.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/tclIndex
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/tclIndex (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/tclIndex 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,70 @@
+# 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 -encoding utf-8 [file join $dir arrow.tcl]]
+set auto_index(arrowMove1) [list source -encoding utf-8 [file join $dir arrow.tcl]]
+set auto_index(arrowMove2) [list source -encoding utf-8 [file join $dir arrow.tcl]]
+set auto_index(arrowMove3) [list source -encoding utf-8 [file join $dir arrow.tcl]]
+set auto_index(textLoadFile) [list source -encoding utf-8 [file join $dir search.tcl]]
+set auto_index(textSearch) [list source -encoding utf-8 [file join $dir search.tcl]]
+set auto_index(textToggle) [list source -encoding utf-8 [file join $dir search.tcl]]
+set auto_index(itemEnter) [list source -encoding utf-8 [file join $dir items.tcl]]
+set auto_index(itemLeave) [list source -encoding utf-8 [file join $dir items.tcl]]
+set auto_index(itemMark) [list source -encoding utf-8 [file join $dir items.tcl]]
+set auto_index(itemStroke) [list source -encoding utf-8 [file join $dir items.tcl]]
+set auto_index(itemsUnderArea) [list source -encoding utf-8 [file join $dir items.tcl]]
+set auto_index(itemStartDrag) [list source -encoding utf-8 [file join $dir items.tcl]]
+set auto_index(itemDrag) [list source -encoding utf-8 [file join $dir items.tcl]]
+set auto_index(butPress) [list source -encoding utf-8 [file join $dir items.tcl]]
+set auto_index(loadDir) [list source -encoding utf-8 [file join $dir image2.tcl]]
+set auto_index(loadImage) [list source -encoding utf-8 [file join $dir image2.tcl]]
+set auto_index(rulerMkTab) [list source -encoding utf-8 [file join $dir ruler.tcl]]
+set auto_index(rulerNewTab) [list source -encoding utf-8 [file join $dir ruler.tcl]]
+set auto_index(rulerSelectTab) [list source -encoding utf-8 [file join $dir ruler.tcl]]
+set auto_index(rulerMoveTab) [list source -encoding utf-8 [file join $dir ruler.tcl]]
+set auto_index(rulerReleaseTab) [list source -encoding utf-8 [file join $dir ruler.tcl]]
+set auto_index(mkTextConfig) [list source -encoding utf-8 [file join $dir ctext.tcl]]
+set auto_index(textEnter) [list source -encoding utf-8 [file join $dir ctext.tcl]]
+set auto_index(textInsert) [list source -encoding utf-8 [file join $dir ctext.tcl]]
+set auto_index(textPaste) [list source -encoding utf-8 [file join $dir ctext.tcl]]
+set auto_index(textB1Press) [list source -encoding utf-8 [file join $dir ctext.tcl]]
+set auto_index(textB1Move) [list source -encoding utf-8 [file join $dir ctext.tcl]]
+set auto_index(textBs) [list source -encoding utf-8 [file join $dir ctext.tcl]]
+set auto_index(textDel) [list source -encoding utf-8 [file join $dir ctext.tcl]]
+set auto_index(bitmapRow) [list source -encoding utf-8 [file join $dir bitmap.tcl]]
+set auto_index(scrollEnter) [list source -encoding utf-8 [file join $dir cscroll.tcl]]
+set auto_index(scrollLeave) [list source -encoding utf-8 [file join $dir cscroll.tcl]]
+set auto_index(scrollButton) [list source -encoding utf-8 [file join $dir cscroll.tcl]]
+set auto_index(textWindOn) [list source -encoding utf-8 [file join $dir twind.tcl]]
+set auto_index(textWindOff) [list source -encoding utf-8 [file join $dir twind.tcl]]
+set auto_index(textWindPlot) [list source -encoding utf-8 [file join $dir twind.tcl]]
+set auto_index(embPlotDown) [list source -encoding utf-8 [file join $dir twind.tcl]]
+set auto_index(embPlotMove) [list source -encoding utf-8 [file join $dir twind.tcl]]
+set auto_index(textWindDel) [list source -encoding utf-8 [file join $dir twind.tcl]]
+set auto_index(embDefBg) [list source -encoding utf-8 [file join $dir twind.tcl]]
+set auto_index(floorDisplay) [list source -encoding utf-8 [file join $dir floor.tcl]]
+set auto_index(newRoom) [list source -encoding utf-8 [file join $dir floor.tcl]]
+set auto_index(roomChanged) [list source -encoding utf-8 [file join $dir floor.tcl]]
+set auto_index(bg1) [list source -encoding utf-8 [file join $dir floor.tcl]]
+set auto_index(bg2) [list source -encoding utf-8 [file join $dir floor.tcl]]
+set auto_index(bg3) [list source -encoding utf-8 [file join $dir floor.tcl]]
+set auto_index(fg1) [list source -encoding utf-8 [file join $dir floor.tcl]]
+set auto_index(fg2) [list source -encoding utf-8 [file join $dir floor.tcl]]
+set auto_index(fg3) [list source -encoding utf-8 [file join $dir floor.tcl]]
+set auto_index(setWidth) [list source -encoding utf-8 [file join $dir hscale.tcl]]
+set auto_index(plotDown) [list source -encoding utf-8 [file join $dir plot.tcl]]
+set auto_index(plotMove) [list source -encoding utf-8 [file join $dir plot.tcl]]
+set auto_index(puzzleSwitch) [list source -encoding utf-8 [file join $dir puzzle.tcl]]
+set auto_index(setHeight) [list source -encoding utf-8 [file join $dir vscale.tcl]]
+set auto_index(showMessageBox) [list source -encoding utf-8 [file join $dir msgbox.tcl]]
+set auto_index(setColor) [list source -encoding utf-8 [file join $dir clrpick.tcl]]
+set auto_index(setColor_helper) [list source -encoding utf-8 [file join $dir clrpick.tcl]]
+set auto_index(fileDialog) [list source -encoding utf-8 [file join $dir filebox.tcl]]
+set auto_index(systray) [list source -encoding utf-8 [file join $dir systray.tcl]]
+set auto_index(windoicons [list source -encoding utf-8 [file join $dir windowicons.tcl]]
+
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/tclIndex
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/tcolor
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/tcolor (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/tcolor 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,358 @@
+#!/bin/sh
+# the next line restarts using wish \
+exec wish90 "$0" ${1+"$@"}
+
+# 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.
+
+package require tk
+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.
+
+. configure -menu [menu .menu]
+menu .menu.file
+.menu add cascade -menu .menu.file -label File -underline 0
+.menu.file add radio -label "RGB color space" -variable colorSpace \
+ -value rgb -underline 0 -command {changeColorSpace rgb}
+.menu.file add radio -label "CMY color space" -variable colorSpace \
+ -value cmy -underline 0 -command {changeColorSpace cmy}
+.menu.file add radio -label "HSB color space" -variable colorSpace \
+ -value hsb -underline 0 -command {changeColorSpace hsb}
+.menu.file add separator
+.menu.file add radio -label "Automatic updates" -variable autoUpdate \
+ -value 1 -underline 0
+.menu.file add radio -label "Manual updates" -variable autoUpdate \
+ -value 0 -underline 0
+.menu.file add separator
+.menu.file add command -label "Exit program" -underline 0 -command {exit}
+
+# Create the command entry window at the bottom of the window, along
+# with the update button.
+
+labelframe .command -text "Command:" -padx {1m 0}
+entry .command.e -textvariable command
+button .command.update -text Update -command doUpdate
+pack .command.update -side right -pady .1c -padx {.25c 0}
+pack .command.e -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.
+
+grid .command -sticky nsew -row 2 -columnspan 3 -padx 1m -pady {0 1m}
+
+grid columnconfigure . {1 2} -weight 1
+grid rowconfigure . 0 -weight 1
+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]
+ labelframe .names -text "Select:" -padx .1c -pady .1c
+ grid .names -row 0 -column 0 -sticky nsew -padx .15c -pady .15c -rowspan 2
+ grid columnconfigure . 0 -weight 1
+ listbox .names.lb -width 20 -height 12 -yscrollcommand ".names.s set" \
+ -exportselection false
+ bind .names.lb <Double-Button-1> {
+ tc_loadNamedColor [.names.lb get [.names.lb curselection]]
+ }
+ scrollbar .names.s -orient vertical -command ".names.lb yview"
+ pack .names.lb .names.s -side left -fill y -expand 1
+ while {[gets $f line] >= 0} {
+ if {[regexp {^\s*\d+\s+\d+\s+\d+\s+(\S+)$} $line -> col]} {
+ .names.lb insert end $col
+ }
+ }
+ close $f
+ break
+}
+
+# Create the three scales for editing the color, and the entry for
+# typing in a color value.
+
+frame .adjust
+foreach i {1 2 3} {
+ label .adjust.l$i -textvariable label$i -pady 0
+ labelframe .adjust.$i -labelwidget .adjust.l$i -padx 1m -pady 1m
+ scale .scale$i -from 0 -to 1000 -length 6c -orient horizontal \
+ -command tc_scaleChanged
+ pack .scale$i -in .adjust.$i
+ pack .adjust.$i
+}
+grid .adjust -row 0 -column 1 -sticky nsew -padx .15c -pady .15c
+
+labelframe .name -text "Name:" -padx 1m -pady 1m
+entry .name.e -textvariable name -width 10
+pack .name.e -side right -expand 1 -fill x
+bind .name.e <Return> {tc_loadNamedColor $name}
+grid .name -column 1 -row 1 -sticky nsew -padx .15c -pady .15c
+
+# Create the color display swatch on the right side of the window.
+
+labelframe .sample -text "Color:" -padx 1m -pady 1m
+frame .sample.swatch -width 2c -height 5c -background $color
+label .sample.value -textvariable color -width 13 -font {Courier 12}
+pack .sample.swatch -side top -expand yes -fill both
+pack .sample.value -side bottom -pady .25c
+grid .sample -row 0 -column 2 -sticky nsew -padx .15c -pady .15c -rowspan 2
+
+
+# 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
+ }
+ switch $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}]]
+ }
+ 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}]]
+ }
+ hsb {
+ 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]
+ .sample.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
+ switch $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}]]
+ }
+ 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}]]
+ }
+ hsb {
+ 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 .sample.swatch $name]
+ set red [lindex $list 0]
+ set green [lindex $list 1]
+ set blue [lindex $list 2]
+ } else {
+ switch [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]
+ .sample.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
+ switch $space {
+ rgb {
+ set label1 "Adjust Red:"
+ set label2 "Adjust Green:"
+ set label3 "Adjust Blue:"
+ tc_setScales
+ return
+ }
+ cmy {
+ set label1 "Adjust Cyan:"
+ set label2 "Adjust Magenta:"
+ set label3 "Adjust Yellow:"
+ tc_setScales
+ return
+ }
+ hsb {
+ set label1 "Adjust Hue:"
+ set label2 "Adjust Saturation:"
+ set label3 "Adjust 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 [expr {double($red)}]
+ set min [expr {double($green)}]
+ } else {
+ set max [expr {double($green)}]
+ set min [expr {double($red)}]
+ }
+ if {$blue > $max} {
+ set max [expr {double($blue)}]
+ } elseif {$blue < $min} {
+ set min [expr {double($blue)}]
+ }
+ 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 {($bc - $gc)/6.0}]
+ } elseif {$green == $max} {
+ set hue [expr {(2 + $rc - $bc)/6.0}]
+ } else {
+ set hue [expr {(4 + $gc - $rc)/6.0}]
+ }
+ 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)))}]]
+ switch $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"}
+ default {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
+
+# Local Variables:
+# mode: tcl
+# End:
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/tcolor
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/text.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/text.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/text.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,113 @@
+# text.tcl --
+#
+# This demonstration script creates a text widget that describes
+# the basic editing functions.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+set w .text
+catch {destroy $w}
+toplevel $w
+wm title $w "Text Demonstration - Basic Facilities"
+wm iconname $w "text"
+positionWindow $w
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w {} \
+ {ttk::button $w.buttons.fontchooser -command fontchooserToggle}]
+pack $btns -side bottom -fill x
+
+text $w.text -yscrollcommand [list $w.scroll set] -setgrid 1 \
+ -height 30 -undo 1 -autosep 1
+ttk::scrollbar $w.scroll -command [list $w.text yview]
+pack $w.scroll -side right -fill y
+pack $w.text -expand yes -fill both
+
+# TIP 324 Demo: [tk fontchooser]
+proc fontchooserToggle {} {
+ tk fontchooser [expr {[tk fontchooser configure -visible] ?
+ "hide" : "show"}]
+}
+proc fontchooserVisibility {w} {
+ $w configure -text [expr {[tk fontchooser configure -visible] ?
+ "Hide Font Dialog" : "Show Font Dialog"}]
+}
+proc fontchooserFocus {w} {
+ tk fontchooser configure -font [$w cget -font] \
+ -command [list fontchooserFontSel $w]
+}
+proc fontchooserFontSel {w font args} {
+ $w configure -font [font actual $font]
+}
+tk fontchooser configure -parent $w
+bind $w.text <FocusIn> [list fontchooserFocus $w.text]
+fontchooserVisibility $w.buttons.fontchooser
+bind $w <<TkFontchooserVisibility>> [list \
+ fontchooserVisibility $w.buttons.fontchooser]
+focus $w.text
+
+$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 the middle mouse button 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 the middle mouse button 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. Control-z undoes the last editing action performed,
+and }
+
+switch [tk windowingsystem] {
+ "aqua" - "x11" {
+ $w.text insert end "Control-Shift-z"
+ }
+ "win32" {
+ $w.text insert end "Control-y"
+ }
+}
+
+$w.text insert end { redoes undone edits.
+
+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
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/text.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/textpeer.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/textpeer.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/textpeer.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,62 @@
+# textpeer.tcl --
+#
+# This demonstration script creates a pair of text widgets that can edit a
+# single logical buffer. This is particularly useful when editing related text
+# in two (or more) parts of the same file.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+set w .textpeer
+catch {destroy $w}
+toplevel $w
+wm title $w "Text Widget Peering Demonstration"
+wm iconname $w "textpeer"
+positionWindow $w
+
+set count 0
+
+## Define a widget that we peer from; it won't ever actually be shown though
+set first [text $w.text[incr count]]
+$first insert end "This is a coupled pair of text widgets; they are peers to "
+$first insert end "each other. They have the same underlying data model, but "
+$first insert end "can show different locations, have different current edit "
+$first insert end "locations, and have different selections. You can also "
+$first insert end "create additional peers of any of these text widgets using "
+$first insert end "the Make Peer button beside the text widget to clone, and "
+$first insert end "delete a particular peer widget using the Delete Peer "
+$first insert end "button."
+
+## Procedures to make and kill clones; most of this is just so that the demo
+## looks nice...
+proc makeClone {w parent} {
+ global count
+ set t [$parent peer create $w.text[incr count] -yscroll "$w.sb$count set"\
+ -height 10 -wrap word]
+ set sb [ttk::scrollbar $w.sb$count -command "$t yview" -orient vertical]
+ set b1 [button $w.clone$count -command "makeClone $w $t" \
+ -text "Make Peer"]
+ set b2 [button $w.kill$count -command "killClone $w $count" \
+ -text "Delete Peer"]
+ set row [expr {$count * 2}]
+ grid $t $sb $b1 -sticky nsew -row $row
+ grid ^ ^ $b2 -row [incr row]
+ grid configure $b1 $b2 -sticky new
+ grid rowconfigure $w $b2 -weight 1
+}
+proc killClone {w count} {
+ destroy $w.text$count $w.sb$count
+ destroy $w.clone$count $w.kill$count
+}
+
+## Now set up the GUI
+makeClone $w $first
+makeClone $w $first
+destroy $first
+
+## See Code / Dismiss buttons
+grid [addSeeDismiss $w.buttons $w] - - -sticky ew -row 5000
+grid columnconfigure $w 0 -weight 1
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/textpeer.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/timer
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/timer (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/timer 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,47 @@
+#!/bin/sh
+# the next line restarts using wish \
+exec wish90 "$0" ${1+"$@"}
+
+# timer --
+# This script generates a counter with start and stop buttons.
+
+package require tk
+
+label .counter -text 0.00 -relief raised -width 10 -padx 2m -pady 1m
+button .start -text Start -command {
+ if {$stopped} {
+ set stopped 0
+ set startMoment [clock clicks -milliseconds]
+ tick
+ .stop configure -state normal
+ .start configure -state disabled
+ }
+}
+button .stop -text Stop -state disabled -command {
+ set stopped 1
+ .stop configure -state disabled
+ .start configure -state normal
+}
+pack .counter -side bottom -fill both
+pack .start -side left -fill both -expand yes
+pack .stop -side right -fill both -expand yes
+
+set startMoment {}
+
+set stopped 1
+
+proc tick {} {
+ global startMoment stopped
+ if {$stopped} {return}
+ after 50 tick
+ set elapsedMS [expr {[clock clicks -milliseconds] - $startMoment}]
+ .counter config -text [format "%.2f" [expr {double($elapsedMS)/1000}]]
+}
+
+bind . <Control-c> {destroy .}
+bind . <Control-q> {destroy .}
+focus .
+
+# Local Variables:
+# mode: tcl
+# End:
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/timer
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/toolbar.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/toolbar.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/toolbar.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,92 @@
+# toolbar.tcl --
+#
+# This demonstration script creates a toolbar that can be torn off.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+set w .toolbar
+destroy $w
+toplevel $w
+wm title $w "Toolbar Demonstration"
+wm iconname $w "toolbar"
+positionWindow $w
+
+ttk::label $w.msg -wraplength 4i -text "This is a demonstration of how to do\
+ a toolbar that is styled correctly and which can be torn off. The\
+ buttons are configured to be “toolbar style” buttons by\
+ telling them that they are to use the Toolbutton style. At the left\
+ end of the toolbar is a simple marker that the cursor changes to a\
+ movement icon over; drag that away from the toolbar to tear off the\
+ whole toolbar into a separate toplevel widget. When the dragged-off\
+ toolbar is no longer needed, just close it like any normal toplevel\
+ and it will reattach to the window it was torn off from."
+
+## Set up the toolbar hull
+set t [frame $w.toolbar] ;# Must be a frame!
+ttk::separator $w.sep
+ttk::frame $t.tearoff -cursor fleur
+ttk::separator $t.tearoff.to -orient vertical
+ttk::separator $t.tearoff.to2 -orient vertical
+pack $t.tearoff.to -fill y -expand 1 -padx 3p -side left
+pack $t.tearoff.to2 -fill y -expand 1 -side left
+ttk::frame $t.contents
+grid $t.tearoff $t.contents -sticky nsew
+grid columnconfigure $t $t.contents -weight 1
+grid columnconfigure $t.contents 1000 -weight 1
+
+## Bindings so that the toolbar can be torn off and reattached
+bind $t.tearoff <B1-Motion> [list tearoff $t %X %Y]
+bind $t.tearoff.to <B1-Motion> [list tearoff $t %X %Y]
+bind $t.tearoff.to2 <B1-Motion> [list tearoff $t %X %Y]
+proc tearoff {w x y} {
+ if {[string match $w* [winfo containing $x $y]]} {
+ return
+ }
+ grid remove $w
+ grid remove $w.tearoff
+ wm manage $w
+ wm protocol $w WM_DELETE_WINDOW [list untearoff $w]
+}
+proc untearoff {w} {
+ wm forget $w
+ grid $w.tearoff
+ grid $w
+}
+
+## Toolbar contents
+ttk::button $t.button -text "Button" -style Toolbutton -command [list \
+ $w.txt insert end "Button Pressed\n"]
+ttk::checkbutton $t.check -text "Check" -variable check -style Toolbutton \
+ -command [concat [list $w.txt insert end] {"check is $check\n"}]
+ttk::menubutton $t.menu -text "Menu" -menu $t.menu.m
+ttk::combobox $t.combo -value [lsort [font families]] -state readonly
+menu $t.menu.m
+$t.menu.m add command -label "Just" -command [list $w.txt insert end Just\n]
+$t.menu.m add command -label "An" -command [list $w.txt insert end An\n]
+$t.menu.m add command -label "Example" \
+ -command [list $w.txt insert end Example\n]
+bind $t.combo <<ComboboxSelected>> [list changeFont $w.txt $t.combo]
+proc changeFont {txt combo} {
+ $txt configure -font [list [$combo get] 10]
+}
+
+## Some content for the rest of the toplevel
+text $w.txt -width 40 -height 10
+interp alias {} doInsert {} $w.txt insert end ;# Make bindings easy to write
+
+## Arrange contents
+grid $t.button $t.check $t.menu $t.combo -in $t.contents -padx 1.5p -pady 3p -sticky ns
+grid $t -sticky ew
+grid $w.sep -sticky ew
+grid $w.msg -sticky ew
+grid $w.txt -sticky nsew
+grid rowconfigure $w $w.txt -weight 1
+grid columnconfigure $w $w.txt -weight 1
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+grid $btns -sticky ew
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/toolbar.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/tree.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/tree.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/tree.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,89 @@
+# tree.tcl --
+#
+# This demonstration script creates a toplevel window containing a Ttk
+# tree widget.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+set w .tree
+catch {destroy $w}
+toplevel $w
+wm title $w "Directory Browser"
+wm iconname $w "tree"
+positionWindow $w
+
+## Explanatory text
+ttk::label $w.msg -font $font -wraplength 4i -justify left -anchor n -padding {10 2 10 6} -text "Ttk is the new Tk themed widget set. One of the widgets it includes is a tree widget, which allows the user to browse a hierarchical data-set such as a filesystem. The tree widget not only allows for the tree part itself, but it also supports an arbitrary number of additional columns which can show additional data (in this case, the size of the files found in your filesystem). You can also change the width of the columns by dragging the boundary between them."
+pack $w.msg -fill x
+
+## See Code / Dismiss
+pack [addSeeDismiss $w.seeDismiss $w] -side bottom -fill x
+
+## Code to populate the roots of the tree (can be more than one on Windows)
+proc populateRoots {tree} {
+ foreach dir [lsort -dictionary [file volumes]] {
+ populateTree $tree [$tree insert {} end -text $dir \
+ -values [list $dir directory]]
+ }
+}
+
+## Code to populate a node of the tree
+proc populateTree {tree node} {
+ if {[$tree set $node type] ne "directory"} {
+ return
+ }
+ set path [$tree set $node fullpath]
+ $tree delete [$tree children $node]
+ foreach f [lsort -dictionary [glob -nocomplain -dir $path *]] {
+ set f [file normalize $f]
+ set type [file type $f]
+ set id [$tree insert $node end -text [file tail $f] \
+ -values [list $f $type]]
+
+ if {$type eq "directory"} {
+ ## Make it so that this node is openable
+ $tree insert $id 0 -text dummy ;# a dummy
+ $tree item $id -text [file tail $f]/
+
+ } elseif {$type eq "file"} {
+ set size [file size $f]
+ ## Format the file size nicely
+ if {$size >= 1024*1024*1024} {
+ set size [format %.1f\ GB [expr {$size/1024/1024/1024.}]]
+ } elseif {$size >= 1024*1024} {
+ set size [format %.1f\ MB [expr {$size/1024/1024.}]]
+ } elseif {$size >= 1024} {
+ set size [format %.1f\ kB [expr {$size/1024.}]]
+ } else {
+ append size " bytes"
+ }
+ $tree set $id size $size
+ }
+ }
+
+ # Stop this code from rerunning on the current node
+ $tree set $node type processedDirectory
+}
+
+## Create the tree and set it up
+ttk::treeview $w.tree -columns {fullpath type size} -displaycolumns {size} \
+ -yscroll "$w.vsb set" -xscroll "$w.hsb set"
+ttk::scrollbar $w.vsb -orient vertical -command "$w.tree yview"
+ttk::scrollbar $w.hsb -orient horizontal -command "$w.tree xview"
+$w.tree heading \#0 -text "Directory Structure"
+$w.tree heading size -text "File Size"
+$w.tree column size -width 70
+populateRoots $w.tree
+bind $w.tree <<TreeviewOpen>> {populateTree %W [%W focus]}
+
+## Arrange the tree and its scrollbars in the toplevel
+lower [ttk::frame $w.dummy]
+pack $w.dummy -fill both -expand 1
+grid $w.tree $w.vsb -sticky nsew -in $w.dummy
+grid $w.hsb -sticky nsew -in $w.dummy
+grid columnconfigure $w.dummy 0 -weight 1
+grid rowconfigure $w.dummy 0 -weight 1
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/tree.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ttkbut.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ttkbut.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ttkbut.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,84 @@
+# ttkbut.tcl --
+#
+# This demonstration script creates a toplevel window containing several
+# simple Ttk widgets, such as labels, labelframes, buttons, checkbuttons and
+# radiobuttons.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+set w .ttkbut
+catch {destroy $w}
+toplevel $w
+wm title $w "Simple Ttk Widgets"
+wm iconname $w "ttkbut"
+positionWindow $w
+
+ttk::label $w.msg -font $font -wraplength 4i -justify left -text "Ttk is the new Tk themed widget set. This is a Ttk themed label, and below are three groups of Ttk widgets in Ttk labelframes. The first group are all buttons that set the current application theme when pressed. The second group contains three sets of checkbuttons, with a separator widget between the sets. Note that the “Enabled” button controls whether all the other themed widgets in this toplevel are in the disabled state. The third group has a collection of linked radiobuttons."
+pack $w.msg -side top -fill x
+
+## See Code / Dismiss
+pack [addSeeDismiss $w.seeDismiss $w {enabled cheese tomato basil oregano happiness}]\
+ -side bottom -fill x
+
+## Add buttons for setting the theme
+ttk::labelframe $w.buttons -text "Buttons"
+foreach theme [lsort [ttk::themes]] {
+ ttk::button $w.buttons.$theme -text $theme \
+ -command [list ttk::setTheme $theme]
+ pack $w.buttons.$theme -pady 1.5p
+}
+
+## Helper procedure for the top checkbutton
+proc setState {rootWidget exceptThese value} {
+ if {$rootWidget in $exceptThese} {
+ return
+ }
+ ## Non-Ttk widgets (e.g. the toplevel) will fail, so make it silent
+ catch {
+ $rootWidget state $value
+ }
+ ## Recursively invoke on all children of this root that are in the same
+ ## toplevel widget
+ foreach w [winfo children $rootWidget] {
+ if {[winfo toplevel $w] eq [winfo toplevel $rootWidget]} {
+ setState $w $exceptThese $value
+ }
+ }
+}
+
+## Set up the checkbutton group
+ttk::labelframe $w.checks -text "Checkbuttons"
+ttk::checkbutton $w.checks.e -text Enabled -variable enabled -command {
+ setState .ttkbut .ttkbut.checks.e \
+ [expr {$enabled ? "!disabled" : "disabled"}]
+}
+set enabled 1
+## See ttk_widget(n) for other possible state flags
+ttk::separator $w.checks.sep1
+ttk::checkbutton $w.checks.c1 -text Cheese -variable cheese
+ttk::checkbutton $w.checks.c2 -text Tomato -variable tomato
+ttk::separator $w.checks.sep2
+ttk::checkbutton $w.checks.c3 -text Basil -variable basil
+ttk::checkbutton $w.checks.c4 -text Oregano -variable oregano
+pack $w.checks.e $w.checks.sep1 $w.checks.c1 $w.checks.c2 $w.checks.sep2 \
+ $w.checks.c3 $w.checks.c4 -fill x -pady 1.5p
+
+## Set up the radiobutton group
+ttk::labelframe $w.radios -text "Radiobuttons"
+ttk::radiobutton $w.radios.r1 -text "Great" -variable happiness -value great
+ttk::radiobutton $w.radios.r2 -text "Good" -variable happiness -value good
+ttk::radiobutton $w.radios.r3 -text "OK" -variable happiness -value ok
+ttk::radiobutton $w.radios.r4 -text "Poor" -variable happiness -value poor
+ttk::radiobutton $w.radios.r5 -text "Awful" -variable happiness -value awful
+pack $w.radios.r1 $w.radios.r2 $w.radios.r3 $w.radios.r4 $w.radios.r5 \
+ -fill x -padx 3p -pady 1.5p
+
+## Arrange things neatly
+pack [ttk::frame $w.f] -fill both -expand 1
+lower $w.f
+grid $w.buttons $w.checks $w.radios -in $w.f -sticky nwe -pady 1.5p -padx 3p
+grid columnconfigure $w.f {0 1 2} -weight 1 -uniform yes
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ttkbut.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ttkmenu.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ttkmenu.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ttkmenu.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,53 @@
+# ttkmenu.tcl --
+#
+# This demonstration script creates a toplevel window containing several Ttk
+# menubutton widgets.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+set w .ttkmenu
+catch {destroy $w}
+toplevel $w
+wm title $w "Ttk Menu Buttons"
+wm iconname $w "ttkmenu"
+positionWindow $w
+
+ttk::label $w.msg -font $font -wraplength 4i -justify left -text "Ttk is the new Tk themed widget set, and one widget that is available in themed form is the menubutton. Below are some themed menu buttons that allow you to pick the current theme in use. Notice how picking a theme changes the way that the menu buttons themselves look, and that the central menu button is styled differently (in a way that is normally suitable for toolbars). However, there are no themed menus; the standard Tk menus were judged to have a sufficiently good look-and-feel on all platforms, especially as they are implemented as native controls in many places."
+pack $w.msg [ttk::separator $w.msgSep] -side top -fill x
+
+## See Code / Dismiss
+pack [addSeeDismiss $w.seeDismiss $w] -side bottom -fill x
+
+ttk::menubutton $w.m1 -menu $w.m1.menu -text "Select a theme" -direction above
+ttk::menubutton $w.m2 -menu $w.m1.menu -text "Select a theme" -direction left
+ttk::menubutton $w.m3 -menu $w.m1.menu -text "Select a theme" -direction right
+ttk::menubutton $w.m4 -menu $w.m1.menu -text "Select a theme" \
+ -direction flush -style TMenubutton.Toolbutton
+ttk::menubutton $w.m5 -menu $w.m1.menu -text "Select a theme" -direction below
+
+menu $w.m1.menu -tearoff 0
+menu $w.m2.menu -tearoff 0
+menu $w.m3.menu -tearoff 0
+menu $w.m4.menu -tearoff 0
+menu $w.m5.menu -tearoff 0
+
+foreach theme [lsort [ttk::themes]] {
+ $w.m1.menu add command -label $theme -command [list ttk::setTheme $theme]
+ $w.m2.menu add command -label $theme -command [list ttk::setTheme $theme]
+ $w.m3.menu add command -label $theme -command [list ttk::setTheme $theme]
+ $w.m4.menu add command -label $theme -command [list ttk::setTheme $theme]
+ $w.m5.menu add command -label $theme -command [list ttk::setTheme $theme]
+}
+
+pack [ttk::frame $w.f] -fill x
+pack [ttk::frame $w.f1] -fill both -expand yes
+lower $w.f
+
+grid anchor $w.f center
+grid x $w.m1 x -in $w.f -padx 2.25p -pady 1.5p
+grid $w.m2 $w.m4 $w.m3 -in $w.f -padx 2.25p -pady 1.5p
+grid x $w.m5 x -in $w.f -padx 2.25p -pady 1.5p
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ttkmenu.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ttknote.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ttknote.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ttknote.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,57 @@
+# ttknote.tcl --
+#
+# This demonstration script creates a toplevel window containing a Ttk
+# notebook widget.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+set w .ttknote
+catch {destroy $w}
+toplevel $w
+wm title $w "Ttk Notebook Widget"
+wm iconname $w "ttknote"
+positionWindow $w
+
+## See Code / Dismiss
+pack [addSeeDismiss $w.seeDismiss $w] -side bottom -fill x
+
+ttk::frame $w.f
+pack $w.f -fill both -expand 1
+set w $w.f
+
+## Make the notebook and set up Ctrl+Tab traversal
+ttk::notebook $w.note
+pack $w.note -fill both -expand 1 -padx 1.5p -pady 3p
+ttk::notebook::enableTraversal $w.note
+
+## Popuplate the first pane
+ttk::frame $w.note.msg
+ttk::label $w.note.msg.m -font $font -wraplength 4i -justify left -anchor n -text "Ttk is the new Tk themed widget set. One of the widgets it includes is the notebook widget, which provides a set of tabs that allow the selection of a group of panels, each with distinct content. They are a feature of many modern user interfaces. Not only can the tabs be selected with the mouse, but they can also be switched between using Ctrl+Tab when the notebook page heading itself is selected. Note that the second tab is disabled, and cannot be selected."
+ttk::button $w.note.msg.b -text "Neat!" -underline 0 -command {
+ set neat "Yeah, I know..."
+ after 500 {set neat {}}
+}
+bind $w <Alt-n> "focus $w.note.msg.b; $w.note.msg.b invoke"
+ttk::label $w.note.msg.l -textvariable neat
+$w.note add $w.note.msg -text "Description" -underline 0 -padding 1.5p
+grid $w.note.msg.m - -sticky new -pady 1.5p
+grid $w.note.msg.b $w.note.msg.l -pady {1.5p 3p}
+grid rowconfigure $w.note.msg 1 -weight 1
+grid columnconfigure $w.note.msg {0 1} -weight 1 -uniform 1
+
+## Populate the second pane. Note that the content doesn't really matter
+ttk::frame $w.note.disabled
+$w.note add $w.note.disabled -text "Disabled" -state disabled
+
+## Popuplate the third pane
+ttk::frame $w.note.editor
+$w.note add $w.note.editor -text "Text Editor" -underline 0
+text $w.note.editor.t -width 40 -height 10 -wrap char \
+ -yscroll "$w.note.editor.s set"
+ttk::scrollbar $w.note.editor.s -orient vertical -command "$w.note.editor.t yview"
+pack $w.note.editor.s -side right -fill y -padx {0 1.5p} -pady 1.5p
+pack $w.note.editor.t -fill both -expand 1 -pady 1.5p -padx {1.5p 0}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ttknote.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ttkpane.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ttkpane.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ttkpane.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,112 @@
+# ttkpane.tcl --
+#
+# This demonstration script creates a Ttk pane with some content.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+set w .ttkpane
+catch {destroy $w}
+toplevel $w
+wm title $w "Themed Nested Panes"
+wm iconname $w "ttkpane"
+positionWindow $w
+
+ttk::label $w.msg -font $font -wraplength 4i -justify left -text "This demonstration shows off a nested set of themed paned windows. Their sizes can be changed by grabbing the area between each contained pane and dragging the divider."
+pack $w.msg [ttk::separator $w.msgSep] -side top -fill x
+
+## See Code / Dismiss
+pack [addSeeDismiss $w.seeDismiss $w] -side bottom -fill x
+
+ttk::frame $w.f
+pack $w.f -fill both -expand 1
+set w $w.f
+ttk::panedwindow $w.outer -orient horizontal
+$w.outer add [ttk::panedwindow $w.outer.inLeft -orient vertical]
+$w.outer add [ttk::panedwindow $w.outer.inRight -orient vertical]
+$w.outer.inLeft add [ttk::labelframe $w.outer.inLeft.top -text Button]
+$w.outer.inLeft add [ttk::labelframe $w.outer.inLeft.bot -text Clocks]
+$w.outer.inRight add [ttk::labelframe $w.outer.inRight.top -text Progress]
+$w.outer.inRight add [ttk::labelframe $w.outer.inRight.bot -text Text]
+if {[tk windowingsystem] eq "aqua"} {
+ foreach i [list inLeft.top inLeft.bot inRight.top inRight.bot] {
+ $w.outer.$i configure -padding 3
+ }
+}
+
+# Fill the button pane
+ttk::button $w.outer.inLeft.top.b -text "Press Me" -command {
+ tk_messageBox -type ok -icon info -message "Ouch!" -detail "That hurt..." \
+ -parent .ttkpane -title "Button Pressed"
+}
+pack $w.outer.inLeft.top.b -padx 1.5p -pady 3p
+
+# Fill the clocks pane
+set i 0
+proc every {delay script} {
+ uplevel #0 $script
+ after $delay [list every $delay $script]
+}
+set testzones {
+ :Europe/Berlin
+ :America/Argentina/Buenos_Aires
+ :Africa/Johannesburg
+ :Europe/London
+ :America/Los_Angeles
+ :Europe/Moscow
+ :America/New_York
+ :Asia/Singapore
+ :Australia/Sydney
+ :Asia/Tokyo
+}
+# Force a pre-load of all the timezones needed; otherwise can end up
+# poor-looking synch problems!
+set zones {}
+foreach zone $testzones {
+ if {![catch {clock format 0 -timezone $zone}]} {
+ lappend zones $zone
+ }
+}
+if {[llength $zones] < 2} { lappend zones -0200 :GMT :UTC +0200 }
+foreach zone $zones {
+ set city [string map {_ " "} [regexp -inline {[^/]+$} $zone]]
+ if {$i} {
+ pack [ttk::separator $w.outer.inLeft.bot.s$i] -fill x
+ }
+ ttk::label $w.outer.inLeft.bot.l$i -text $city -anchor w
+ ttk::label $w.outer.inLeft.bot.t$i -textvariable time($zone) -anchor w
+ pack $w.outer.inLeft.bot.l$i $w.outer.inLeft.bot.t$i -fill x
+ every 1000 "set time($zone) \[clock format \[clock seconds\] -timezone $zone -format %T\]"
+ incr i
+}
+
+# Fill the progress pane
+ttk::progressbar $w.outer.inRight.top.progress -mode indeterminate
+pack $w.outer.inRight.top.progress -fill both -expand 1
+$w.outer.inRight.top.progress start
+
+# Fill the text pane
+if {[tk windowingsystem] ne "aqua"} {
+ # The trick with the ttk::frame makes the text widget look like it fits with
+ # the current Ttk theme despite not being a themed widget itself. It is done
+ # by styling the frame like an entry, turning off the border in the text
+ # widget, and putting the text widget in the frame with enough space to allow
+ # the surrounding border to show through (2 pixels seems to be enough).
+ ttk::frame $w.outer.inRight.bot.f -style TEntry
+ text $w.txt -wrap word -yscroll "$w.sb set" -width 30 -borderwidth 0
+ pack $w.txt -fill both -expand 1 -in $w.outer.inRight.bot.f -pady 1.5p -padx 1.5p
+ ttk::scrollbar $w.sb -orient vertical -command "$w.txt yview"
+ pack $w.sb -side right -fill y -in $w.outer.inRight.bot
+ pack $w.outer.inRight.bot.f -fill both -expand 1
+ pack $w.outer -fill both -expand 1
+} else {
+ text $w.txt -wrap word -yscroll "$w.sb set" -width 30 -borderwidth 0
+ ttk::scrollbar $w.sb -orient vertical -command "$w.txt yview"
+ pack $w.sb -side right -fill y -in $w.outer.inRight.bot
+ pack $w.txt -fill both -expand 1 -in $w.outer.inRight.bot
+ pack $w.outer -fill both -expand 1 -padx 10 -pady {6 10}
+}
+
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ttkpane.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ttkprogress.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ttkprogress.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ttkprogress.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,46 @@
+# ttkprogress.tcl --
+#
+# This demonstration script creates several progress bar widgets.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+set w .ttkprogress
+catch {destroy $w}
+toplevel $w
+wm title $w "Progress Bar Demonstration"
+wm iconname $w "ttkprogress"
+positionWindow $w
+
+ttk::label $w.msg -font $font -wraplength 4i -justify left -text "Below are two progress bars. The top one is a “determinate” progress bar, which is used for showing how far through a defined task the program has got. The bottom one is an “indeterminate” progress bar, which is used to show that the program is busy but does not know how long for. Both are run here in self-animated mode, which can be turned on and off using the buttons underneath."
+pack $w.msg -side top -fill x
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+ttk::frame $w.f
+pack $w.f -fill both -expand 1
+set w $w.f
+
+proc doBars {op args} {
+ foreach w $args {
+ $w $op
+ }
+}
+ttk::progressbar $w.p1 -mode determinate
+ttk::progressbar $w.p2 -mode indeterminate
+ttk::button $w.start -text "Start Progress" -command [list \
+ doBars start $w.p1 $w.p2]
+ttk::button $w.stop -text "Stop Progress" -command [list \
+ doBars stop $w.p1 $w.p2]
+
+grid $w.p1 - -pady 3p -padx 7.5p
+grid $w.p2 - -pady 3p -padx 7.5p
+grid $w.start $w.stop -padx 7.5p -pady 3p
+grid configure $w.start -sticky e
+grid configure $w.stop -sticky w
+grid columnconfigure $w all -weight 1
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ttkprogress.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ttkscale.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ttkscale.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ttkscale.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,39 @@
+# ttkscale.tcl --
+#
+# This demonstration script shows an example with a horizontal scale.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+set w .ttkscale
+catch {destroy $w}
+toplevel $w -bg [ttk::style lookup TLabel -background]
+wm title $w "Themed Scale Demonstration"
+wm iconname $w "ttkscale"
+positionWindow $w
+
+pack [ttk::frame [set w $w.contents]] -fill both -expand 1
+
+ttk::label $w.msg -font $font -wraplength 3.5i -justify left -text "A label tied to a horizontal scale is displayed below. If you click or drag mouse button 1 in the scale, you can change the contents of the label; a callback command is used to couple the slider to both the text and the coloring of the label."
+pack $w.msg -side top -padx .5c
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons [winfo toplevel $w]]
+pack $btns -side bottom -fill x
+
+ttk::frame $w.frame -borderwidth 7.5p
+pack $w.frame -side top -fill x
+
+# List of colors from rainbow; "Indigo" is not a standard color
+set colorList {Red Orange Yellow Green Blue Violet}
+ttk::label $w.frame.label
+ttk::scale $w.frame.scale -from 0 -to 5 -command [list apply {{w idx} {
+ set c [lindex $::colorList [tcl::mathfunc::int $idx]]
+ $w.frame.label configure -foreground $c -text "Color: $c"
+}} $w]
+# Trigger the setting of the label's text
+$w.frame.scale set 0
+pack $w.frame.label $w.frame.scale
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ttkscale.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ttkspin.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ttkspin.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ttkspin.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,49 @@
+# ttkspin.tcl --
+#
+# This demonstration script creates several Ttk spinbox widgets.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+set w .ttkspin
+catch {destroy $w}
+toplevel $w
+wm title $w "Themed Spinbox Demonstration"
+wm iconname $w "ttkspin"
+positionWindow $w
+
+label $w.msg -font $font -wraplength 5i -justify left -text "Three different\
+ themed spin-boxes 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 values that are too large to fit in the\
+ window all at once, you can scan through the value by dragging with\
+ mouse button2 pressed. Note that the first spin-box will only permit\
+ you to type in integers, and the third selects from a list of\
+ Australian cities."
+pack $w.msg -side top
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+set australianCities {
+ Canberra Sydney Melbourne Perth Adelaide Brisbane
+ Hobart Darwin "Alice Springs"
+}
+
+ttk::spinbox $w.s1 -from 1 -to 10 -width 10 -validate key \
+ -validatecommand {string is integer %P}
+ttk::spinbox $w.s2 -from 0 -to 3 -increment .5 -format %05.2f -width 10
+ttk::spinbox $w.s3 -values $australianCities -width 10
+
+$w.s1 set 1
+$w.s2 set 00.00
+$w.s3 set Canberra
+
+pack $w.s1 $w.s2 $w.s3 -side top -pady 3p -padx 7.5p
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/ttkspin.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/twind.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/twind.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/twind.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,358 @@
+# twind.tcl --
+#
+# This demonstration script creates a text widget with a bunch of
+# embedded windows.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+# Make an Aqua button's fill color match its parent's background
+proc blend {bt} {
+ if {[tk windowingsystem] eq "aqua"} {
+ $bt configure -highlightbackground [[winfo parent $bt] cget -background]
+ }
+ return $bt
+}
+
+set w .twind
+catch {destroy $w}
+toplevel $w
+wm title $w "Text Demonstration - Embedded Windows and Other Features"
+wm iconname $w "Embedded Windows"
+positionWindow $w
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+frame $w.f -highlightthickness 1 -borderwidth 1 -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
+ttk::scrollbar $w.scroll -command "$t yview"
+pack $w.scroll -side right -fill y
+panedwindow $w.pane
+pack $w.pane -expand yes -fill both
+$w.pane add $w.f -stretch always
+# Import to raise given creation order above
+raise $w.f
+
+$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
+
+$t insert end "A text widget can contain many different kinds of items, "
+$t insert end "both active and passive. It can lay these out in various "
+$t insert end "ways, with wrapping, tabs, centering, etc. In addition, "
+$t insert end "when the contents are too big for the window, smooth "
+$t insert end "scrolling in all directions is provided.\n\n"
+
+$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 [blend $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 [blend $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 -create {
+ button %W.click -text "Click Here" -command "textWindPlot %W" \
+ -cursor top_left_arrow
+ blend %W.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 -create {
+ button %W.delete -text "Delete" -command "textWindDel %W" \
+ -cursor top_left_arrow
+ blend %W.delete
+}
+$t insert end " the plot again.\n\n"
+
+$t insert end "You can also create multiple text widgets each of which "
+$t insert end "display the same underlying text. Click this button to "
+$t window create end \
+ -create {button %W.peer -text "Make A Peer" -command "textMakePeer %W" \
+ -cursor top_left_arrow
+ blend %W.peer} -padx 3p
+$t insert end " widget. Notice how peer widgets can have different "
+$t insert end "font settings, and by default contain all the images "
+$t insert end "of the 'parent', but that the embedded windows, "
+$t insert end "such as buttons may not appear in the peer. To ensure "
+$t insert end "that embedded windows appear in all peers you can set the "
+$t insert end "'-create' option to a script or a string containing %W. "
+$t insert end "(The plot above and the 'Make A Peer' button are "
+$t insert end "designed to show up in all peers.) A good use of "
+$t insert end "peers is for "
+$t window create end \
+ -create {button %W.split -text "Split Windows" -command "textSplitWindow %W" \
+ -cursor top_left_arrow
+ blend %W.split} -padx 3p
+$t insert end " \n\n"
+
+$t insert end "Users of previous versions of Tk will also be interested "
+$t insert end "to note that now cursor movement is now by visual line by "
+$t insert end "default, and that all scrolling of this widget is by pixel.\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"
+
+$t insert end "\nNOTE: these buttons will not appear in peers!\n" "peer_warning"
+button $t.default -text Default -command "embDefBg $t" \
+ -cursor top_left_arrow
+$t window create end -window $t.default -padx 3p
+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 3p -padx 1.5p
+$t window create end -window $t.toggle -padx 3p -pady 1.5p
+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 \
+ "changeBg $t $color"
+ $t window create end -window [blend $t.color$i] -padx 3p -pady 1.5p
+ incr i
+}
+$t tag add buttons [blend $t.default] end
+
+button $t.bigB -text "Big borders" -command "textWindBigB $t" \
+ -cursor top_left_arrow
+button $t.smallB -text "Small borders" -command "textWindSmallB $t" \
+ -cursor top_left_arrow
+button $t.bigH -text "Big highlight" -command "textWindBigH $t" \
+ -cursor top_left_arrow
+button $t.smallH -text "Small highlight" -command "textWindSmallH $t" \
+ -cursor top_left_arrow
+button $t.bigP -text "Big pad" -command "textWindBigP $t" \
+ -cursor top_left_arrow
+button $t.smallP -text "Small pad" -command "textWindSmallP $t" \
+ -cursor top_left_arrow
+
+set text_normal(border) [$t cget -borderwidth]
+set text_normal(highlight) [$t cget -highlightthickness]
+set text_normal(pad) [$t cget -padx]
+
+$t insert end "\nYou can also change the usual border width and "
+$t insert end "highlightthickness and padding.\n"
+$t window create end -window [blend $t.bigB]
+$t window create end -window [blend $t.smallB]
+$t window create end -window [blend $t.bigH]
+$t window create end -window [blend $t.smallH]
+$t window create end -window [blend $t.bigP]
+$t window create end -window [blend $t.smallP]
+
+$t insert end "\n\nFinally, images fit comfortably in text widgets too:"
+
+image create photo img -file [file join $tk_demoDirectory images ouster.png]
+
+# Create a copy of the image just created, magnified according to the
+# display's DPI scaling level. Since the zooom factor must be an integer,
+# the copy will only be effectively magnified if $tk::scalingPct >= 200.
+image create photo img2
+img2 copy img -zoom [expr {$tk::scalingPct / 100}]
+
+$t image create end -image img2
+
+proc textWindBigB w {
+ $w configure -borderwidth 12p
+}
+
+proc textWindBigH w {
+ $w configure -highlightthickness 12p
+}
+
+proc textWindBigP w {
+ $w configure -padx 12p -pady 12p
+}
+
+proc textWindSmallB w {
+ $w configure -borderwidth $::text_normal(border)
+}
+
+proc textWindSmallH w {
+ $w configure -highlightthickness $::text_normal(highlight)
+}
+
+proc textWindSmallP w {
+ $w configure -padx $::text_normal(pad) -pady $::text_normal(pad)
+}
+
+proc textWindOn w {
+ catch {destroy $w.scroll2}
+ set t $w.f.text
+ ttk::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
+ }
+
+ while {[string first [$t get plot] " \t\n"] >= 0} {
+ $t delete plot
+ }
+ $t insert plot "\n"
+
+ $t window create plot -create {createPlot %W}
+ $t tag add center plot
+ $t insert plot "\n"
+}
+
+proc createPlot {t} {
+ set c $t.c
+
+ 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 <Enter> "$c itemconfig current -fill red"
+ $c bind point <Leave> "$c itemconfig current -fill SkyBlue2"
+ $c bind point <Button-1> "embPlotDown $c %x %y"
+ $c bind point <ButtonRelease-1> "$c dtag selected"
+ bind $c <B1-Motion> "embPlotMove $c %x %y"
+ return $c
+}
+
+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 t {
+ 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 changeBg {t c} {
+ $t configure -background $c
+ if {[tk windowingsystem] eq "aqua"} {
+ foreach b [$t window names] {
+ if {[winfo class $b] eq "Button"} {
+ $b configure -highlightbackground $c
+ }
+ }
+ }
+}
+
+proc embDefBg t {
+ set bg [lindex [$t configure -background] 3]
+ changeBg $t $bg
+}
+
+proc textMakePeer {parent} {
+ set n 1
+ while {[winfo exists .peer$n]} { incr n }
+ set w [toplevel .peer$n]
+ wm title $w "Text Peer #$n"
+ frame $w.f -highlightthickness 1 -borderwidth 1 -relief sunken
+ set t [$parent peer create $w.f.text -yscrollcommand "$w.scroll set" \
+ -borderwidth 0 -highlightthickness 0]
+ $t tag configure peer_warning -font boldFont
+ pack $t -expand yes -fill both
+ ttk::scrollbar $w.scroll -command "$t yview"
+ pack $w.scroll -side right -fill y
+ pack $w.f -expand yes -fill both
+}
+
+proc textSplitWindow {textW} {
+ if {$textW eq ".twind.f.text"} {
+ if {[winfo exists .twind.peer]} {
+ destroy .twind.peer
+ } else {
+ set parent [winfo parent $textW]
+ set w [winfo parent $parent]
+ set t [$textW peer create $w.peer \
+ -yscrollcommand "$w.scroll set"]
+ $t tag configure peer_warning -font boldFont
+ $w.pane add $t -stretch always
+ }
+ } else {
+ return
+ }
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/twind.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/unicodeout.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/unicodeout.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/unicodeout.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,126 @@
+# unicodeout.tcl --
+#
+# This demonstration script shows how you can produce output (in label
+# widgets) using many different alphabets.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+set w .unicodeout
+catch {destroy $w}
+toplevel $w
+wm title $w "Unicode Label Demonstration"
+wm iconname $w "unicodeout"
+positionWindow $w
+
+label $w.msg -font $font -wraplength 4i -anchor w -justify left \
+ -text "This is a sample of Tk's support for languages that use\
+ non-Western character sets. However, what you will actually see\
+ below depends largely on what character sets you have installed,\
+ and what you see for characters that are not present varies greatly\
+ between platforms as well."
+pack $w.msg -side top
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+## The frame that will contain the sample texts.
+pack [frame $w.f] -side bottom -expand 1 -fill both -padx 2m -pady 1m
+grid columnconfigure $w.f 1 -weight 1
+set i 0
+proc addSample {w language args} {
+ global font i
+ set sample [join $args ""]
+ set j [incr i]
+ label $w.f.l$j -font $font -text "${language}:" -anchor nw -pady 0
+ label $w.f.s$j -font $font -text $sample -anchor nw -width 30 -pady 0
+ grid $w.f.l$j $w.f.s$j -sticky ew -pady 0
+ grid configure $w.f.l$j -padx 1m
+}
+
+## A helper procedure that determines what form to use to express languages
+## that have complex rendering rules...
+proc usePresentationFormsFor {language} {
+ switch [tk windowingsystem] {
+ aqua {
+ # OSX wants natural character order; the renderer knows how to
+ # compose things for display for all languages.
+ return false
+ }
+ x11 {
+ # The X11 font renderers that Tk supports all know nothing about
+ # composing characters, so we need to use presentation forms.
+ return true
+ }
+ win32 {
+ # On Windows, we need to determine whether the font system will
+ # render right-to-left text. This varies by language!
+ try {
+ package require registry
+ set rkey [join {
+ HKEY_LOCAL_MACHINE
+ SOFTWARE
+ Microsoft
+ {Windows NT}
+ CurrentVersion
+ LanguagePack
+ } \\]
+ return [expr {
+ [string toupper $language] ni [registry values $rkey]
+ }]
+ } trap error {} {
+ # Cannot work it out, so use presentation forms.
+ return true
+ }
+ }
+ default {
+ # Default to using presentation forms.
+ return true
+ }
+ }
+}
+
+## Processing when some characters are not currently cached by the display
+## engine might take a while, so make sure we're displaying something in the
+## meantime...
+pack [label $w.wait -text "Please wait while loading fonts..." \
+ -font {Helvetica 12 italic}]
+set oldCursor [$w cget -cursor]
+$w conf -cursor watch
+update
+
+## Add the samples...
+if {[usePresentationFormsFor Arabic]} {
+ # Using presentation forms (pre-layouted)
+ addSample $w Arabic "ﺔﻴﺑﺮﻌﻟﺍ ﺔﻤﻠﻜﻟﺍ"
+} else {
+ # Using standard text characters
+ addSample $w Arabic "الكلمة العربية"
+}
+addSample $w "Trad. Chinese" "中國的漢字"
+addSample $w "Simpl. Chinese" "汉语"
+addSample $w French "Langue française"
+addSample $w Greek "Ελληνική γλώσσα"
+if {[usePresentationFormsFor Hebrew]} {
+ # Visual order (pre-layouted)
+ addSample $w Hebrew "תירבע בתכ"
+} else {
+ # Standard logical order
+ addSample $w Hebrew "כתב עברית"
+}
+addSample $w Hindi "हिन्दी भाषा"
+addSample $w Icelandic "Íslenska"
+addSample $w Japanese "日本語のひらがな, 漢字とカタカナ"
+addSample $w Korean "대한민국의 한글"
+addSample $w Russian "Русский язык"
+if {([tk windowingsystem] ne "x11") || (![catch {tk::pkgconfig get fontsystem} fs] && ($fs eq "xft"))} {
+ addSample $w Emoji "😀💩👍🇳🇱"
+}
+
+## We're done processing, so change things back to normal running...
+destroy $w.wait
+$w conf -cursor $oldCursor
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/unicodeout.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/vscale.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/vscale.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/vscale.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,50 @@
+# vscale.tcl --
+#
+# This demonstration script shows an example with a vertical scale.
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+package require tk
+
+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
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+frame $w.frame -borderwidth 7.5p
+pack $w.frame
+
+scale $w.frame.scale -orient vertical -length 213p -from 0 -to 250 \
+ -command "setHeight $w.frame.canvas" -tickinterval 50
+canvas $w.frame.canvas -width 37.5p -height 37.5p -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 11.25p
+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
+
+ set scaleFactor [expr {$tk::scalingPct / 100.0}]
+ $w scale poly 0 0 $scaleFactor $scaleFactor
+ $w scale line 0 0 $scaleFactor $scaleFactor
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/vscale.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/widget
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/widget (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/widget 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,713 @@
+#!/bin/sh
+# the next line restarts using wish \
+exec wish90 "$0" ${1+"$@"}
+
+# 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.
+
+package require tk 8.7-
+package require msgcat
+
+destroy {*}[winfo children .]
+set tk_demoDirectory [file join [pwd] [file dirname [info script]]]
+::msgcat::mcload $tk_demoDirectory
+namespace import ::msgcat::mc
+wm title . [mc "Widget Demonstration"]
+if {[tk windowingsystem] eq "x11"} {
+ # This won't work everywhere, but there's no other way in core Tk at the
+ # moment to display a coloured icon.
+ image create photo TclPowered \
+ -file [file join $tk_library images logo64.gif]
+ wm iconwindow . [toplevel ._iconWindow]
+ pack [label ._iconWindow.i -image TclPowered]
+ wm iconname . [mc "tkWidgetDemo"]
+}
+
+if {"defaultFont" ni [font names]} {
+ # TIP #145 defines some standard named fonts
+ if {"TkDefaultFont" in [font names] && "TkFixedFont" in [font names]} {
+ # FIX ME: the following technique of cloning the font to copy it works
+ # fine but means that if the system font is changed by Tk
+ # cannot update the copied font. font alias might be useful
+ # here -- or fix the app to use TkDefaultFont etc.
+ font create mainFont {*}[font configure TkDefaultFont]
+ font create fixedFont {*}[font configure TkFixedFont]
+ font create boldFont {*}[font configure TkDefaultFont] -weight bold
+ font create titleFont {*}[font configure TkDefaultFont] -weight bold
+ font create statusFont {*}[font configure TkDefaultFont]
+ font create varsFont {*}[font configure TkDefaultFont]
+ if {[tk windowingsystem] eq "aqua"} {
+ font configure titleFont -size 17
+ }
+ } else {
+ font create mainFont -family Helvetica -size 12
+ font create fixedFont -family Courier -size 10
+ font create boldFont -family Helvetica -size 12 -weight bold
+ font create titleFont -family Helvetica -size 18 -weight bold
+ font create statusFont -family Helvetica -size 10
+ font create varsFont -family Helvetica -size 14
+ }
+}
+
+set widgetDemo 1
+set font mainFont
+
+# The SVG images used below are based on some icons provided by the
+# official open source SVG icon library for the Bootstrap project,
+# licensed under the MIT license (https://opensource.org/licenses/MIT).
+#
+# See https://github.com/twbs/icons.
+
+set viewData {
+ <?xml version="1.0" encoding="UTF-8"?>
+ <svg width="16" height="16" version="1.1" xmlns="http://www.w3.org/2000/svg">
+ <path d="M11.742 10.344a6.5 6.5 0 1 0-1.397 1.398h-.001c.03.04.062.078.098.115l3.85 3.85a1 1 0 0 0 1.415-1.414l-3.85-3.85a1.007 1.007 0 0 0-.115-.1zM12 6.5a5.5 5.5 0 1 1-11 0 5.5 5.5 0 0 1 11 0z" fill="#000000"/>
+ </svg>
+}
+
+set refreshData {
+ <?xml version="1.0" encoding="UTF-8"?>
+ <svg width="16" height="16" version="1.1" xmlns="http://www.w3.org/2000/svg">
+ <path d="M11 5.466V4H5a4 4 0 0 0-3.584 5.777.5.5 0 1 1-.896.446A5 5 0 0 1 5 3h6V1.534a.25.25 0 0 1 .41-.192l2.36 1.966c.12.1.12.284 0 .384l-2.36 1.966a.25.25 0 0 1-.41-.192Zm3.81.086a.5.5 0 0 1 .67.225A5 5 0 0 1 11 13H5v1.466a.25.25 0 0 1-.41.192l-2.36-1.966a.25.25 0 0 1 0-.384l2.36-1.966a.25.25 0 0 1 .41.192V12h6a4 4 0 0 0 3.585-5.777.5.5 0 0 1 .225-.67Z" fill="#000000"/>
+ </svg>
+}
+
+set printData {
+ <?xml version="1.0" encoding="UTF-8"?>
+ <svg width="16" height="16" version="1.1" xmlns="http://www.w3.org/2000/svg">
+ <path d="M2.5 8a.5.5 0 1 0 0-1 .5.5 0 0 0 0 1z" fill="#000000"/>
+ <path d="M5 1a2 2 0 0 0-2 2v2H2a2 2 0 0 0-2 2v3a2 2 0 0 0 2 2h1v1a2 2 0 0 0 2 2h6a2 2 0 0 0 2-2v-1h1a2 2 0 0 0 2-2V7a2 2 0 0 0-2-2h-1V3a2 2 0 0 0-2-2H5zM4 3a1 1 0 0 1 1-1h6a1 1 0 0 1 1 1v2H4V3zm1 5a2 2 0 0 0-2 2v1H2a1 1 0 0 1-1-1V7a1 1 0 0 1 1-1h12a1 1 0 0 1 1 1v3a1 1 0 0 1-1 1h-1v-1a2 2 0 0 0-2-2H5zm7 2v3a1 1 0 0 1-1 1H5a1 1 0 0 1-1-1v-3a1 1 0 0 1 1-1h6a1 1 0 0 1 1 1z" fill="#000000"/>
+ </svg>
+}
+
+proc images {arg} {
+ set fgColor [ttk::style lookup . -foreground {} black]
+ lassign [winfo rgb . $fgColor] r g b
+ set fgColor [format "#%02x%02x%02x" \
+ [expr {$r >> 8}] [expr {$g >> 8}] [expr {$b >> 8}]]
+
+ foreach action {view refresh print} {
+ upvar ${action}Data imgData
+ for {set data $imgData; set startIdx 0} \
+ {[set idx1 [string first "#000000" $data $startIdx]] >= 0} \
+ {set startIdx [expr {$idx1 + 7}]} {
+ set idx2 [expr {$idx1 + 6}]
+ set data [string replace $data $idx1 $idx2 $fgColor]
+ }
+
+ switch $arg {
+ create {
+ image create photo ::img::$action -format $::tk::svgFmt \
+ -data $data
+ }
+ configure { ::img::$action configure -data $data }
+ }
+ }
+}
+
+images create
+set mainClass [winfo class .]
+foreach event {<<ThemeChanged>> <<LightAqua>> <<DarkAqua>>} {
+ bind $mainClass $event { images configure }
+}
+unset mainClass event
+
+image create photo ::img::delete -format $::tk::svgFmt -data {
+ <?xml version="1.0" encoding="UTF-8"?>
+ <svg width="16" height="16" version="1.1" xmlns="http://www.w3.org/2000/svg">
+ <path d="M2.146 2.854a.5.5 0 1 1 .708-.708L8 7.293l5.146-5.147a.5.5 0 0 1 .708.708L8.707 8l5.147 5.146a.5.5 0 0 1-.708.708L8 8.707l-5.146 5.147a.5.5 0 0 1-.708-.708L7.293 8 2.146 2.854Z" fill="#d00000"/>
+ </svg>
+}
+
+#----------------------------------------------------------------
+# The code below creates 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.
+#----------------------------------------------------------------
+
+menu .menuBar -tearoff 0
+
+# On Aqua, just use the default menu.
+if {[tk windowingsystem] ne "aqua"} {
+ # This is a tk-internal procedure to make i18n easier
+ ::tk::AmpMenuArgs .menuBar add cascade -label [mc "&File"] \
+ -menu .menuBar.file
+ menu .menuBar.file -tearoff 0
+ ::tk::AmpMenuArgs .menuBar.file add command -label [mc "&About..."] \
+ -command {tkAboutDialog} -accelerator [mc "<F1>"]
+ bind . <F1> {tkAboutDialog}
+ .menuBar.file add sep
+ if {[tk windowingsystem] eq "win32"} {
+ # Windows doesn't usually have a Meta key
+ ::tk::AmpMenuArgs .menuBar.file add command -label [mc "&Quit"] \
+ -command {exit} -accelerator [mc "Ctrl+Q"]
+ bind . <[mc "Control-q"]> {exit}
+ } else {
+ ::tk::AmpMenuArgs .menuBar.file add command -label [mc "&Quit"] \
+ -command {exit} -accelerator [mc "Meta-Q"]
+ bind . <[mc "Meta-q"]> {exit}
+ }
+ . configure -menu .menuBar
+}
+
+ttk::frame .statusBar
+ttk::label .statusBar.lab -text " " -anchor w
+if {[tk windowingsystem] eq "aqua"} {
+ ttk::separator .statusBar.sep
+ pack .statusBar.sep -side top -expand yes -fill x -pady 0
+}
+pack .statusBar.lab -side left -padx 1.5p -expand yes -fill both
+if {[tk windowingsystem] ne "aqua"} {
+ ttk::sizegrip .statusBar.foo
+ pack .statusBar.foo -side left -padx 1.5p
+}
+pack .statusBar -side bottom -fill x -pady 1.5p
+
+set textheight 30
+catch {
+ set textheight [expr {
+ ([winfo screenheight .] * 0.7) /
+ [font metrics mainFont -displayof . -linespace]
+ }]
+}
+
+ttk::frame .textFrame
+ttk::scrollbar .s -orient vertical -command {.t yview} -takefocus 1
+pack .s -in .textFrame -side right -fill y
+text .t -yscrollcommand {.s set} -wrap word -width 70 -height $textheight \
+ -font mainFont -setgrid 1 -highlightthickness 0 \
+ -padx 3p -pady 1.5p -takefocus 0
+pack .t -in .textFrame -expand y -fill both -padx 1
+pack .textFrame -expand yes -fill both
+if {[tk windowingsystem] eq "aqua"} {
+ pack configure .statusBar.lab -padx {10 18} -pady {4 6}
+ pack configure .statusBar -pady 0
+ .t configure -padx 10 -pady 0
+}
+
+# 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 titleFont
+.t tag configure subtitle -font titleFont
+.t tag configure bold -font boldFont
+if {[tk windowingsystem] eq "aqua"} {
+ .t tag configure title -spacing1 8
+ .t tag configure subtitle -spacing3 3
+}
+
+# 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
+ if {[tk windowingsystem] eq "aqua"} {
+ .t tag configure demo -foreground systemLinkColor
+ .t tag configure visited -foreground purple
+ }
+ .t tag configure hot -foreground red -underline 1
+}
+
+# The tag "new" must be the one having the highest priority.
+#
+.t tag configure new -foreground #c00000 -underline 0 -font boldFont
+
+.t tag bind demo <ButtonRelease-1> {
+ invoke [.t index {@%x,%y}]
+}
+set lastLine ""
+.t tag bind demo <Enter> {
+ set lastLine [.t index {@%x,%y linestart}]
+ .t tag add hot "$lastLine +1 chars" "$lastLine lineend -1 chars"
+ .t config -cursor [::ttk::cursor link]
+ showStatus [.t index {@%x,%y}]
+}
+.t tag bind demo <Leave> {
+ .t tag remove hot 1.0 end
+ .t config -cursor [::ttk::cursor text]
+ .statusBar.lab config -text ""
+}
+.t tag bind demo <Motion> {
+ set newLine [.t index {@%x,%y linestart}]
+ if {$newLine ne $lastLine} {
+ .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.
+
+# addFormattedText --
+#
+# Add formatted text (but not hypertext) to the text widget after first
+# passing it through the message catalog to allow for localization.
+# Lines starting with @@ are formatting directives (insert title, insert
+# demo hyperlink, begin newline, or change style) and all other lines
+# are literal strings to be inserted. Substitutions are performed,
+# allowing processing pieces through the message catalog. Blank lines
+# are ignored.
+#
+proc addFormattedText {formattedText} {
+ set style normal
+ set isNL 1
+ set demoCount 0
+ set new 0
+ foreach line [split $formattedText \n] {
+ set line [string trim $line]
+ if {$line eq ""} {
+ continue
+ }
+ if {[string match @@* $line]} {
+ set data [string range $line 2 end]
+ set key [lindex $data 0]
+ set values [lrange $data 1 end]
+ switch -exact -- $key {
+ title {
+ .t insert end [mc $values]\n title \n normal
+ }
+ newline {
+ .t insert end \n $style
+ set isNL 1
+ }
+ subtitle {
+ .t insert end "\n" {} [mc $values] subtitle \
+ " \n " demospace
+ set demoCount 0
+ }
+ demo {
+ set description [lassign $values name]
+ .t insert end "[incr demoCount]. [mc $description]" \
+ [list demo demo-$name]
+ if {$new} {
+ .t insert end " [mc NEW]" new
+ set new 0
+ }
+ .t insert end " \n " demospace
+ }
+ new {
+ set new 1
+ }
+ default {
+ set style $key
+ }
+ }
+ continue
+ }
+ if {!$isNL} {
+ .t insert end " " $style
+ }
+ set isNL 0
+ .t insert end [mc $line] $style
+ }
+}
+
+addFormattedText {
+ @@title Tk Widget Demonstrations
+
+ 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
+ @@bold
+ See Code
+ @@normal
+ button to see the Tcl/Tk code that created the demonstration. If
+ you wish, you can edit the code and click the
+ @@bold
+ Rerun Demo
+ @@normal
+ button in the code window to reinvoke the demonstration with the
+ modified code.
+ @@newline
+
+ @@subtitle Labels, buttons, checkbuttons, and radiobuttons
+ @@demo label Labels (text and bitmaps)
+ @@demo unicodeout Labels and UNICODE text
+ @@demo button Buttons
+ @@demo check Check-buttons (select any of a group)
+ @@demo radio Radio-buttons (select one of a group)
+ @@demo puzzle A 15-puzzle game made out of buttons
+ @@demo icon Iconic buttons that use bitmaps
+ @@demo image1 Two labels displaying images
+ @@demo image2 A simple user interface for viewing images
+ @@demo labelframe Labelled frames
+ @@demo ttkbut The simple Themed Tk widgets
+}
+
+if {[tk windowingsystem] eq "aqua"} {
+ addFormattedText {
+ @@subtitle Mac-Specific Widgets and Window Styles
+ @@new
+ @@demo mac_styles Special widgets for macOS
+ @@new
+ @@demo mac_wm Window styles for macOS
+ @@new
+ @@demo mac_tabs Tabbed Windows on macOS
+ }
+}
+
+addFormattedText {
+ @@subtitle Listboxes and Trees
+ @@demo states The 50 states
+ @@demo colors Colors: change the color scheme for the application
+ @@demo sayings A collection of famous and infamous sayings
+ @@demo mclist A multi-column list of countries
+ @@demo tree A directory browser tree
+
+ @@subtitle Entries, Spin-boxes and Combo-boxes
+ @@demo entry1 Entries without scrollbars
+ @@demo entry2 Entries with scrollbars
+ @@demo entry3 Validated entries and password fields
+ @@demo spin Spin-boxes
+ @@demo ttkspin Themed spin-boxes
+ @@demo combo Combo-boxes
+ @@demo form Simple Rolodex-like form
+
+ @@subtitle Text
+ @@demo text Basic editable text
+ @@demo style Text display styles
+ @@demo bind Hypertext (tag bindings)
+ @@demo twind A text widget with embedded windows and other features
+ @@demo search A search tool built with a text widget
+ @@demo textpeer Peering text widgets
+
+ @@subtitle Canvases
+ @@demo items The canvas item types
+ @@demo plot A simple 2-D plot
+ @@demo ctext Text items in canvases
+ @@demo arrow An editor for arrowheads on canvas lines
+ @@demo ruler A ruler with adjustable tab stops
+ @@demo floor A building floor plan
+ @@demo cscroll A simple scrollable canvas
+ @@demo knightstour A Knight's tour of the chess board
+
+ @@subtitle Scales and Progress Bars
+ @@demo hscale Horizontal scale
+ @@demo vscale Vertical scale
+ @@demo ttkscale Themed scale linked to a label with traces
+ @@demo ttkprogress Progress bar
+
+ @@subtitle Paned Windows and Notebooks
+ @@demo paned1 Horizontal paned window
+ @@demo paned2 Vertical paned window
+ @@demo ttkpane Themed nested panes
+ @@demo ttknote Notebook widget
+
+ @@subtitle Menus and Toolbars
+ @@demo menu Menus and cascades (sub-menus)
+ @@demo menubu Menu-buttons
+ @@demo ttkmenu Themed menu buttons
+ @@demo toolbar Themed toolbar
+
+ @@subtitle Common Dialogs
+ @@demo msgbox Message boxes
+ @@demo filebox File selection dialog
+ @@demo clrpick Color picker
+ @@demo fontchoose Font selection dialog
+ @@new
+ @@demo systray System tray icon and notification
+ @@new
+ @@demo print Printing from canvas and text widgets
+
+ @@subtitle Animation
+ @@demo anilabel Animated labels
+ @@demo aniwave Animated wave
+ @@demo pendulum Pendulum simulation
+ @@demo goldberg A celebration of Rube Goldberg
+
+ @@subtitle Miscellaneous
+ @@demo bitmap The built-in bitmaps
+ @@demo dialog1 A dialog box with a local grab
+ @@demo dialog2 A dialog box with a global grab
+ @@new
+ @@demo windowicons Window icons and badges
+}
+
+##############################################################################
+
+.t configure -state disabled
+focus .s
+
+# addSeeDismiss --
+# Add "See Code" and "Dismiss" button frame, with optional "See Vars"
+#
+# Arguments:
+# w - The name of the frame to use.
+
+proc addSeeDismiss {w show {vars {}} {extra {}}} {
+ ## See Code / Dismiss buttons
+ ttk::frame $w
+ #ttk::frame $w.sep -height 2 -relief sunken
+ ttk::separator $w.sep
+ grid $w.sep -columnspan 4 -row 0 -sticky ew -pady 1.5p
+ ttk::button $w.dismiss -text [mc "Dismiss"] \
+ -image ::img::delete -compound left \
+ -command [list destroy [winfo toplevel $w]]
+ ttk::button $w.code -text [mc "See Code"] \
+ -image ::img::view -compound left \
+ -command [list showCode $show]
+ set buttons [list x $w.code $w.dismiss]
+ if {[llength $vars]} {
+ ttk::button $w.vars -text [mc "See Variables"] \
+ -image ::img::view -compound left \
+ -command [concat [list showVars $w.dialog] $vars]
+ set buttons [linsert $buttons 1 $w.vars]
+ }
+ if {$extra ne ""} {
+ set buttons [linsert $buttons 1 [uplevel 1 $extra]]
+ }
+ grid {*}$buttons -padx 3p -pady 3p
+ grid columnconfigure $w 0 -weight 1
+ if {[tk windowingsystem] eq "aqua"} {
+ foreach b [lrange $buttons 1 end] {$b configure -takefocus 0}
+ grid configure $w.sep -pady 0
+ grid configure {*}$buttons -pady {10 12}
+ grid configure [lindex $buttons 1] -padx {16 4}
+ grid configure [lindex $buttons end] -padx {4 18}
+ }
+ return $w
+}
+
+# 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
+ if {[tk windowingsystem] eq "x11"} {wm attributes $w -type dialog}
+ wm title $w [mc "Variable values"]
+
+ set b [ttk::frame $w.frame]
+ grid $b -sticky news
+ set f [ttk::labelframe $b.title -text [mc "Variable values:"]]
+ foreach var $args {
+ ttk::label $f.n$var -text "$var:" -anchor w
+ ttk::label $f.v$var -textvariable $var -anchor w
+ grid $f.n$var $f.v$var -padx 1.5p -pady 1.5p -sticky w
+ }
+ ttk::button $b.ok -text [mc "OK"] \
+ -command [list destroy $w] -default active
+ bind $w <Return> [list $b.ok invoke]
+ bind $w <Escape> [list $b.ok invoke]
+
+ grid $f -sticky news -padx 3p
+ grid $b.ok -sticky e -padx 3p -pady {4.5p 3p}
+ if {[tk windowingsystem] eq "aqua"} {
+ $b.ok configure -takefocus 0
+ grid configure $b.ok -pady {10 12} -padx {16 18}
+ grid configure $f -padx 10 -pady {10 0}
+ }
+ grid columnconfig $f 1 -weight 1
+ grid rowconfigure $f 100 -weight 1
+ grid columnconfig $b 0 -weight 1
+ grid rowconfigure $b 0 -weight 1
+ grid columnconfig $w 0 -weight 1
+ grid rowconfigure $w 0 -weight 1
+}
+
+# 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_demoDirectory
+ set tags [.t tag names $index]
+ set i [lsearch -glob $tags demo-*]
+ if {$i < 0} {
+ return
+ }
+ set cursor [.t cget -cursor]
+ .t configure -cursor [::ttk::cursor busy]
+ update
+ set demo [string range [lindex $tags $i] 5 end]
+ uplevel 1 [list source -encoding utf-8 [file join $tk_demoDirectory $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 {
+ 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 [::ttk::cursor text]
+ } else {
+ set demo [string range [lindex $tags $i] 5 end]
+ .statusBar.lab config -text [mc "Run the \"%s\" sample program" $demo]
+ set newcursor [::ttk::cursor link]
+ }
+ if {$cursor ne $newcursor} {
+ .t config -cursor $newcursor
+ }
+}
+
+# evalShowCode --
+#
+# Arguments:
+# w - Name of text widget containing code to eval
+
+proc evalShowCode {w} {
+ set code [$w get 1.0 end-1c]
+ uplevel #0 $code
+}
+
+# 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_demoDirectory
+ set file [string range $w 1 end].tcl
+ set top .code
+ if {![winfo exists $top]} {
+ toplevel $top
+ if {[tk windowingsystem] eq "x11"} {wm attributes $top -type dialog}
+
+ set t [frame $top.f]
+ set text [text $t.text -font fixedFont -height 24 -wrap word \
+ -xscrollcommand [list $t.xscroll set] \
+ -yscrollcommand [list $t.yscroll set] \
+ -setgrid 1 -highlightthickness 0 -padx 3p -pady 1.5p \
+ -tabstyle wordprocessor]
+ ttk::scrollbar $t.xscroll -command [list $t.text xview] \
+ -orient horizontal
+ ttk::scrollbar $t.yscroll -command [list $t.text yview] \
+ -orient vertical
+
+ grid $t.text $t.yscroll -sticky news
+ #grid $t.xscroll
+ grid rowconfigure $t 0 -weight 1
+ grid columnconfig $t 0 -weight 1
+
+ set btns [ttk::frame $top.btns]
+ ttk::separator $btns.sep
+ grid $btns.sep -columnspan 4 -row 0 -sticky ew -pady 1.5p
+ ttk::button $btns.dismiss -text [mc "Dismiss"] \
+ -default active -command [list destroy $top] \
+ -image ::img::delete -compound left
+ ttk::button $btns.print -text [mc "Print Code"] \
+ -command [list printCode $text $file] \
+ -image ::img::print -compound left
+ ttk::button $btns.rerun -text [mc "Rerun Demo"] \
+ -command [list evalShowCode $text] \
+ -image ::img::refresh -compound left
+ set buttons [list x $btns.rerun $btns.print $btns.dismiss]
+ grid {*}$buttons -padx 3p -pady 3p
+ grid columnconfigure $btns 0 -weight 1
+ if {[tk windowingsystem] eq "aqua"} {
+ foreach b [lrange $buttons 1 end] {$b configure -takefocus 0}
+ grid configure $btns.sep -pady 0
+ grid configure {*}$buttons -pady {10 12}
+ grid configure [lindex $buttons 1] -padx {16 4}
+ grid configure [lindex $buttons end] -padx {4 18}
+ }
+ grid $t -sticky news
+ grid $btns -sticky ew
+ grid rowconfigure $top 0 -weight 1
+ grid columnconfig $top 0 -weight 1
+
+ bind $top <Return> {
+ if {[winfo class %W] ne "Text"} { .code.btns.dismiss invoke }
+ }
+ bind $top <Escape> [bind $top <Return>]
+ } else {
+ wm deiconify $top
+ raise $top
+ }
+ wm title $top [mc "Demo code: %s" [file join $tk_demoDirectory $file]]
+ wm iconname $top $file
+ set id [open [file join $tk_demoDirectory $file]]
+ fconfigure $id -encoding utf-8 -eofchar "\032 {}"
+ $top.f.text delete 1.0 end
+ $top.f.text insert 1.0 [read $id]
+ $top.f.text mark set insert 1.0
+ close $id
+}
+
+# printCode --
+# Prints the source code currently displayed in the See Code dialog. Much
+# thanks to Arjen Markus for this.
+#
+# Arguments:
+# w - Name of text widget containing code to print
+# file - Name of the original file (implicitly for title)
+
+proc printCode {w file} {
+ tk print $w
+}
+
+# tkAboutDialog --
+#
+# Pops up a message box with an "about" message
+#
+proc tkAboutDialog {} {
+ tk_messageBox -icon info -type ok -title [mc "About Widget Demo"] \
+ -message [mc "Tk widget demonstration application"] -detail \
+"[mc "Copyright © %s" {1996-1997 Sun Microsystems, Inc.}]
+[mc "Copyright © %s" {1997-2000 Ajuba Solutions, Inc.}]
+[mc "Copyright © %s" {2001-2009 Donal K. Fellows}]
+[mc "Copyright © %s" {2002-2007 Daniel A. Steffen}]
+[mc "Copyright © %s" {2021 Kevin Walzer}]"
+}
+
+# Local Variables:
+# mode: tcl
+# End:
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/widget
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/windowicons.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/windowicons.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/windowicons.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,108 @@
+# windowicons.tcl --
+#
+# This demonstration script showcases the wm iconphoto and wm iconbadge commands.
+#
+
+if {![info exists widgetDemo]} {
+ error "This script should be run from the \"widget\" demo."
+}
+
+set w .windowicons
+destroy $w
+toplevel $w
+wm title $w "Window Icon Demonstration"
+positionWindow $w
+
+## See Code / Dismiss buttons
+pack [addSeeDismiss $w.buttons $w] -side bottom -fill x
+
+image create photo icon -data {
+ iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAABGdBTUEAALGP
+ C/xhBQAAACBjSFJNAAB6JgAAgIQAAPoAAACA6AAAdTAAAOpgAAA6mAAAF3Cc
+ ulE8AAAABmJLR0QA/wD/AP+gvaeTAAAACXBIWXMAArQNAAK0DQEdFIm+AAAJ
+ QElEQVRYw+WXW2xdV5nHf/ty7lcf2/FxYsdOnMSNC0HTpDiRKJWAQjWCEQNU
+ SEAFfUOiQqrEC2+IxwpemDLSzNBBCCQeQEKqRJgBSikiuGlN22TqhsR27OPL
+ 8eWc43Pdt7X22osHHydOm4FBPM6Slr69paX9/32Xtb614f/7MP6vC3O5f8L3
+ G7HJyZPHBwfz5wrF7HQ6nRwxLTOhQuU4PW+z3eq9Xa+33rq9cms7k8pHjvfS
+ 3w8wOfk52u1u8oHpiUff897JJ8+dO/nI6LHho6OjQ3ahkMYwTTZ2O2zXutS3
+ G/7ayubq7Vtr/7Ve2f7RytLam4ViXq1t/vRvB0ilPsjzz3+LZ5/9j7MzM5Nf
+ /8hj5//5H97/YNbK5hkfTFLMxAEQQvD766v0yBGIEBEEuPUGi9dv7lx77cb3
+ Vm9vfqc0WNi9evUKWr/xLh3rfuLj45+l0bjM7m768U98/OJ/fulLH/3wiemx
+ eCafxRcKw7TJxKC+12RpbYdAx7HsOCrSRNpg+sQQj1w8nS0N5h8JAvm+rWr9
+ 9ZmZB2qWdZq9vWt/GWBm5im+9rUn6HRGPv7EE4/++2P/eOFkV0FkJTDQgCaX
+ TbO1tcV2R2EmCxBJQixs2+R9EwV00MFAceJE2ZiZOT7VaTsPLyxU5orFTK1c
+ fphq9bX7A8zOfoV8Ps3c3NsXPvWpD37vc5//0ETNt8gNjDAzlsdAE0vliTCR
+ xEhnC2CaRIZNMmZiaonv9mh1PcrDJQZzCfK5OGNjQ8e2tvZO37y5+ctk0naq
+ 1fn7A4yOnmd5uVp4/PGHn/vylz8xe+zoEIP5JAMpA0OHeK6DG4TEk2li8Tha
+ QxRpIg0q6DGUNjg6UuLYSInhYoYoigiCgHQ6TrGYnlpd3Q1ffvk3L128+ITe
+ 2Hj1XoBLl55menqcbDb1haeeevyrDz102tJaE7ctLBMqG1X23Ag7kcKOJzAA
+ DSilCVWEZdmMDaXJJCxSiRimaaK1RkqJ7/uUSlk6Hed0oxG9HI9bm+Pjs2xs
+ vIp5AKC15oUX/lA8f/7MF2dnz8YADMNASslypYqrUxSHyqSy+f31hzaRZRpM
+ DKVYr+7y4usVri1WWavWCWSIZZkYhoFSIRcuTI1MTAw9OTf33Tu7zz54SCRi
+ nD17/Pzs7AMPFQqZPlTE8vo2DlmGhgbo12BffD/8SmukitiuNxHKoDwyzPJG
+ nTdXmtiWwdnRNCN5GxWGDA/nOH26/NGpqSfHgPU7AJcuPc0nP/kBrl698YGZ
+ mYmMEIJmx6Hn+my0DUZGC6gIzEOnhu4Lh2GEbRocGyxRSO/7c3QgiRuEVOtd
+ EvEQrSN8IVEq5MSJ4YlSKX3OMKJ14G4KnnnmM9bkZPk92VyKy3M3eentJjd3
+ FUYyjxuEeELt7/NoP+eBVAipCFXEsYE4xcydYFIeSHKynOXhUwM0mh32egH1
+ tsdL16oo007kcskHs7kYly49fRcALqby+fQopklkZ4jHY3g6gQgjHF/QcgQd
+ V+7DHJoGmnzSQuvD0QGlIsJQkU4luLXR4kgxxcRgjM1mQCyZHrv0sUe4JwKF
+ XMmu7/VSXV9xaXqI0YzC8328QOJ4gq4raHQDGt2AtitwfIEbSAwibOvdJ7pS
+ CiElR3IxGh2X5Y0GV66v0wnAsq3MN5759L1FqKMoCkQoX19u0QkkD47lKSYi
+ Th1NoSLYafu0ehrTNNBaE2mNUop2z+DEUJKBbPxecSEIgoAoUjwwmmZpdZPl
+ muL4oIFWkbx8rXIvQMfZ9p2e1xBCstOJcFe6nB1NcWokhW1ZHMkazK90qXXD
+ fZFII0NFIBW/XQiZHraoNbsU81mmjhbxfZ8gCAiCgELKQitJGCoIQ6SQO//2
+ ze/fm4Kf/Px50dzr3Aoch1Ap2o4kn8tgW/sHynAxzcVTBQYzFp4v6boBjidw
+ fcFCpcmPf7/Oz+ZrvPBalb12D9/370DUGk1evr6NacWIfD/yveDmXq3F3Nxz
+ dwH+5dkfUq8155rb9dA2QcqQcjFx57DRGgaySR47d4RHZ0pYeh/C9QSOJ3EE
+ CGWw3fJZ323j+x6e5xH4Pgu3d6g0FMWUjdvu7bo9/5oK1d0IzM09hwhCGrvN
+ ubXFylI2pum4AZXtDqEURFGE1hoNxGMW5ZyB22nS8wQ9r1+QvsDzBc1uQGW7
+ jee6eN4+RMfxMdHkYgatWmtur9ZaOnD8TgQMA27c+uH68s3KT8O9BoYBv3pj
+ kxuVGo7Tw+1/MAh83lreYm1P9r3fT4XjSVxf4voC1/NwHAfXdXFcB891KGVj
+ hO2e16q3fzR2cjQwDPPeZrSx8SqXL2/RqDU2EnH7I8dPjQ8v7Tqs1RwmSzEs
+ QoQQSBHw1lKVha0AEUb4IiQQIb4I8YUkkCHTQwa5WIjne9xY2mT+VouRfI7N
+ xfVfrK8sfTuRSAavXP3Xd7fjavWPRq1+3TeiQTVcGnh0oHwktlZzmBq0SNsR
+ QgiuXLvNL/+nQU/aBFL1xSW+kAghEb5PEkE5q3Bdl7dv72LGCrTXdzf+9Nb8
+ N5dXfrG6Wf1jeNDP3nkjigOFWm2xpvx0+tjI8LnMYMnMxQT5eIjruVye36LS
+ TRAqRSD3vZdCIqUgEj5R4CEDj2O5kMZei3rHoLXV6Sy88cp3Fhf/ew6IAAGE
+ 9wOIARmtw9Tu7vKa1yY+Wiqeee+ZYdsi4HdvrjK/HiKUiZQhoZREQhDJAC18
+ tPSIhEfouwSuQ9cx2VxpNK/PX/n+4uKvXwQdAAHgA/J+AAaQABJRJOydnVsr
+ zZ1O13eMcSuezC61LJzQRgY+KvCJhI+WPpH0IAywIkEhaVIupAhdHS0t3F66
+ Nv/iD9bW/nAFtAM4QA9wAXX3RnEvQBoYODSL+fzEmalTsx+emjl3YWjsaMlM
+ pcwg0ggZEimFoSNsI8JSCtF1wtpmdWt1aeGVSuW133leYwNoA01gr297BzVw
+ v/8CA0gBBaDYtzkw87ns6PhI+czM0JHjp/PFUjmZSmUM07RCKUPP6XVae/Vq
+ fbdys1ZbvOX5ja2+ULcP0Opbt18H/G8Ah+shDWQPzVQ/RSnLTGRsO5U0TMuM
+ VKjC0PUjLd1+fgPAOxTybl9YcvdC9VcBDobV3x0JINm3MfYbmdX/hu57FfZF
+ Dgot6Fe8eqfw3wLwzvVmX9jsvx8AHEAcnn91/BlySEFKTpuCtgAAABN0RVh0
+ QXV0aG9yAHdhcnN6YXdpYW5rYQy+S5cAAABYdEVYdENvcHlyaWdodABDQzAg
+ UHVibGljIERvbWFpbiBEZWRpY2F0aW9uIGh0dHA6Ly9jcmVhdGl2ZWNvbW1v
+ bnMub3JnL3B1YmxpY2RvbWFpbi96ZXJvLzEuMC/G4735AAAAIXRFWHRDcmVh
+ dGlvbiBUaW1lADIwMTAtMDMtMjlUMDg6MDg6MzD47LxwAAAAJXRFWHRkYXRl
+ OmNyZWF0ZQAyMDIxLTA4LTE1VDIwOjU0OjM5LTA0OjAwNBT3DQAAACV0RVh0
+ ZGF0ZTptb2RpZnkAMjAyMS0wOC0xNVQyMDo1NDoxMS0wNDowMDSDBqsAAADI
+ elRYdERlc2NyaXB0aW9uAAAY042OwQqCQBCGn6B3GOy+Cl0qTAjEc1HRJVhW
+ HXUrd2pmLXr7tDrVpcMP838w/F+wxxxyprsgB2ALclAxtRAbaBirRdB4f5mH
+ oTeuJlUxYoly8nRRxHW4HahO30SvmI5Y+CCBF4dPhzg0CYwOLs45GdKfG+sK
+ hBuy2H4xUlM1i76+BhcBwwirLj/bAlJqjXXzP9UyxmuHzp8feiknLPW6Q/H9
+ moy3yK1oqvROUE2yH99suX45PwEyf2MTOoCNrQAAABl0RVh0U29mdHdhcmUA
+ d3d3Lmlua3NjYXBlLm9yZ5vuPBoAAABWdEVYdFNvdXJjZQBodHRwczovL29w
+ ZW5jbGlwYXJ0Lm9yZy9kZXRhaWwvMzUyMzMvdGFuZ28taW5ldHJuZXQtd2Vi
+ LWJyb3dzZXItYnktd2Fyc3phd2lhbmth5nAuRgAAACB0RVh0VGl0bGUAdGF
+ uZ28gaW5ldHJuZXQgd2ViIGJyb3dzZXLyr62TAAAAAElFTkSuQmCC
+}
+
+set ::tk::icons::base_icon(.) icon
+
+# Create a copy of the image just created, magnified according to the
+# display's DPI scaling level. Since the zooom factor must be an integer,
+# the copy will only be effectively magnified if $tk::scalingPct >= 200.
+image create photo icon2
+icon2 copy icon -zoom [expr {$tk::scalingPct / 100}]
+
+pack [button $w.i -text "Set Window Icon to Globe" -image icon2 \
+ -compound top -command {wm iconphoto . icon}] -fill x -padx 3p
+pack [button $w.b -text "Set Badge to 3" -command {wm iconbadge . 3}] \
+ -fill x -padx 3p
+pack [button $w.e -text "Set Badge to 11" -command {wm iconbadge . 11}] \
+ -fill x -padx 3p
+pack [button $w.f -text "Reset Badge" -command {wm iconbadge . ""}] \
+ -fill x -padx 3p
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/demos/windowicons.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/dialog.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/dialog.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/dialog.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,175 @@
+# dialog.tcl --
+#
+# This file defines the procedure tk_dialog, which creates a dialog
+# box containing a bitmap, a message, and one or more buttons.
+#
+# Copyright © 1992-1993 The Regents of the University of California.
+# Copyright © 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} {
+ variable ::tk::Priv
+
+ # Check that $default was properly given
+ if {[string is integer -strict $default]} {
+ if {$default >= [llength $args]} {
+ return -code error -errorcode {TK DIALOG BAD_DEFAULT} \
+ "default button index greater than number of buttons\
+ specified for tk_dialog"
+ }
+ } elseif {"" eq $default} {
+ set default -1
+ } else {
+ set default [lsearch -exact $args $default]
+ }
+
+ set windowingsystem [tk windowingsystem]
+
+ # 1. Create the top-level window and divide it into top
+ # and bottom parts.
+
+ destroy $w
+ toplevel $w -class Dialog
+ wm title $w $title
+ wm iconname $w Dialog
+ wm protocol $w WM_DELETE_WINDOW { }
+
+ # Dialog boxes should be transient with respect to their parent,
+ # so that they will always stay on top of their parent window. However,
+ # some window managers will create the window as withdrawn if the parent
+ # window is withdrawn or iconified. Combined with the grab we put on the
+ # window, this can hang the entire application. Therefore we only make
+ # the dialog transient if the parent is viewable.
+ #
+ if {[winfo viewable [winfo toplevel [winfo parent $w]]] } {
+ wm transient $w [winfo toplevel [winfo parent $w]]
+ }
+
+ if {$windowingsystem eq "aqua"} {
+ ::tk::unsupported::MacWindowStyle style $w moveableModal {}
+ } elseif {$windowingsystem eq "x11"} {
+ wm attributes $w -type dialog
+ }
+
+ frame $w.bot
+ frame $w.top
+ if {$windowingsystem eq "x11"} {
+ $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
+ grid anchor $w.bot center
+
+ # 2. Fill the top part with bitmap and message (use the option
+ # database for -wraplength and -font so that they can be
+ # overridden by the caller).
+
+ option add *Dialog.msg.wrapLength 3i widgetDefault
+ option add *Dialog.msg.font TkCaptionFont widgetDefault
+
+ label $w.msg -justify left -text $text
+ pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m
+ if {$bitmap ne ""} {
+ if {$windowingsystem eq "aqua" && $bitmap eq "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 [list set ::tk::Priv(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 7.5p -pady 3p
+ grid columnconfigure $w.bot $i
+ # We boost the size of some Mac buttons for l&f
+ if {$windowingsystem eq "aqua"} {
+ set tmp [string tolower $but]
+ if {$tmp eq "ok" || $tmp eq "cancel"} {
+ grid columnconfigure $w.bot $i -minsize 90
+ }
+ grid configure $w.button$i -pady 7
+ }
+ incr i
+ }
+
+ # 4. Create a binding for <Return> on the dialog if there is a
+ # default button.
+ # Convention also dictates that if the keyboard focus moves among the
+ # the buttons that the <Return> binding affects the button with the focus.
+
+ if {$default >= 0} {
+ bind $w <Return> [list $w.button$default invoke]
+ }
+ bind $w <<PrevWindow>> [list bind $w <Return> {[tk_focusPrev %W] invoke}]
+ bind $w <<NextWindow>> [list bind $w <Return> {[tk_focusNext %W] invoke}]
+
+ # 5. Create a <Destroy> 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 <Destroy> {set ::tk::Priv(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 (Motif style) and de-iconify it.
+
+ ::tk::PlaceWindow $w
+ tkwait visibility $w
+
+ # 7. Set a grab and claim the focus too.
+
+ if {$default >= 0} {
+ set focus $w.button$default
+ } else {
+ set focus $w
+ }
+ tk::SetFocusGrab $w $focus
+
+ # 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.
+
+ vwait ::tk::Priv(button)
+
+ catch {
+ # It's possible that the window has already been destroyed,
+ # hence this "catch". Delete the Destroy handler so that
+ # Priv(button) doesn't get reset by it.
+
+ bind $w <Destroy> {}
+ }
+ tk::RestoreFocusGrab $w $focus
+ return $Priv(button)
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/dialog.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/entry.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/entry.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/entry.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,720 @@
+# entry.tcl --
+#
+# This file defines the default bindings for Tk entry widgets and provides
+# procedures that help in implementing those bindings.
+#
+# Copyright © 1992-1994 The Regents of the University of California.
+# Copyright © 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 tk::Priv 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.
+# data - Used for Cut and Copy
+#-------------------------------------------------------------------------
+
+#-------------------------------------------------------------------------
+# The code below creates the default class bindings for entries.
+#-------------------------------------------------------------------------
+bind Entry <<Cut>> {
+ if {![catch {tk::EntryGetSelection %W} tk::Priv(data)]} {
+ clipboard clear -displayof %W
+ clipboard append -displayof %W $tk::Priv(data)
+ %W delete sel.first sel.last
+ unset tk::Priv(data)
+ }
+}
+bind Entry <<Copy>> {
+ if {![catch {tk::EntryGetSelection %W} tk::Priv(data)]} {
+ clipboard clear -displayof %W
+ clipboard append -displayof %W $tk::Priv(data)
+ unset tk::Priv(data)
+ }
+}
+bind Entry <<Paste>> {
+ catch {
+ if {[tk windowingsystem] ne "x11"} {
+ catch {
+ %W delete sel.first sel.last
+ }
+ }
+ %W insert insert [::tk::GetSelection %W CLIPBOARD]
+ tk::EntrySeeInsert %W
+ }
+}
+bind Entry <<Clear>> {
+ # ignore if there is no selection
+ catch {%W delete sel.first sel.last}
+}
+bind Entry <<PasteSelection>> {
+ if {$tk_strictMotif || ![info exists tk::Priv(mouseMoved)]
+ || !$tk::Priv(mouseMoved)} {
+ tk::EntryPaste %W %x
+ }
+}
+
+bind Entry <<TraverseIn>> {
+ %W selection range 0 end
+ %W icursor end
+}
+
+# Standard Motif bindings:
+
+bind Entry <Button-1> {
+ tk::EntryButton1 %W %x
+ %W selection clear
+}
+bind Entry <B1-Motion> {
+ set tk::Priv(x) %x
+ tk::EntryMouseSelect %W %x
+}
+bind Entry <Double-Button-1> {
+ set tk::Priv(selectMode) word
+ tk::EntryMouseSelect %W %x
+ catch {%W icursor sel.last}
+}
+bind Entry <Triple-Button-1> {
+ set tk::Priv(selectMode) line
+ tk::EntryMouseSelect %W %x
+ catch {%W icursor sel.last}
+}
+bind Entry <Shift-Button-1> {
+ set tk::Priv(selectMode) char
+ %W selection adjust @%x
+}
+bind Entry <Double-Shift-Button-1> {
+ set tk::Priv(selectMode) word
+ tk::EntryMouseSelect %W %x
+}
+bind Entry <Triple-Shift-Button-1> {
+ set tk::Priv(selectMode) line
+ tk::EntryMouseSelect %W %x
+}
+bind Entry <B1-Leave> {
+ set tk::Priv(x) %x
+ tk::EntryAutoScan %W
+}
+bind Entry <B1-Enter> {
+ tk::CancelRepeat
+}
+bind Entry <ButtonRelease-1> {
+ tk::CancelRepeat
+}
+bind Entry <Control-Button-1> {
+ %W icursor @%x
+}
+
+bind Entry <<PrevChar>> {
+ tk::EntrySetCursor %W [tk::EntryPreviousChar %W insert]
+}
+bind Entry <<NextChar>> {
+ tk::EntrySetCursor %W [tk::EntryNextChar %W insert]
+}
+bind Entry <<SelectPrevChar>> {
+ tk::EntryKeySelect %W [tk::EntryPreviousChar %W insert]
+ tk::EntrySeeInsert %W
+}
+bind Entry <<SelectNextChar>> {
+ tk::EntryKeySelect %W [tk::EntryNextChar %W insert]
+ tk::EntrySeeInsert %W
+}
+bind Entry <<PrevWord>> {
+ tk::EntrySetCursor %W [tk::EntryPreviousWord %W insert]
+}
+bind Entry <<NextWord>> {
+ tk::EntrySetCursor %W [tk::EntryNextWord %W insert]
+}
+bind Entry <<SelectPrevWord>> {
+ tk::EntryKeySelect %W [tk::EntryPreviousWord %W insert]
+ tk::EntrySeeInsert %W
+}
+bind Entry <<SelectNextWord>> {
+ tk::EntryKeySelect %W [tk::EntrySelectNextWord %W insert]
+ tk::EntrySeeInsert %W
+}
+bind Entry <<LineStart>> {
+ tk::EntrySetCursor %W 0
+}
+bind Entry <<SelectLineStart>> {
+ tk::EntryKeySelect %W 0
+ tk::EntrySeeInsert %W
+}
+bind Entry <<LineEnd>> {
+ tk::EntrySetCursor %W end
+}
+bind Entry <<SelectLineEnd>> {
+ tk::EntryKeySelect %W end
+ tk::EntrySeeInsert %W
+}
+
+bind Entry <Delete> {
+ if {[%W selection present]} {
+ %W delete sel.first sel.last
+ } else {
+ %W delete [tk::startOfCluster [%W get] [%W index insert]] \
+ [tk::endOfCluster [%W get] [%W index insert]]
+ }
+}
+bind Entry <BackSpace> {
+ tk::EntryBackspace %W
+}
+
+bind Entry <Control-space> {
+ %W selection from insert
+}
+bind Entry <Select> {
+ %W selection from insert
+}
+bind Entry <Control-Shift-space> {
+ %W selection adjust insert
+}
+bind Entry <Shift-Select> {
+ %W selection adjust insert
+}
+bind Entry <<SelectAll>> {
+ %W selection range 0 end
+}
+bind Entry <<SelectNone>> {
+ %W selection clear
+}
+bind Entry <Key> {
+ tk::CancelRepeat
+ tk::EntryInsert %W %A
+}
+
+# Ignore all Alt, Meta, Control, Command, and Fn keypresses unless explicitly bound.
+# Otherwise, if a widget binding for one of these is defined, the
+# <Key> class binding will also fire and insert the character,
+# which is wrong. Ditto for Escape, Return, and Tab.
+
+bind Entry <Alt-Key> {# nothing}
+bind Entry <Meta-Key> {# nothing}
+bind Entry <Control-Key> {# nothing}
+bind Entry <Escape> {# nothing}
+bind Entry <Return> {# nothing}
+bind Entry <KP_Enter> {# nothing}
+bind Entry <Tab> {# nothing}
+bind Entry <Prior> {# nothing}
+bind Entry <Next> {# nothing}
+bind Entry <Command-Key> {# nothing}
+bind Entry <Fn-Key> {# nothing}
+# Tk-on-Cocoa generates characters for these two keys. [Bug 2971663]
+bind Entry <<NextLine>> {# nothing}
+bind Entry <<PrevLine>> {# nothing}
+
+# On Windows, paste is done using Shift-Insert. Shift-Insert already
+# generates the <<Paste>> event, so we don't need to do anything here.
+if {[tk windowingsystem] ne "win32"} {
+ bind Entry <Insert> {
+ catch {tk::EntryInsert %W [::tk::GetSelection %W PRIMARY]}
+ }
+}
+
+# Additional emacs-like bindings:
+
+bind Entry <Control-d> {
+ if {!$tk_strictMotif} {
+ %W delete insert
+ }
+}
+bind Entry <Control-h> {
+ if {!$tk_strictMotif} {
+ tk::EntryBackspace %W
+ }
+}
+bind Entry <Control-k> {
+ if {!$tk_strictMotif} {
+ %W delete insert end
+ }
+}
+bind Entry <Control-t> {
+ if {!$tk_strictMotif} {
+ tk::EntryTranspose %W
+ }
+}
+bind Entry <Meta-b> {
+ if {!$tk_strictMotif} {
+ tk::EntrySetCursor %W [tk::EntryPreviousWord %W insert]
+ }
+}
+bind Entry <Meta-d> {
+ if {!$tk_strictMotif} {
+ %W delete insert [tk::EntryNextWord %W insert]
+ }
+}
+bind Entry <Meta-f> {
+ if {!$tk_strictMotif} {
+ tk::EntrySetCursor %W [tk::EntryNextWord %W insert]
+ }
+}
+bind Entry <Meta-BackSpace> {
+ if {!$tk_strictMotif} {
+ %W delete [tk::EntryPreviousWord %W insert] insert
+ }
+}
+bind Entry <Meta-Delete> {
+ if {!$tk_strictMotif} {
+ %W delete [tk::EntryPreviousWord %W insert] insert
+ }
+}
+
+# Bindings for IME text input and accents.
+
+bind Entry <<TkStartIMEMarkedText>> {
+ dict set ::tk::Priv(IMETextMark) "%W" [%W index insert]
+}
+bind Entry <<TkEndIMEMarkedText>> {
+ ::tk::EntryEndIMEMarkedText %W
+}
+bind Entry <<TkClearIMEMarkedText>> {
+ %W delete [dict get $::tk::Priv(IMETextMark) "%W"] [%W index insert]
+}
+bind Entry <<TkAccentBackspace>> {
+ tk::EntryBackspace %W
+}
+
+# ::tk::EntryEndIMEMarkedText --
+# Handles input method text marking in an entry
+#
+# Arguments:
+# w - The entry window.
+
+proc ::tk::EntryEndIMEMarkedText {w} {
+ variable Priv
+ if {[catch {
+ set mark [dict get $Priv(IMETextMark) $w]
+ }]} {
+ bell
+ return
+ }
+ $w selection range $mark insert
+}
+
+# A few additional bindings of my own.
+
+bind Entry <Button-2> {
+ if {!$tk_strictMotif} {
+ ::tk::EntryScanMark %W %x
+ }
+}
+bind Entry <B2-Motion> {
+ if {!$tk_strictMotif} {
+ ::tk::EntryScanDrag %W %x
+ }
+}
+
+# ::tk::EntryClosestGap --
+# Given x and y coordinates, this procedure finds the closest boundary
+# between characters to the given coordinates and returns the index
+# of the character just after the boundary.
+#
+# Arguments:
+# w - The entry window.
+# x - X-coordinate within the window.
+
+proc ::tk::EntryClosestGap {w x} {
+ set pos [$w index @$x]
+ set bbox [$w bbox $pos]
+ if {($x - [lindex $bbox 0]) < ([lindex $bbox 2]/2)} {
+ return $pos
+ }
+ incr pos
+}
+
+# ::tk::EntryButton1 --
+# This procedure is invoked to handle button-1 presses in entry
+# widgets. It moves the insertion cursor, sets the selection anchor,
+# and claims the input focus.
+#
+# Arguments:
+# w - The entry window in which the button was pressed.
+# x - The x-coordinate of the button press.
+
+proc ::tk::EntryButton1 {w x} {
+ variable ::tk::Priv
+
+ set Priv(selectMode) char
+ set Priv(mouseMoved) 0
+ set Priv(pressX) $x
+ $w icursor [EntryClosestGap $w $x]
+ $w selection from insert
+ if {"disabled" ne [$w cget -state]} {
+ focus $w
+ }
+}
+
+# ::tk::EntryMouseSelect --
+# This procedure is invoked when dragging out a selection with
+# the mouse. Depending on the selection mode (character, word,
+# line) it selects in different-sized units. This procedure
+# ignores mouse motions initially until the mouse has moved from
+# one character to another or until there have been multiple clicks.
+#
+# Arguments:
+# w - The entry window in which the button was pressed.
+# x - The x-coordinate of the mouse.
+
+proc ::tk::EntryMouseSelect {w x} {
+ variable ::tk::Priv
+
+ set cur [EntryClosestGap $w $x]
+ set anchor [$w index anchor]
+ if {($cur != $anchor) || (abs($Priv(pressX) - $x) >= 3)} {
+ set Priv(mouseMoved) 1
+ }
+ switch $Priv(selectMode) {
+ char {
+ if {$Priv(mouseMoved)} {
+ if {$cur < $anchor} {
+ $w selection range $cur $anchor
+ } elseif {$cur > $anchor} {
+ $w selection range $anchor $cur
+ } else {
+ $w selection clear
+ }
+ }
+ }
+ word {
+ if {$cur < $anchor} {
+ set before [tk::wordBreakBefore [$w get] $cur]
+ set after [tk::wordBreakAfter [$w get] $anchor-1]
+ } elseif {$cur > $anchor} {
+ set before [tk::wordBreakBefore [$w get] $anchor]
+ set after [tk::wordBreakAfter [$w get] $cur-1]
+ } else {
+ if {[$w index @$Priv(pressX)] < $anchor} {
+ incr anchor -1
+ }
+ set before [tk::wordBreakBefore [$w get] $anchor]
+ set after [tk::wordBreakAfter [$w get] $anchor]
+ }
+ if {$before < 0} {
+ set before 0
+ }
+ if {$after < 0} {
+ set after end
+ }
+ $w selection range $before $after
+ }
+ line {
+ $w selection range 0 end
+ }
+ }
+ if {$Priv(mouseMoved)} {
+ $w icursor $cur
+ }
+ update idletasks
+}
+
+# ::tk::EntryPaste --
+# This procedure sets the insertion cursor to the current mouse position,
+# pastes the selection there, and sets the focus to the window.
+#
+# Arguments:
+# w - The entry window.
+# x - X position of the mouse.
+
+proc ::tk::EntryPaste {w x} {
+ $w icursor [EntryClosestGap $w $x]
+ catch {$w insert insert [::tk::GetSelection $w PRIMARY]}
+ if {"disabled" ne [$w cget -state]} {
+ focus $w
+ }
+}
+
+# ::tk::EntryAutoScan --
+# This procedure is invoked when the mouse leaves an entry window
+# with button 1 down. It scrolls the window left or right,
+# depending on where the mouse is, 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 ::tk::EntryAutoScan {w} {
+ variable ::tk::Priv
+ set x $Priv(x)
+ if {![winfo exists $w]} {
+ return
+ }
+ if {$x >= [winfo width $w]} {
+ $w xview scroll 2 units
+ EntryMouseSelect $w $x
+ } elseif {$x < 0} {
+ $w xview scroll -2 units
+ EntryMouseSelect $w $x
+ }
+ set Priv(afterId) [after 50 [list tk::EntryAutoScan $w]]
+}
+
+# ::tk::EntryKeySelect --
+# This procedure is invoked when stroking out selections using the
+# keyboard. It moves the cursor to a new position, then extends
+# the selection to that position.
+#
+# Arguments:
+# w - The entry window.
+# new - A new position for the insertion cursor (the cursor hasn't
+# actually been moved to this position yet).
+
+proc ::tk::EntryKeySelect {w new} {
+ if {![$w selection present]} {
+ $w selection from insert
+ $w selection to $new
+ } else {
+ $w selection adjust $new
+ }
+ $w icursor $new
+}
+
+# ::tk::EntryInsert --
+# Insert a string into an entry at the point of the insertion cursor.
+# If there is a selection in the entry, and it covers the point of the
+# insertion cursor, then delete the selection before inserting.
+#
+# Arguments:
+# w - The entry window in which to insert the string
+# s - The string to insert (usually just a single character)
+
+proc ::tk::EntryInsert {w s} {
+ if {$s eq ""} {
+ return
+ }
+ catch {
+ set insert [$w index insert]
+ if {([$w index sel.first] <= $insert)
+ && ([$w index sel.last] >= $insert)} {
+ $w delete sel.first sel.last
+ }
+ }
+ $w insert insert $s
+ EntrySeeInsert $w
+}
+
+# ::tk::EntryBackspace --
+# Backspace over the character just before the insertion cursor.
+# If backspacing would move the cursor off the left edge of the
+# window, reposition the cursor at about the middle of the window.
+#
+# Arguments:
+# w - The entry window in which to backspace.
+
+proc ::tk::EntryBackspace w {
+ if {[$w selection present]} {
+ $w delete sel.first sel.last
+ } else {
+ set x [expr {[$w index insert] - 1}]
+ if {$x >= 0} {
+ $w delete [tk::startOfCluster [$w get] $x] \
+ [tk::endOfCluster [$w get] $x]
+ }
+ if {[$w index @0] >= [$w index insert]} {
+ set range [$w xview]
+ set left [lindex $range 0]
+ set right [lindex $range 1]
+ $w xview moveto [expr {$left - ($right - $left)/2.0}]
+ }
+ }
+}
+
+# ::tk::EntrySeeInsert --
+# Make sure that the insertion cursor is visible in the entry window.
+# If not, adjust the view so that it is.
+#
+# Arguments:
+# w - The entry window.
+
+proc ::tk::EntrySeeInsert w {
+ set c [$w index insert]
+ if {($c < [$w index @0]) || ($c > [$w index @[winfo width $w]])} {
+ $w xview $c
+ }
+}
+
+# ::tk::EntrySetCursor -
+# Move the insertion cursor to a given position in an entry. Also
+# clears the selection, if there is one in the entry, and makes sure
+# that the insertion cursor is visible.
+#
+# Arguments:
+# w - The entry window.
+# pos - The desired new position for the cursor in the window.
+
+proc ::tk::EntrySetCursor {w pos} {
+ $w icursor $pos
+ $w selection clear
+ EntrySeeInsert $w
+}
+
+# ::tk::EntryTranspose -
+# This procedure implements the "transpose" function for entry widgets.
+# It tranposes the characters on either side of the insertion cursor,
+# unless the cursor is at the end of the line. In this case it
+# transposes the two characters to the left of the cursor. In either
+# case, the cursor ends up to the right of the transposed characters.
+#
+# Arguments:
+# w - The entry window.
+
+proc ::tk::EntryTranspose w {
+ set i [$w index insert]
+ if {$i < [$w index end]} {
+ incr i
+ }
+ if {$i < 2} {
+ return
+ }
+ set first $i-2
+ set data [$w get]
+ set new [string index $data $i-1][string index $data $first]
+ $w delete $first $i
+ $w insert insert $new
+ EntrySeeInsert $w
+}
+
+# ::tk::EntryNextWord --
+# Returns the index of the next start-of-word position after the next
+# end-of-word position after a given position in the text.
+#
+# Arguments:
+# w - The entry window in which the cursor is to move.
+# start - Position at which to start search.
+
+proc ::tk::EntryNextWord {w start} {
+ # the check on [winfo class] is because the spinbox also uses this proc
+ if {[winfo class $w] eq "Entry" && [$w cget -show] ne ""} {
+ return end
+ }
+ set pos [tk::endOfWord [$w get] [$w index $start]]
+ if {$pos >= 0} {
+ set pos [tk::startOfNextWord [$w get] $pos]
+ }
+ if {$pos < 0} {
+ return end
+ }
+ return $pos
+}
+
+# ::tk::EntrySelectNextWord --
+# Returns the index of the next end-of-word position after a given
+# position in the text.
+#
+# Arguments:
+# w - The entry window in which the cursor is to move.
+# start - Position at which to start search.
+
+proc ::tk::EntrySelectNextWord {w start} {
+ # the check on [winfo class] is because the spinbox also uses this proc
+ if {[winfo class $w] eq "Entry" && [$w cget -show] ne ""} {
+ return end
+ }
+ set pos [tk::endOfWord [$w get] [$w index $start]]
+ if {$pos < 0} {
+ return end
+ }
+ return $pos
+}
+
+# ::tk::EntryPreviousWord --
+#
+# Returns the index of the previous word position before a given
+# position in the entry.
+#
+# Arguments:
+# w - The entry window in which the cursor is to move.
+# start - Position at which to start search.
+
+proc ::tk::EntryPreviousWord {w start} {
+ # the check on [winfo class] is because the spinbox also uses this proc
+ if {[winfo class $w] eq "Entry" && [$w cget -show] ne ""} {
+ return 0
+ }
+ set pos [tk::startOfPreviousWord [$w get] [$w index $start]]
+ if {$pos < 0} {
+ return 0
+ }
+ return $pos
+}
+
+proc ::tk::EntryNextChar {w start} {
+ set pos [tk::endOfCluster [$w get] [$w index $start]]
+ if {$pos < 0} {
+ return end
+ }
+ return $pos
+}
+
+proc ::tk::EntryPreviousChar {w start} {
+ set pos [tk::startOfCluster [$w get] [expr {[$w index $start]-1}]]
+ if {$pos < 0} {
+ return 0
+ }
+ return $pos
+}
+
+
+# ::tk::EntryScanMark --
+#
+# Marks the start of a possible scan drag operation
+#
+# Arguments:
+# w - The entry window from which the text to get
+# x - x location on screen
+
+proc ::tk::EntryScanMark {w x} {
+ $w scan mark $x
+ set ::tk::Priv(x) $x
+ set ::tk::Priv(y) 0 ; # not used
+ set ::tk::Priv(mouseMoved) 0
+}
+
+# ::tk::EntryScanDrag --
+#
+# Marks the start of a possible scan drag operation
+#
+# Arguments:
+# w - The entry window from which the text to get
+# x - x location on screen
+
+proc ::tk::EntryScanDrag {w x} {
+ # Make sure these exist, as some weird situations can trigger the
+ # motion binding without the initial press. [Bug #220269]
+ if {![info exists ::tk::Priv(x)]} {set ::tk::Priv(x) $x}
+ # allow for a delta
+ if {abs($x-$::tk::Priv(x)) > 2} {
+ set ::tk::Priv(mouseMoved) 1
+ }
+ $w scan dragto $x
+}
+
+# ::tk::EntryGetSelection --
+#
+# Returns the selected text of the entry with respect to the -show option.
+#
+# Arguments:
+# w - The entry window from which the text to get
+
+proc ::tk::EntryGetSelection {w} {
+ set entryString [string range [$w get] [$w index sel.first] \
+ [$w index sel.last]-1]
+ if {[$w cget -show] ne ""} {
+ return [string repeat [string index [$w cget -show] 0] \
+ [string length $entryString]]
+ }
+ return $entryString
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/entry.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/focus.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/focus.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/focus.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,178 @@
+# focus.tcl --
+#
+# This file defines several procedures for managing the input
+# focus.
+#
+# Copyright © 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.
+#
+
+# ::tk_focusNext --
+# This procedure returns the name of the next window after "w" in
+# "focus order" (the window that should receive the focus next if
+# Tab is typed in w). "Next" is defined by a pre-order search
+# of a top-level and its non-top-level descendants, with the stacking
+# order determining the order of siblings. The "-takefocus" options
+# on windows determine whether or not they should be skipped.
+#
+# Arguments:
+# w - Name of a window.
+
+proc ::tk_focusNext w {
+ set cur $w
+ while {1} {
+
+ # Descend to just before the first child of the current widget.
+
+ set parent $cur
+ set children [winfo children $cur]
+ set i -1
+
+ # Look for the next sibling that isn't a top-level.
+
+ while {1} {
+ incr i
+ if {$i < [llength $children]} {
+ set cur [lindex $children $i]
+ if {[winfo toplevel $cur] eq $cur} {
+ continue
+ } else {
+ break
+ }
+ }
+
+ # No more siblings, so go to the current widget's parent.
+ # If it's a top-level, break out of the loop, otherwise
+ # look for its next sibling.
+
+ set cur $parent
+ if {[winfo toplevel $cur] eq $cur} {
+ break
+ }
+ set parent [winfo parent $parent]
+ set children [winfo children $parent]
+ set i [lsearch -exact $children $cur]
+ }
+ if {$w eq $cur || [tk::FocusOK $cur]} {
+ return $cur
+ }
+ }
+}
+
+# ::tk_focusPrev --
+# This procedure returns the name of the previous window before "w" in
+# "focus order" (the window that should receive the focus next if
+# Shift-Tab is typed in w). "Next" is defined by a pre-order search
+# of a top-level and its non-top-level descendants, with the stacking
+# order determining the order of siblings. The "-takefocus" options
+# on windows determine whether or not they should be skipped.
+#
+# Arguments:
+# w - Name of a window.
+
+proc ::tk_focusPrev w {
+ set cur $w
+ while {1} {
+
+ # Collect information about the current window's position
+ # among its siblings. Also, if the window is a top-level,
+ # then reposition to just after the last child of the window.
+
+ if {[winfo toplevel $cur] eq $cur} {
+ set parent $cur
+ set children [winfo children $cur]
+ set i [llength $children]
+ } else {
+ set parent [winfo parent $cur]
+ set children [winfo children $parent]
+ set i [lsearch -exact $children $cur]
+ }
+
+ # Go to the previous sibling, then descend to its last descendant
+ # (highest in stacking order. While doing this, ignore top-levels
+ # and their descendants. When we run out of descendants, go up
+ # one level to the parent.
+
+ while {$i > 0} {
+ incr i -1
+ set cur [lindex $children $i]
+ if {[winfo toplevel $cur] eq $cur} {
+ continue
+ }
+ set parent $cur
+ set children [winfo children $parent]
+ set i [llength $children]
+ }
+ set cur $parent
+ if {$w eq $cur || [tk::FocusOK $cur]} {
+ return $cur
+ }
+ }
+}
+
+# ::tk::FocusOK --
+#
+# This procedure is invoked to decide whether or not to focus on
+# a given window. It returns 1 if it's OK to focus on the window,
+# 0 if it's not OK. The code first checks whether the window is
+# viewable. If not, then it never focuses on the window. Then it
+# checks the -takefocus option for the window and uses it if it's
+# set. If there's no -takefocus option, the procedure checks to
+# see if (a) the widget isn't disabled, and (b) it has some key
+# bindings. If all of these are true, then 1 is returned.
+#
+# Arguments:
+# w - Name of a window.
+
+proc ::tk::FocusOK w {
+ set code [catch {$w cget -takefocus} value]
+ if {($code == 0) && ($value ne "")} {
+ if {$value == 0} {
+ return 0
+ } elseif {$value == 1} {
+ return [winfo viewable $w]
+ } else {
+ set value [uplevel #0 $value [list $w]]
+ if {$value ne ""} {
+ return $value
+ }
+ }
+ }
+ if {![winfo viewable $w]} {
+ return 0
+ }
+ set code [catch {$w cget -state} value]
+ if {($code == 0) && $value eq "disabled"} {
+ return 0
+ }
+ regexp Key|Focus "[bind $w] [bind [winfo class $w]]"
+}
+
+# ::tk_focusFollowsMouse --
+#
+# If this procedure is invoked, Tk will enter "focus-follows-mouse"
+# mode, where the focus is always on whatever window contains the
+# mouse. If this procedure isn't invoked, then the user typically
+# has to click on a window to give it the focus.
+#
+# Arguments:
+# None.
+
+proc ::tk_focusFollowsMouse {} {
+ set old [bind all <Enter>]
+ set script {
+ if {"%d" eq "NotifyAncestor" || "%d" eq "NotifyNonlinear" \
+ || "%d" eq "NotifyInferior"} {
+ if {[tk::FocusOK %W]} {
+ focus %W
+ }
+ }
+ }
+ if {$old ne ""} {
+ bind all <Enter> "$old; $script"
+ } else {
+ bind all <Enter> $script
+ }
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/focus.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/fontchooser.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/fontchooser.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/fontchooser.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,512 @@
+# fontchooser.tcl -
+#
+# A themeable Tk font selection dialog. See TIP #324.
+#
+# Copyright © 2008 Keith Vetter
+# Copyright © 2008 Pat Thoyts <patthoyts at users.sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+namespace eval ::tk::fontchooser {
+ variable S
+
+ set S(W) .__tk__fontchooser
+ set S(fonts) [lsort -dictionary -unique [font families]]
+ set S(styles) [list \
+ [::msgcat::mc Regular] \
+ [::msgcat::mc Italic] \
+ [::msgcat::mc Bold] \
+ [::msgcat::mc {Bold Italic}] \
+ ]
+ set S(sizes) {8 9 10 11 12 14 16 18 20 22 24 26 28 36 48 72}
+ set S(strike) 0
+ set S(under) 0
+ set S(first) 1
+ set S(-parent) .
+ set S(-title) {}
+ set S(-command) ""
+ set S(-font) TkDefaultFont
+ set S(bad) [list ]
+}
+
+proc ::tk::fontchooser::Canonical {} {
+ variable S
+
+ foreach style $S(styles) {
+ lappend S(styles,lcase) [string tolower $style]
+ }
+ set S(sizes,lcase) $S(sizes)
+ set S(sampletext) [::msgcat::mc "AaBbYyZz01"]
+
+ # Canonical versions of font families, styles, etc. for easier searching
+ set S(fonts,lcase) {}
+ foreach font $S(fonts) {
+ lappend S(fonts,lcase) [string tolower $font]
+ }
+ set S(styles,lcase) {}
+ foreach style $S(styles) {
+ lappend S(styles,lcase) [string tolower $style]
+ }
+}
+
+proc ::tk::fontchooser::Setup {} {
+ variable S
+
+ Canonical
+
+ ::ttk::style layout FontchooserFrame {
+ Entry.field -sticky news -border true -children {
+ FontchooserFrame.padding -sticky news
+ }
+ }
+ bind [winfo class .] <<ThemeChanged>> \
+ [list +ttk::style layout FontchooserFrame \
+ [ttk::style layout FontchooserFrame]]
+
+ namespace ensemble create -map {
+ show ::tk::fontchooser::Show
+ hide ::tk::fontchooser::Hide
+ configure ::tk::fontchooser::Configure
+ }
+}
+::tk::fontchooser::Setup
+
+proc ::tk::fontchooser::Show {} {
+ variable S
+
+ Canonical
+
+ if {![winfo exists $S(W)]} {
+ Create
+ wm transient $S(W) [winfo toplevel $S(-parent)]
+ tk::PlaceWindow $S(W) widget $S(-parent)
+ if {[string trim $S(-title)] eq ""} {
+ wm title $S(W) [::msgcat::mc "Font"]
+ } else {
+ wm title $S(W) $S(-title)
+ }
+ }
+ set S(fonts) [lsort -dictionary -unique [font families]]
+ set S(fonts,lcase) {}
+ foreach font $S(fonts) {
+ lappend S(fonts,lcase) [string tolower $font]
+ }
+ wm deiconify $S(W)
+}
+
+proc ::tk::fontchooser::Hide {} {
+ variable S
+ wm withdraw $S(W)
+}
+
+proc ::tk::fontchooser::Configure {args} {
+ variable S
+
+ set specs {
+ {-parent "" "" . }
+ {-title "" "" ""}
+ {-font "" "" ""}
+ {-command "" "" ""}
+ }
+
+ if {[llength $args] == 0} {
+ set result {}
+ foreach spec $specs {
+ foreach {name xx yy default} $spec break
+ lappend result $name \
+ [expr {[info exists S($name)] ? $S($name) : $default}]
+ }
+ lappend result -visible \
+ [expr {[winfo exists $S(W)] && [winfo ismapped $S(W)]}]
+ return $result
+ }
+ if {[llength $args] == 1} {
+ set option [lindex $args 0]
+ if {[string equal $option "-visible"]} {
+ return [expr {[winfo exists $S(W)] && [winfo ismapped $S(W)]}]
+ } elseif {[info exists S($option)]} {
+ return $S($option)
+ }
+ return -code error -errorcode [list TK LOOKUP OPTION $option] \
+ "bad option \"$option\": must be\
+ -command, -font, -parent, -title or -visible"
+ }
+ set cache [dict create -parent $S(-parent) -title $S(-title) \
+ -font $S(-font) -command $S(-command)]
+ set r [tclParseConfigSpec [namespace which -variable S] $specs DONTSETDEFAULTS $args]
+ if {![winfo exists $S(-parent)]} {
+ set code [list TK LOOKUP WINDOW $S(-parent)]
+ set err "bad window path name \"$S(-parent)\""
+ array set S $cache
+ return -code error -errorcode $code $err
+ }
+
+ if {[winfo exists $S(W)]} {
+ if {{-font} in $args} {
+ Init $S(-font)
+ event generate $S(-parent) <<TkFontchooserFontChanged>>
+ }
+
+ if {[string trim $S(-title)] eq {}} {
+ wm title $S(W) [::msgcat::mc Font]
+ } else {
+ wm title $S(W) $S(-title)
+ }
+ $S(W).ok configure -state $S(nstate)
+ $S(W).apply configure -state $S(nstate)
+ }
+ return $r
+}
+
+proc ::tk::fontchooser::Create {} {
+ variable S
+ set windowName __tk__fontchooser
+ if {$S(-parent) eq "."} {
+ set S(W) .$windowName
+ } else {
+ set S(W) $S(-parent).$windowName
+ }
+
+ # Now build the dialog
+ if {![winfo exists $S(W)]} {
+ toplevel $S(W) -class TkFontDialog
+ if {[package provide tcltest] ne {}} {
+ set ::tk_dialog $S(W)
+ }
+ wm withdraw $S(W)
+ wm title $S(W) $S(-title)
+ wm transient $S(W) [winfo toplevel $S(-parent)]
+
+ set outer [::ttk::frame $S(W).outer -padding {7.5p 7.5p}]
+ ::tk::AmpWidget ::ttk::label $S(W).font -text [::msgcat::mc "&Font:"]
+ ::tk::AmpWidget ::ttk::label $S(W).style -text [::msgcat::mc "Font st&yle:"]
+ ::tk::AmpWidget ::ttk::label $S(W).size -text [::msgcat::mc "&Size:"]
+ ttk::entry $S(W).efont -width 18 \
+ -textvariable [namespace which -variable S](font)
+ ttk::entry $S(W).estyle -width 10 \
+ -textvariable [namespace which -variable S](style)
+ ttk::entry $S(W).esize -textvariable [namespace which -variable S](size) \
+ -width 3 -validate key -validatecommand {regexp -- {^-*[0-9]*$} %P}
+
+ ttk_slistbox $S(W).lfonts -height 7 -exportselection 0 \
+ -selectmode browse -activestyle none \
+ -listvariable [namespace which -variable S](fonts)
+ ttk_slistbox $S(W).lstyles -width 5 -height 7 -exportselection 0 \
+ -selectmode browse -activestyle none \
+ -listvariable [namespace which -variable S](styles)
+ ttk_slistbox $S(W).lsizes -width 4 -height 7 -exportselection 0 \
+ -selectmode browse -activestyle none \
+ -listvariable [namespace which -variable S](sizes)
+
+ set WE $S(W).effects
+ ::ttk::labelframe $WE -text [::msgcat::mc "Effects"]
+ ::tk::AmpWidget ::ttk::checkbutton $WE.strike \
+ -variable [namespace which -variable S](strike) \
+ -text [::msgcat::mc "Stri&keout"] \
+ -command [namespace code [list Click strike]]
+ ::tk::AmpWidget ::ttk::checkbutton $WE.under \
+ -variable [namespace which -variable S](under) \
+ -text [::msgcat::mc "&Underline"] \
+ -command [namespace code [list Click under]]
+
+ set bbox [::ttk::frame $S(W).bbox]
+ ::ttk::button $S(W).ok -text [::msgcat::mc OK] -default active\
+ -command [namespace code [list Done 1]]
+ ::ttk::button $S(W).cancel -text [::msgcat::mc Cancel] \
+ -command [namespace code [list Done 0]]
+ ::tk::AmpWidget ::ttk::button $S(W).apply -text [::msgcat::mc "&Apply"] \
+ -command [namespace code [list Apply]]
+ wm protocol $S(W) WM_DELETE_WINDOW [namespace code [list Done 0]]
+
+ # Calculate minimum sizes
+ ttk::scrollbar $S(W).tmpvs
+ set scroll_width [winfo reqwidth $S(W).tmpvs]
+ destroy $S(W).tmpvs
+ set minsize(gap) [::tk::ScaleNum 10]
+ set minsize(bbox) [winfo reqwidth $S(W).ok]
+ set minsize(fonts) \
+ [expr {[font measure TkDefaultFont "Helvetica"] + $scroll_width}]
+ set minsize(styles) \
+ [expr {[font measure TkDefaultFont "Bold Italic"] + $scroll_width}]
+ set minsize(sizes) \
+ [expr {[font measure TkDefaultFont "-99"] + $scroll_width}]
+ set min [expr {$minsize(gap) * 4}]
+ foreach {what width} [array get minsize] {
+ incr min $width
+ }
+ wm minsize $S(W) $min [::tk::ScaleNum 260]
+
+ bind $S(W) <Return> [namespace code [list Done 1]]
+ bind $S(W) <Escape> [namespace code [list Done 0]]
+ bind $S(W) <Map> [namespace code [list Visibility %W 1]]
+ bind $S(W) <Unmap> [namespace code [list Visibility %W 0]]
+ bind $S(W) <Destroy> [namespace code [list Visibility %W 0]]
+ bind $S(W).lfonts.list <<ListboxSelect>> [namespace code [list Click font]]
+ bind $S(W).lstyles.list <<ListboxSelect>> [namespace code [list Click style]]
+ bind $S(W).lsizes.list <<ListboxSelect>> [namespace code [list Click size]]
+ bind $S(W) <Alt-Key> [list ::tk::AltKeyInDialog $S(W) %A]
+ bind $S(W).font <<AltUnderlined>> [list ::focus $S(W).efont]
+ bind $S(W).style <<AltUnderlined>> [list ::focus $S(W).estyle]
+ bind $S(W).size <<AltUnderlined>> [list ::focus $S(W).esize]
+ bind $S(W).apply <<AltUnderlined>> [namespace code [list Apply]]
+ bind $WE.strike <<AltUnderlined>> [list $WE.strike invoke]
+ bind $WE.under <<AltUnderlined>> [list $WE.under invoke]
+
+ set WS $S(W).sample
+ ::ttk::labelframe $WS -text [::msgcat::mc "Sample"]
+ ::ttk::label $WS.sample -relief sunken -anchor center \
+ -textvariable [namespace which -variable S](sampletext)
+ set S(sample) $WS.sample
+ grid $WS.sample -sticky news -padx 4.5p -pady 3p
+ grid rowconfigure $WS 0 -weight 1
+ grid columnconfigure $WS 0 -weight 1
+ grid propagate $WS 0
+
+ grid $S(W).ok -in $bbox -sticky new -pady {0 1.5p}
+ grid $S(W).cancel -in $bbox -sticky new -pady 1.5p
+ grid $S(W).apply -in $bbox -sticky new -pady 1.5p
+ grid columnconfigure $bbox 0 -weight 1
+
+ grid $WE.strike -sticky w -padx 7.5p
+ grid $WE.under -sticky w -padx 7.5p -pady {0 22.5p}
+ grid columnconfigure $WE 1 -weight 1
+
+ grid $S(W).font x $S(W).style x $S(W).size x -in $outer -sticky w
+ grid $S(W).efont x $S(W).estyle x $S(W).esize x $bbox -in $outer -sticky ew
+ grid $S(W).lfonts x $S(W).lstyles x $S(W).lsizes x ^ -in $outer -sticky news
+ grid $WE x $WS - - x ^ -in $outer -sticky news -pady {11p 22.5p}
+ grid configure $bbox -sticky n
+ grid rowconfigure $outer 2 -weight 1
+ grid columnconfigure $outer {1 3 5} -minsize $minsize(gap)
+ grid columnconfigure $outer {0 2 4} -weight 1
+ grid columnconfigure $outer 0 -minsize $minsize(fonts)
+ grid columnconfigure $outer 2 -minsize $minsize(styles)
+ grid columnconfigure $outer 4 -minsize $minsize(sizes)
+ grid columnconfigure $outer 6 -minsize $minsize(bbox)
+
+ grid $outer -sticky news
+ grid rowconfigure $S(W) 0 -weight 1
+ grid columnconfigure $S(W) 0 -weight 1
+
+ Init $S(-font)
+
+ trace add variable [namespace which -variable S](size) \
+ write [namespace code [list Tracer]]
+ trace add variable [namespace which -variable S](style) \
+ write [namespace code [list Tracer]]
+ trace add variable [namespace which -variable S](font) \
+ write [namespace code [list Tracer]]
+ trace add variable [namespace which -variable S](strike) \
+ write [namespace code [list Tracer]]
+ trace add variable [namespace which -variable S](under) \
+ write [namespace code [list Tracer]]
+ }
+
+ Init $S(-font)
+
+ return
+}
+
+# ::tk::fontchooser::Done --
+#
+# Handles teardown of the dialog, calling -command if needed
+#
+# Arguments:
+# ok true if user pressed OK
+#
+proc ::tk::fontchooser::Done {ok} {
+ variable S
+
+ if {! $ok} {
+ set S(result) ""
+ }
+ trace remove variable S(size) write [namespace code [list Tracer]]
+ trace remove variable S(style) write [namespace code [list Tracer]]
+ trace remove variable S(font) write [namespace code [list Tracer]]
+ trace remove variable S(strike) write [namespace code [list Tracer]]
+ trace remove variable S(under) write [namespace code [list Tracer]]
+ destroy $S(W)
+ if {$ok} {
+ if {$S(-command) ne ""} {
+ uplevel #0 $S(-command) [list $S(result)]
+ }
+ event generate $S(-parent) <<TkFontchooserFontChanged>>
+ }
+}
+
+# ::tk::fontchooser::Apply --
+#
+# Call the -command procedure appending the current font
+# Errors are reported via the background error mechanism
+#
+proc ::tk::fontchooser::Apply {} {
+ variable S
+ if {$S(-command) ne ""} {
+ if {[catch {uplevel #0 $S(-command) [list $S(result)]} err]} {
+ ::bgerror $err
+ }
+ }
+ event generate $S(-parent) <<TkFontchooserFontChanged>>
+}
+
+# ::tk::fontchooser::Init --
+#
+# Initializes dialog to a default font
+#
+# Arguments:
+# defaultFont font to use as the default
+#
+proc ::tk::fontchooser::Init {{defaultFont ""}} {
+ variable S
+
+ if {$S(first) || $defaultFont ne ""} {
+ Canonical
+ if {$defaultFont eq ""} {
+ set defaultFont [[entry .___e] cget -font]
+ destroy .___e
+ }
+ array set F [font actual $defaultFont]
+ set S(font) $F(-family)
+ set S(style) [::msgcat::mc "Regular"]
+ set S(size) $F(-size)
+ set S(strike) $F(-overstrike)
+ set S(under) $F(-underline)
+ if {$F(-weight) eq "bold" && $F(-slant) eq "italic"} {
+ set S(style) [::msgcat::mc "Bold Italic"]
+ } elseif {$F(-weight) eq "bold"} {
+ set S(style) [::msgcat::mc "Bold"]
+ } elseif {$F(-slant) eq "italic"} {
+ set S(style) [::msgcat::mc "Italic"]
+ }
+ set S(first) 0
+ }
+}
+
+# ::tk::fontchooser::Click --
+#
+# Handles all button clicks, updating the appropriate widgets
+#
+# Arguments:
+# who which widget got pressed
+#
+proc ::tk::fontchooser::Click {who} {
+ variable S
+ if {$who eq "font"} {
+ set S(font) [$S(W).lfonts get [$S(W).lfonts curselection]]
+ } elseif {$who eq "style"} {
+ set S(style) [$S(W).lstyles get [$S(W).lstyles curselection]]
+ } elseif {$who eq "size"} {
+ set S(size) [$S(W).lsizes get [$S(W).lsizes curselection]]
+ }
+}
+
+# ::tk::fontchooser::Tracer --
+#
+# Handles traces on key variables, updating the appropriate widgets
+#
+# Arguments:
+# standard trace arguments (not used)
+#
+proc ::tk::fontchooser::Tracer {var1 var2 op} {
+ variable S
+ # We don't need to process strike and under
+ if {$var2 ni [list strike under]} {
+ # Make selection in listbox
+ set value [string tolower $S($var2)]
+ $S(W).l${var2}s selection clear 0 end
+ set n [lsearch -exact $S(${var2}s,lcase) $value]
+ $S(W).l${var2}s selection set $n
+ if {$n >= 0} {
+ set S($var2) [lindex $S(${var2}s) $n]
+ $S(W).e$var2 icursor end
+ $S(W).e$var2 selection clear
+ if {[set i [lsearch $S(bad) $var2]] >= 0} {
+ set S(bad) [lreplace $S(bad) $i $i]
+ }
+ } else {
+ # No match, try prefix
+ set n [lsearch -glob $S(${var2}s,lcase) "$value*"]
+ if {$var2 ne "size" || !([regexp -- {^(-[0-9]+|[0-9]+)$} $value] && $value >= -4096 && $value <= 4096)} {
+ if {[lsearch $S(bad) $var2] < 0} {
+ lappend S(bad) $var2
+ }
+ } else {
+ if {[set i [lsearch $S(bad) $var2]] >= 0} {
+ set S(bad) [lreplace $S(bad) $i $i]
+ }
+ }
+ }
+ $S(W).l${var2}s see $n
+ }
+ if {[llength $S(bad)] == 0} {
+ set S(nstate) normal
+ Update
+ } else {
+ set S(nstate) disabled
+ }
+ $S(W).ok configure -state $S(nstate)
+ $S(W).apply configure -state $S(nstate)
+}
+
+# ::tk::fontchooser::Update --
+#
+# Shows a sample of the currently selected font
+#
+proc ::tk::fontchooser::Update {} {
+ variable S
+
+ set S(result) [list $S(font) $S(size)]
+ if {$S(style) eq [::msgcat::mc "Bold"]} {
+ lappend S(result) bold
+ }
+ if {$S(style) eq [::msgcat::mc "Italic"]} {
+ lappend S(result) italic
+ }
+ if {$S(style) eq [::msgcat::mc "Bold Italic"]} {
+ lappend S(result) bold italic
+ }
+ if {$S(strike)} {
+ lappend S(result) overstrike
+ }
+ if {$S(under)} {
+ lappend S(result) underline
+ }
+
+ $S(sample) configure -font $S(result)
+ set S(-font) $S(result)
+}
+
+# ::tk::fontchooser::Visibility --
+#
+# Notify the parent when the dialog visibility changes
+#
+proc ::tk::fontchooser::Visibility {w visible} {
+ variable S
+ if {$w eq $S(W)} {
+ event generate $S(-parent) <<TkFontchooserVisibility>>
+ }
+}
+
+# ::tk::fontchooser::ttk_slistbox --
+#
+# Create a properly themed scrolled listbox.
+# This is exactly right on XP but may need adjusting on other platforms.
+#
+proc ::tk::fontchooser::ttk_slistbox {w args} {
+ set f [ttk::frame $w -style FontchooserFrame -padding 1.5p]
+ if {[catch {
+ listbox $f.list -relief flat -highlightthickness 0 -borderwidth 0 {*}$args
+ ttk::scrollbar $f.vs -command [list $f.list yview]
+ $f.list configure -yscrollcommand [list $f.vs set]
+ grid $f.list $f.vs -sticky news
+ grid rowconfigure $f 0 -weight 1
+ grid columnconfigure $f 0 -weight 1
+ interp hide {} $w
+ interp alias {} $w {} $f.list
+ } err opt]} {
+ destroy $f
+ return -options $opt $err
+ }
+ return $w
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/fontchooser.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/iconbadges.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/iconbadges.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/iconbadges.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,253 @@
+# iconbadges.tcl --
+#
+# Notification badges for Tk applications.
+#
+#
+# Copyright © 2021 Kevin Walzer/WordTech Communications LLC
+
+namespace eval ::tk::icons {}
+
+image create photo ::tk::icons::1-badge -data {
+ iVBORw0KGgoAAAANSUhEUgAAABIAAAASCAMAAABhEH5lAAAABGdBTUEAALGPC/xh
+ BQAAACBjSFJNAAB6JgAAgIQAAPoAAACA6AAAdTAAAOpgAAA6mAAAF3CculE8AAAA
+ kFBMVEUAAAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/
+ AAD/AAD/AAD/AAD/HBz/V1f/Rkb/BQX/Dw//oKD/////y8v/Bgb/Pz//ra3/+/v/
+ zMz/Li7/5ub/+vr/8fH/Ly//uLj/Zmb/n5//Bwf/Dg7/kpL/YWH/rq7/h4f/Cgr/
+ AQH/AgLXmjE+AAAAEXRSTlMAAA5Vq9/4NK/0St3cDa7z4Pnet34AAAABYktHRBib
+ aYUeAAAAnElEQVQY022Q5w6DMBCD78hi03RQuvegg77/25ULCakq/MenT4piGwAQ
+ A8aFlIKzABGAiAojbRSFihhinOheSdwyVKn+UaoQsry7x5PpjDzPgBWGlPNqUdJR
+ MODky9V6U20N0hwE2W5/ODokQJKdzperQ7JDt7uuPRL299o/5P+IuxA9akO4qI/n
+ 622jukLNp3GFBmoPjOMnHNkJv3kDExXHctm+AAAAJXRFWHRkYXRlOmNyZWF0ZQAy
+ MDIxLTA4LTEwVDA4OjM1OjE0LTA0OjAw0aX6GwAAACV0RVh0ZGF0ZTptb2RpZnkA
+ MjAyMS0wOC0xMFQwODozNToxNC0wNDowMKD4QqcAAAAASUVORK5CYII=
+}
+image create photo ::tk::icons::2-badge -data {
+ iVBORw0KGgoAAAANSUhEUgAAABIAAAASCAMAAABhEH5lAAAABGdBTUEAALGPC/xh
+ BQAAACBjSFJNAAB6JgAAgIQAAPoAAACA6AAAdTAAAOpgAAA6mAAAF3CculE8AAAA
+ 21BMVEUAAAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/
+ AAD/AAD/AAD/AAD/Cwv/ODj/UlL/UFD/MjL/CAj/ExP/oKD/8fH//v7//f3/7u7/
+ kJD/DAz/ZWX/9fX/jIz/lpb/+vr/9/f/TEz/TU3/m5v/iYn/Ly//6+v/////YmL/
+ nJz/5OT/MDD/KSn/srL/7Oz/ZGT/AQH/Nzf/zs7/zc3/SUn/AgL/ICD/ysr/7e3/
+ gYH/VVX/WVn/Kir/fX3/eXn/AwP/dnb/rKz/qan/q6vjChO4AAAAEXRSTlMAAA5V
+ q9/4NK/0St3cDa7z4Pnet34AAAABYktHRCy63XGrAAAAwElEQVQY021Q1xLCMAxz
+ uktpS9hQoOwZ9t57/P8XUSesB/RinXz2SQIAQiRZUTVNVWSJEABUdMOkHKaho0ZI
+ yKIfWKFAI3qY/iCsE7AdZNFYPJFMIXNskN1gpjNZL5cv+AF1ZVBwVfRK5Uq1Vkeu
+ gIqj0Wz57Q7rIldBe/1N91h/gER7S8ORN55MhcQP6WzOFssVFYf8/XrDtrv94Sje
+ cxMnxnEWJtDq5Xq7B3gkhFUeaCUwFYH+xP5TzrfCyKvCJ3EzGUFH/1QDAAAAJXRF
+ WHRkYXRlOmNyZWF0ZQAyMDIxLTA4LTEwVDA4OjM1OjE0LTA0OjAw0aX6GwAAACV0
+ RVh0ZGF0ZTptb2RpZnkAMjAyMS0wOC0xMFQwODozNToxNC0wNDowMKD4QqcAAAAA
+ SUVORK5CYII=
+}
+image create photo ::tk::icons::3-badge -data {
+ iVBORw0KGgoAAAANSUhEUgAAABIAAAASCAMAAABhEH5lAAAABGdBTUEAALGPC/xh
+ BQAAACBjSFJNAAB6JgAAgIQAAPoAAACA6AAAdTAAAOpgAAA6mAAAF3CculE8AAAA
+ +VBMVEUAAAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/
+ AAD/AAD/AAD/AAD/CQn/NTX/UlL/Tk7/Kir/BAT/ERH/mZn/8PD/+Pj/+vr/5ub/
+ cHD/AgL/Vlb/9PT/5eX/X1//nZ3/////29v/HR3/Fhb/QED/RET/Cwv/f3//1dX/
+ Ghr/Bwf/mpr/9vb/+fn/b2//lZX/2tr//Pz/wsL/Jyf/Dg7/Bgb/MzP/c3P/XV3/
+ wMD/qqr/ExP/KSn/4+P/bm7/Q0P/6ur/vb3/x8f/19f/KCj/SEj/qan/zc3/y8v/
+ oKD/ODj/BQX/DQ3/AwON+4wDAAAAEXRSTlMAAA5Vq9/4NK/0St3cDa7z4Pnet34A
+ AAABYktHRCXDAckPAAAAx0lEQVQY021Q1RLCQBDbo4qW4l7ssOLu7g7//zH07oo8
+ kJfNZGczyQIAQhaOF0RR4DkLQgBEkWSrSmGVJaIhZLOrH9hthoYkh/oDh4TA6SLM
+ 4/X5A0HCXE7gFGOGwpFoLJ7QDKpwwJNVMpXOZHEuTzgPAhmFYkkv40qVcAFEZlur
+ N5otysS3pLc73V6fSfRQ8wyGozges0NqP5nO5oslXjF7GmK96W53eH9gIWhU7Xg6
+ X643M6pZ6D54PN+F/tT+85zvC93mC1+z9hl5VNGhJwAAACV0RVh0ZGF0ZTpjcmVh
+ dGUAMjAyMS0wOC0xMFQwODozNToxNC0wNDowMNGl+hsAAAAldEVYdGRhdGU6bW9k
+ aWZ5ADIwMjEtMDgtMTBUMDg6MzU6MTQtMDQ6MDCg+EKnAAAAAElFTkSuQmCC
+}
+image create photo ::tk::icons::4-badge -data {
+ iVBORw0KGgoAAAANSUhEUgAAABIAAAASCAMAAABhEH5lAAAABGdBTUEAALGPC/xh
+ BQAAACBjSFJNAAB6JgAAgIQAAPoAAACA6AAAdTAAAOpgAAA6mAAAF3CculE8AAAA
+ 1VBMVEUAAAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/
+ AAD/AAD/AAD/AAD/AgL/OTn/W1v/ODj/QED/4uL/////oaH/AQH/KSn/zs7/oqL/
+ Fhb/tbX/9PT/1NT/Cgr/l5f//Pz/h4f/fHz/dXX/+/v/trb/HBz/fX3/qKj/DAz/
+ EBD/ysr/4eH/zc3/5eX/8fH/lJT/BAT/Dw//uLj/5+f/5ub/8vL/+vr/paX/BQX/
+ HR3/JCT/ISH/iYn/sLD/Ghr/Tk7/rq7/a2vT0ZXAAAAAEXRSTlMAAA5Vq9/4NK/0
+ St3cDa7z4Pnet34AAAABYktHRBibaYUeAAAAvklEQVQY022QVRPCMBCEL1RSg5Ji
+ Ibi7W9Hi//8n0aRBHtiXvflm7mZvAQChmKJquq6pSgwhAE6wYRIh08CcIWTZ5CPb
+ ChnCDvmRgxHEE9HspdIZ7ok4KG6EsjmaZ6G7CqgRKRQpLXFEVNAEKVeqNYk00LnV
+ G81WWyJdINbp9voDOhxFiC+OJ3Q6m9PFciUW+fn1xt/6O7o/HMV5HsI7BcH5Qq83
+ JkK8o5L74ymjfh5iHpMP/Xn7TznfCpOywhdM6Ra8aC+AYwAAACV0RVh0ZGF0ZTpj
+ cmVhdGUAMjAyMS0wOC0xMFQwODozNToxNS0wNDowMHfS8a8AAAAldEVYdGRhdGU6
+ bW9kaWZ5ADIwMjEtMDgtMTBUMDg6MzU6MTUtMDQ6MDAGj0kTAAAAAElFTkSuQmCC
+}
+image create photo ::tk::icons::5-badge -data {
+ iVBORw0KGgoAAAANSUhEUgAAABIAAAASCAMAAABhEH5lAAAABGdBTUEAALGPC/xh
+ BQAAACBjSFJNAAB6JgAAgIQAAPoAAACA6AAAdTAAAOpgAAA6mAAAF3CculE8AAAA
+ 7VBMVEUAAAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/
+ AAD/AAD/AAD/AAD/ICD/MjL/Li7/CQn/Bgb/q6v/8/P/8vL/9PT/4uL/FRX/0tL/
+ ////wsL/xcX/uLj/Jib/Kyv/6ur/8fH/aGj/XV3/SUn/Fhb/AQH/+Pj//Pz/7Oz/
+ +fn/l5f/Dg7/ODj/qan/sLD/W1v/fn7/9/f/+vr/WVn/EBD/Ghr/2dn/gID/X1//
+ oKD/EhL/5OT/Y2P/S0v/7e3/vb3/ycn/yMj/HR3/AwP/Skr/zc3/LCz/BQX/DAz/
+ AgKLBoLHAAAAEXRSTlMAAA5Vq9/4NK/0St3cDa7z4Pnet34AAAABYktHRB5yCiAr
+ AAAAyUlEQVQY021Q1RLDMAxzVhp1XcbYMXXMzIz//zmLk9HD9GKdzvZJAgBCbJKs
+ qKoiSzZCAFDR7A7K4bBrqBHidNEPXE6mEc1Nf+DWCOgeZD4/QyDImEcHyWAzFI5E
+ I7F4gFFDAhmXEkkzmUpnsshlUHDk8oViqVyxkCug4ihXa/VGtNlCrgqp3en2+oPh
+ SEj80AqO6WRqzsQhfz/PLJa5lbkW77mJzba225uHozDBrZ7Oncu+eaXC6ivQrXV/
+ vAP9if2nnG+F3leFT2jDGOnV8F/uAAAAJXRFWHRkYXRlOmNyZWF0ZQAyMDIxLTA4
+ LTEwVDA4OjM1OjE1LTA0OjAwd9LxrwAAACV0RVh0ZGF0ZTptb2RpZnkAMjAyMS0w
+ OC0xMFQwODozNToxNS0wNDowMAaPSRMAAAAASUVORK5CYII=
+}
+image create photo ::tk::icons::6-badge -data {
+ iVBORw0KGgoAAAANSUhEUgAAABIAAAASCAMAAABhEH5lAAAABGdBTUEAALGPC/xh
+ BQAAACBjSFJNAAB6JgAAgIQAAPoAAACA6AAAdTAAAOpgAAA6mAAAF3CculE8AAAA
+ 9lBMVEUAAAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/
+ AAD/AAD/AAD/AAD/AQH/ICD/S0v/UlL/NDT/CAj/WVn/2dn/+Pj/+fn/8PD/jY3/
+ Cgr/LCz/4OD//f3/hob/cHD/5eX/1NT/NTX/bGz/////39//T0//Bwf/j4//5ub/
+ wcH/7+//4uL/f3//CQn/lpb/+/v/n5//iIj/8vL/9/f/UVH/hYX/3t7/Hx//vb3/
+ VVX/6Oj/MzP/ExP/x8f/e3v/EhL/t7f/0tL/wMD/MTH/IiL/xsb/zc3/qKj/QkL/
+ AgL/Cwv/Dg7/BQWiS7IgAAAAEXRSTlMAAA5Vq9/4NK/0St3cDa7z4Pnet34AAAAB
+ YktHRCi9sLWyAAAAyklEQVQY021Q1RLCQBDbowalBYq7y+FWirs7/P/PwPawB/Ky
+ mezsThIAIMTC8YIoCjxnIQQAFclq00zYrBJqhMh27QO7/NSIpGg/UCQCqgOZ2+P1
+ +QPIHCpwTlSCoXAkGos/qZMDHleJZCqdyebyyHkQcBRoMeEvecrIBRBxVGi1Vm80
+ W8hFJrWp3jG6vT6TzMMBHY4CY2qwQ/P9RJ/O5gu6ZO9NE6s13Wz14o6ZYFb3scPx
+ dHYzq69Al+vt/g70J/afcr4Vul4VPgDLCRmO3FuJegAAACV0RVh0ZGF0ZTpjcmVh
+ dGUAMjAyMS0wOC0xMFQwODozNToxNS0wNDowMHfS8a8AAAAldEVYdGRhdGU6bW9k
+ aWZ5ADIwMjEtMDgtMTBUMDg6MzU6MTUtMDQ6MDAGj0kTAAAAAElFTkSuQmCC
+}
+image create photo ::tk::icons::7-badge -data {
+ iVBORw0KGgoAAAANSUhEUgAAABIAAAASCAMAAABhEH5lAAAABGdBTUEAALGPC/xh
+ BQAAACBjSFJNAAB6JgAAgIQAAPoAAACA6AAAdTAAAOpgAAA6mAAAF3CculE8AAAA
+ xlBMVEUAAAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/
+ AAD/AAD/AAD/AAD/Hh7/Njb/NTX/Ghr/i4v/9/f/8/P/8vL/8fH/9PT/eHj/fHz/
+ 3Nz/2Nj/19f/6Oj/////+Pj/YGD/DQ3/Fxf/FRX/IiL/trb/j4//CQn/Zmb/+/v/
+ xsb/GBj/HR3/0tL//f3/Xl7/ZGT/1dX/BAT/p6f/n5//AQH/Fhb/09P/c3P/GRn/
+ mZn/qqr/PT3/AgKXVg1iAAAAEXRSTlMAAA5Vq9/4NK/0St3cDa7z4Pnet34AAAAB
+ YktHRCJdZVysAAAAu0lEQVQY022Q1xKCMBBFN5LQixFR7Bp77wU7//9TJgTFB+7L
+ njmTydxdAECooGCiqgQrBYQAhNF0gyYxdE04hEyL/mKZ3CHNpn+xNQSOy6Hkl3n8
+ gKPrgOLxWamGYa3eaHL0FMDieavd6fZYfyAYAxFjOBpPpmw2F0xATf9dLFfrBNSv
+ 2mx3e5oqIuHAjoEkIr+npzO7RFJhWYJeb+wuDS+RVKWP5+stFa8qF4riOFsoZ+2c
+ 42QnLKYn/ADYChWCRPB9rQAAACV0RVh0ZGF0ZTpjcmVhdGUAMjAyMS0wOC0xMFQw
+ ODozNToxNS0wNDowMHfS8a8AAAAldEVYdGRhdGU6bW9kaWZ5ADIwMjEtMDgtMTBU
+ MDg6MzU6MTUtMDQ6MDAGj0kTAAAAAElFTkSuQmCC
+}
+image create photo ::tk::icons::8-badge -data {
+ iVBORw0KGgoAAAANSUhEUgAAABIAAAASCAMAAABhEH5lAAAABGdBTUEAALGPC/xh
+ BQAAACBjSFJNAAB6JgAAgIQAAPoAAACA6AAAdTAAAOpgAAA6mAAAF3CculE8AAAA
+ 6lBMVEUAAAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/
+ AAD/AAD/AAD/AAD/Bwf/MjL/UVH/TU3/Kir/BAT/DAz/j4//7e3/+Pj/5+f/eXn/
+ BQX/Skr/9/f/7+//Z2f/fn7/+/v/6ur/MDD/UFD/4uL/Jib/QUH/9PT/NTX/EhL/
+ srL/////09P/2tr/m5v/CAj/ycn//f3/y8v/1dX/s7P/GBj/hYX/HR3/Zmb/0dH/
+ LCz/5eX/dHT/S0v/wsL/NDT/V1f/sLD/zc3/ysr/paX/RUX/AQH/Bgb/Dg7/DQ3m
+ iTf5AAAAEXRSTlMAAA5Vq9/4NK/0St3cDa7z4Pnet34AAAABYktHRC8j1CARAAAA
+ yklEQVQY021Q1RLCQBDbowZFSpEWh+J+xd3d/v936N5hD+QlmezsTrIAQIhLECVZ
+ lkTBRQgAOorbozN43Ap6hKhe/QOv6nhE8ek/8CkE/AFUoXAkapioAn4QNIdj8UQy
+ mUpnHKkJIOIom7PyhWKpjFoECalSrNbqDauJWgIZqdWmdod2e6hlbhn9wXBExxNu
+ scUptWfhFJ3zRXY+TheT5Yqu+XkWYmMNtkNa3fEQLGpmfziezpcrj/oqdLs/zHeh
+ P7X/POf7wuDrhU+46hlBGTVCQgAAACV0RVh0ZGF0ZTpjcmVhdGUAMjAyMS0wOC0x
+ MFQwODozNToxNS0wNDowMHfS8a8AAAAldEVYdGRhdGU6bW9kaWZ5ADIwMjEtMDgt
+ MTBUMDg6MzU6MTUtMDQ6MDAGj0kTAAAAAElFTkSuQmCC
+}
+image create photo ::tk::icons::9-badge -data {
+ iVBORw0KGgoAAAANSUhEUgAAABIAAAASCAMAAABhEH5lAAAABGdBTUEAALGPC/xh
+ BQAAACBjSFJNAAB6JgAAgIQAAPoAAACA6AAAdTAAAOpgAAA6mAAAF3CculE8AAAA
+ 8FBMVEUAAAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/
+ AAD/AAD/AAD/AAD/DAz/OTn/U1P/R0f/HBz/AQH/Fhb/oqL/8/P/+fn/+Pj/1NT/
+ S0v/cXH/////29v/W1v/mJj/0ND/AgL/paX/np7/Ly//7e3//Pz/lZX/vr7/GBj/
+ VVX/9fX/c3P/QED/5ub//f3/19f/4OD/+/v/eXn/Pz//mZn/oaH/dXX/6Oj/Z2f/
+ Kir/cHD/enr/FRX/TU3/8PD/Ojr/Ozv/2tr/nJz/CAj/Tk7/sbH/z8//wcH/Bgb/
+ Dw//CgoJOUsyAAAAEXRSTlMAAA5Vq9/4NK/0St3cDa7z4Pnet34AAAABYktHRCCz
+ az2AAAAAy0lEQVQY022Q1RLCQAxFs9QovlAozuLu7u72/39D0y3yQB6SO2cmmXsD
+ AITYBFGSZUkUbIQAIFHsKjVLtSvICHE46aecDoMRxUV/yqUQcHtQ+QNaMKSj8rhB
+ 8BozHInG4okkIq8AIs4US2eyLBdCLYJk9HyBFWmpXNEQSSDjqLJavdFkLdQyR+1O
+ t9cfsCFHuEj10XgynbE5XzTPL5ar9Sa+3fHzpon9rFI7sOOJmzCt5s+X6221tqxa
+ ge6Pp/4O9Cf2n+d8X+izXvgCm5cZM7QQ1AwAAAAldEVYdGRhdGU6Y3JlYXRlADIw
+ MjEtMDgtMTBUMDg6MzU6MTUtMDQ6MDB30vGvAAAAJXRFWHRkYXRlOm1vZGlmeQAy
+ MDIxLTA4LTEwVDA4OjM1OjE1LTA0OjAwBo9JEwAAAABJRU5ErkJggg==
+}
+
+image create photo ::tk::icons::9plus-badge -data {
+ iVBORw0KGgoAAAANSUhEUgAAABIAAAASCAMAAABhEH5lAAAABGdBTUEAALGPC/xh
+ BQAAACBjSFJNAAB6JgAAgIQAAPoAAACA6AAAdTAAAOpgAAA6mAAAF3CculE8AAAB
+ OFBMVEUAAAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/
+ AAD/ERH/AAD/NDT/AQH/AAD/AAD/Cgr/Nzf/U1P/SUn/Hx//AQH/mJj/8fH/+fn/
+ 2dn/VFT/BAT/YmL//f3/4uL/YGD/j4//IyP/GBj/xsb/xcX/Fxf/lZX/////rKz/
+ JSX/5eX/3t7/3Nz/AgL/hob/yMj/Hh7/Skr/fn7/MTH/srL/vr7/9fX/NDT/NTX/
+ 39///v7/3d3/+vr/g4P/RET/9PT/+/v/8/P/R0f/OTn/lpb/pKT/c3P/4eH/dHT/
+ Dw//Pz//VVX/5ub/ExP/JCT/bW3/fX3/Ghr/QUH/Rkb/Gxv/wsL/1dX/p6f/DAz/
+ e3v/enr/Dg7/ra3/zs7/w8P/gYH/GRn/Bgb/CwuphzIHAAAAFHRSTlMAAA5Vq9/4
+ NK/0St3cDa7z8/Ou4A5hHfoAAAABYktHRCy63XGrAAAA+ElEQVQY02NgYGBkZGJm
+ YWVjY2VhZmJkZGAAibBzcIqAAScHO0iMkZGLWwQOuLmAYozsPCJIgIedkYGXT1RM
+ XEJSCibGx8vAzC8tIysrJw/kKUhKKogIMDOwKCopq6gqyamJiKhraGqJiLAwsGrr
+ 6Erp6euoABUZGEoqGLEysBnrmJiayeiYW1haWVtbWdqwMbDZ2tnLOTjqODm7uNrb
+ u7q5szGwinh4enn76Pj6+QcE6gf4B7EysASHhIaFu1lHiIhEGhiGgYxnFvSxj4rW
+ iYkVEfGLi08AOYJXKCIxKTklFcmpQA+lJaRLIXsIi7exBA4iCIWhQQgAiNMk9J5+
+ e/MAAAAldEVYdGRhdGU6Y3JlYXRlADIwMjEtMDgtMTBUMDg6MzU6MTYtMDQ6MDBG
+ OusyAAAAJXRFWHRkYXRlOm1vZGlmeQAyMDIxLTA4LTEwVDA4OjM1OjE2LTA0OjAw
+ N2dTjgAAAABJRU5ErkJggg==
+}
+image create photo ::tk::icons::!-badge -data {
+ iVBORw0KGgoAAAANSUhEUgAAABIAAAASCAMAAABhEH5lAAAABGdBTUEAALGPC/xh
+ BQAAACBjSFJNAAB6JgAAgIQAAPoAAACA6AAAdTAAAOpgAAA6mAAAF3CculE8AAAA
+ olBMVEUAAAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/AAD/
+ AAD/AAD/AAD/AAD/Fhb/QED/Pj7/ExP/VVX/9PT/8PD/SUn/WFj//v7/+fn/S0v/
+ SEj/PDz/MjL/6Oj/Jyf/ICD/4+P/2Nj/Fxf/Dw//qKj/nZ3/Cgr/IyP/hIT/gYH/
+ Hh7/PT3/Ly//paX/oqL/KCj/AgL///8V6AjgAAAAEXRSTlMAAA5Vq9/4NK/0St3c
+ Da7z4Pnet34AAAABYktHRDXettlrAAAAoElEQVQY022QxxKCQBBEZ9hERkygophz
+ lv//NmF3Bz0wp1dd1V3dAwCIDuNCSsGZgwjQKMr1Un2eqxoN0Q/S9gK/1lCF6d+F
+ CiGKNfYHw5GGOAKWaBpn+URDwoAbw3RWzA1xEAYWRVYaEiANLPPV2pAkabPd7Umy
+ xsPxdCajjb9cb3eKtyXq+AeVsFWfr/eHqtKgqmoHdczueM7vhT37wi9PRRMHXNeq
+ aAAAACV0RVh0ZGF0ZTpjcmVhdGUAMjAyMS0wOC0xMFQwODozNToxNi0wNDowMEY6
+ 6zIAAAAldEVYdGRhdGU6bW9kaWZ5ADIwMjEtMDgtMTBUMDg6MzU6MTYtMDQ6MDA3
+ Z1OOAAAAAElFTkSuQmCC
+}
+
+
+if {[tk windowingsystem] eq "x11"} {
+
+ # ::tk::icons::IconBadge --
+ # This procedure creates an icon with an overlay badge on systems that
+ # do not have a native icon/badge API.
+ #
+ # Arguments:
+ # win - window name
+ # badgenumber - badge number to draw over the window icon
+
+ proc ::tk::icons::IconBadge {win badgenumber} {
+
+ variable ::tk::icons::base_icon
+
+ if {![info exists ::tk::icons::base_icon]} {
+ return -code error "::tk::icons::base_icon($win) must be set on X11"
+ }
+
+ if {![info exists ::tk::icons::base_icon($win)]} {
+ return -code error "::tk::icons::base_icon($win) must be set on X11"
+ }
+
+ if {[lsearch -exact [image names] $::tk::icons::base_icon($win)] <= 0} {
+ return -code error "can't use \"$::tk::icons::base_icon($win)\" as iconphoto: not a photo image"
+ }
+
+ if {!([string is integer -strict $badgenumber] && $badgenumber > 0)
+ && $badgenumber ne "!" && $badgenumber ne ""} {
+ return -code error "can't use \"$badgenumber\" as icon badge"
+ }
+
+ wm iconphoto $win $::tk::icons::base_icon($win)
+
+ if {$badgenumber eq ""} {
+ return
+ }
+
+ image create photo overlay
+
+ switch -glob -- $badgenumber {
+ ! {
+ set badge ::tk::icons::!-badge
+ }
+ [1-9] {
+ set badge ::tk::icons::$badgenumber-badge
+ }
+ default {
+ set badge ::tk::icons::9plus-badge
+ }
+
+ }
+
+ overlay copy $::tk::icons::base_icon($win)
+ overlay copy $badge -from 0 0 18 18 -to 18 0
+ wm iconphoto $win overlay
+
+ }
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/iconbadges.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/iconlist.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/iconlist.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/iconlist.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,705 @@
+# iconlist.tcl
+#
+# Implements the icon-list megawidget used in the "Tk" standard file
+# selection dialog boxes.
+#
+# Copyright © 1994-1998 Sun Microsystems, Inc.
+# Copyright © 2009 Donal K. Fellows
+#
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# API Summary:
+# tk::IconList <path> ?<option> <value>? ...
+# <path> add <imageName> <itemList>
+# <path> cget <option>
+# <path> configure ?<option>? ?<value>? ...
+# <path> deleteall
+# <path> destroy
+# <path> get <itemIndex>
+# <path> index <index>
+# <path> invoke
+# <path> see <index>
+# <path> selection anchor ?<int>?
+# <path> selection clear <first> ?<last>?
+# <path> selection get
+# <path> selection includes <item>
+# <path> selection set <first> ?<last>?
+
+package require tk
+
+::tk::Megawidget create ::tk::IconList ::tk::FocusableWidget {
+ variable w canvas sbar accel accelCB fill font index \
+ itemList itemsPerColumn list maxIH maxIW maxTH maxTW noScroll \
+ numItems oldX oldY options rect selected selection textList
+ constructor args {
+ next {*}$args
+ set accelCB {}
+ }
+ destructor {
+ my Reset
+ next
+ }
+
+ method GetSpecs {} {
+ concat [next] {
+ {-command "" "" ""}
+ {-font "" "" "TkIconFont"}
+ {-multiple "" "" "0"}
+ }
+ }
+
+ # ----------------------------------------------------------------------
+
+ method index i {
+ if {![info exist list]} {
+ set list {}
+ }
+ switch -regexp -- $i {
+ "^-?[0-9]+$" {
+ if {$i < 0} {
+ set i 0
+ }
+ if {$i >= [llength $list]} {
+ set i [expr {[llength $list] - 1}]
+ }
+ return $i
+ }
+ "^anchor$" {
+ return $index(anchor)
+ }
+ "^end$" {
+ return [llength $list]
+ }
+ "@-?[0-9]+,-?[0-9]+" {
+ scan $i "@%d,%d" x y
+ set item [$canvas find closest \
+ [$canvas canvasx $x] [$canvas canvasy $y]]
+ return [lindex [$canvas itemcget $item -tags] 1]
+ }
+ }
+ }
+
+ method selection {op args} {
+ switch -exact -- $op {
+ anchor {
+ if {[llength $args] == 1} {
+ set index(anchor) [$w index [lindex $args 0]]
+ } else {
+ return $index(anchor)
+ }
+ }
+ clear {
+ switch [llength $args] {
+ 2 {
+ lassign $args first last
+ }
+ 1 {
+ set first [set last [lindex $args 0]]
+ }
+ default {
+ return -code error -errorcode {TCL WRONGARGS} \
+ "wrong # args: should be\
+ \"[lrange [info level 0] 0 1] first ?last?\""
+ }
+ }
+
+ set first [$w index $first]
+ set last [$w index $last]
+ if {$first > $last} {
+ set tmp $first
+ set first $last
+ set last $tmp
+ }
+ set ind 0
+ foreach item $selection {
+ if {$item >= $first} {
+ set first $ind
+ break
+ }
+ incr ind
+ }
+ set ind [expr {[llength $selection] - 1}]
+ for {} {$ind >= 0} {incr ind -1} {
+ set item [lindex $selection $ind]
+ if {$item <= $last} {
+ set last $ind
+ break
+ }
+ }
+
+ if {$first > $last} {
+ return
+ }
+ set selection [lreplace $selection $first $last]
+ event generate $w <<ListboxSelect>>
+ my DrawSelection
+ }
+ get {
+ return $selection
+ }
+ includes {
+ return [expr {[lindex $args 0] in $selection}]
+ }
+ set {
+ switch [llength $args] {
+ 2 {
+ lassign $args first last
+ }
+ 1 {
+ set first [set last [lindex $args 0]]
+ }
+ default {
+ return -code error -errorcode {TCL WRONGARGS} \
+ "wrong # args: should be\
+ \"[lrange [info level 0] 0 1] first ?last?\""
+ }
+ }
+
+ set first [$w index $first]
+ set last [$w index $last]
+ if {$first > $last} {
+ set tmp $first
+ set first $last
+ set last $tmp
+ }
+
+ for {set i $first} {$i <= $last} {incr i} {
+ lappend selection $i
+ }
+ set selection [lsort -integer -unique $selection]
+ event generate $w <<ListboxSelect>>
+ my DrawSelection
+ }
+ }
+ }
+
+ method get item {
+ set rTag [lindex $list $item 2]
+ lassign $itemList($rTag) iTag tTag text serial
+ return $text
+ }
+
+ # Deletes all the items inside the canvas subwidget and reset the
+ # iconList's state.
+ #
+ method deleteall {} {
+ $canvas delete all
+ unset -nocomplain selected rect list itemList
+ set maxIW 1
+ set maxIH 1
+ set maxTW 1
+ set maxTH 1
+ set numItems 0
+ set noScroll 1
+ set selection {}
+ set index(anchor) ""
+ $sbar set 0.0 1.0
+ $canvas xview moveto 0
+ }
+
+ # Adds an icon into the IconList with the designated image and text
+ #
+ method add {image items} {
+ foreach text $items {
+ set iID item$numItems
+ set iTag [$canvas create image 0 0 -image $image -anchor nw \
+ -tags [list icon $numItems $iID]]
+ set tTag [$canvas create text 0 0 -text $text -anchor nw \
+ -font $options(-font) -fill $fill \
+ -tags [list text $numItems $iID]]
+ set rTag [$canvas create rect 0 0 0 0 -fill "" -outline "" \
+ -tags [list rect $numItems $iID]]
+
+ lassign [$canvas bbox $iTag] x1 y1 x2 y2
+ set iW [expr {$x2 - $x1}]
+ set iH [expr {$y2 - $y1}]
+ if {$maxIW < $iW} {
+ set maxIW $iW
+ }
+ if {$maxIH < $iH} {
+ set maxIH $iH
+ }
+
+ lassign [$canvas bbox $tTag] x1 y1 x2 y2
+ set tW [expr {$x2 - $x1}]
+ set tH [expr {$y2 - $y1}]
+ if {$maxTW < $tW} {
+ set maxTW $tW
+ }
+ if {$maxTH < $tH} {
+ set maxTH $tH
+ }
+
+ lappend list [list $iTag $tTag $rTag $iW $iH $tW $tH $numItems]
+ set itemList($rTag) [list $iTag $tTag $text $numItems]
+ set textList($numItems) [string tolower $text]
+ incr numItems
+ }
+ my WhenIdle Arrange
+ return
+ }
+
+ # Gets called when the user invokes the IconList (usually by
+ # double-clicking or pressing the Return key).
+ #
+ method invoke {} {
+ if {$options(-command) ne "" && [llength $selection]} {
+ uplevel #0 $options(-command)
+ }
+ }
+
+ # If the item is not (completely) visible, scroll the canvas so that it
+ # becomes visible.
+ #
+ method see rTag {
+ if {$noScroll} {
+ return
+ }
+ set sRegion [$canvas cget -scrollregion]
+ if {$sRegion eq ""} {
+ return
+ }
+
+ if {$rTag < 0 || $rTag >= [llength $list]} {
+ return
+ }
+
+ set bbox [$canvas bbox item$rTag]
+ set pad [expr {[$canvas cget -highlightthickness]+[$canvas cget -bd]}]
+
+ set x1 [lindex $bbox 0]
+ set x2 [lindex $bbox 2]
+ incr x1 [expr {$pad * -2}]
+ incr x2 [expr {$pad * -1}]
+
+ set cW [expr {[winfo width $canvas] - $pad*2}]
+
+ set scrollW [expr {[lindex $sRegion 2]-[lindex $sRegion 0]+1}]
+ set dispX [expr {int([lindex [$canvas xview] 0]*$scrollW)}]
+ set oldDispX $dispX
+
+ # check if out of the right edge
+ #
+ if {($x2 - $dispX) >= $cW} {
+ set dispX [expr {$x2 - $cW}]
+ }
+ # check if out of the left edge
+ #
+ if {($x1 - $dispX) < 0} {
+ set dispX $x1
+ }
+
+ if {$oldDispX ne $dispX} {
+ set fraction [expr {double($dispX) / double($scrollW)}]
+ $canvas xview moveto $fraction
+ }
+ }
+
+ # ----------------------------------------------------------------------
+
+ # Places the icons in a column-major arrangement.
+ #
+ method Arrange {} {
+ if {![info exists list]} {
+ if {[info exists canvas] && [winfo exists $canvas]} {
+ set noScroll 1
+ $sbar configure -command ""
+ }
+ return
+ }
+
+ set W [winfo width $canvas]
+ set H [winfo height $canvas]
+ set pad [expr {[$canvas cget -highlightthickness]+[$canvas cget -bd]}]
+ if {$pad < 2} {
+ set pad 2
+ }
+
+ incr W [expr {$pad*-2}]
+ incr H [expr {$pad*-2}]
+
+ set dx [expr {$maxIW + $maxTW + 8}]
+ if {$maxTH > $maxIH} {
+ set dy $maxTH
+ } else {
+ set dy $maxIH
+ }
+ incr dy 2
+ set shift [expr {$maxIW + 4}]
+
+ set x [expr {$pad * 2}]
+ set y [expr {$pad * 1}] ; # Why * 1 ?
+ set usedColumn 0
+ foreach sublist $list {
+ set usedColumn 1
+ lassign $sublist iTag tTag rTag iW iH tW tH
+
+ set i_dy [expr {($dy - $iH)/2}]
+ set t_dy [expr {($dy - $tH)/2}]
+
+ $canvas coords $iTag $x [expr {$y + $i_dy}]
+ $canvas coords $tTag [expr {$x + $shift}] [expr {$y + $t_dy}]
+ $canvas coords $rTag $x $y [expr {$x+$dx}] [expr {$y+$dy}]
+
+ incr y $dy
+ if {($y + $dy) > $H} {
+ set y [expr {$pad * 1}] ; # *1 ?
+ incr x $dx
+ set usedColumn 0
+ }
+ }
+
+ if {$usedColumn} {
+ set sW [expr {$x + $dx}]
+ } else {
+ set sW $x
+ }
+
+ if {$sW < $W} {
+ $canvas configure -scrollregion [list $pad $pad $sW $H]
+ $sbar configure -command ""
+ $canvas xview moveto 0
+ set noScroll 1
+ } else {
+ $canvas configure -scrollregion [list $pad $pad $sW $H]
+ $sbar configure -command [list $canvas xview]
+ set noScroll 0
+ }
+
+ set itemsPerColumn [expr {($H-$pad) / $dy}]
+ if {$itemsPerColumn < 1} {
+ set itemsPerColumn 1
+ }
+
+ my DrawSelection
+ }
+
+ method DrawSelection {} {
+ $canvas delete selection
+ $canvas itemconfigure selectionText -fill $fill
+ $canvas dtag selectionText
+ set cbg [ttk::style lookup TEntry -selectbackground focus]
+ set cfg [ttk::style lookup TEntry -selectforeground focus]
+ foreach item $selection {
+ set rTag [lindex $list $item 2]
+ foreach {iTag tTag text serial} $itemList($rTag) {
+ break
+ }
+
+ set bbox [$canvas bbox $tTag]
+ $canvas create rect $bbox -fill $cbg -outline $cbg \
+ -tags selection
+ $canvas itemconfigure $tTag -fill $cfg -tags selectionText
+ }
+ $canvas lower selection
+ return
+ }
+
+ # Creates an IconList widget by assembling a canvas widget and a
+ # scrollbar widget. Sets all the bindings necessary for the IconList's
+ # operations.
+ #
+ method Create {} {
+ variable hull
+ set sbar [ttk::scrollbar $hull.sbar -orient horizontal -takefocus 0]
+ catch {$sbar configure -highlightthickness 0}
+ set canvas [canvas $hull.canvas -highlightthick 0 -takefocus 1 \
+ -width 300p -height 90p \
+ -background [ttk::style lookup Treeview -background {} white]]
+ pack $sbar -side bottom -fill x -padx 1.5p -pady {0 1.5p}
+ pack $canvas -expand yes -fill both -padx 1.5p -pady {1.5p 0}
+
+ $sbar configure -command [list $canvas xview]
+ $canvas configure -xscrollcommand [list $sbar set]
+
+ # Initializes the max icon/text width and height and other variables
+ #
+ set maxIW 1
+ set maxIH 1
+ set maxTW 1
+ set maxTH 1
+ set numItems 0
+ set noScroll 1
+ set selection {}
+ set index(anchor) ""
+ set fill [ttk::style lookup Treeview -foreground {} black]
+
+ # Creates the event bindings.
+ #
+ bind $canvas <Configure> [namespace code {my WhenIdle Arrange}]
+
+ bind $canvas <Button-1> [namespace code {my Btn1 %x %y}]
+ bind $canvas <B1-Motion> [namespace code {my Motion1 %x %y}]
+ bind $canvas <B1-Leave> [namespace code {my Leave1 %x %y}]
+ bind $canvas <Control-Button-1> [namespace code {my CtrlBtn1 %x %y}]
+ bind $canvas <Shift-Button-1> [namespace code {my ShiftBtn1 %x %y}]
+ bind $canvas <B1-Enter> [list tk::CancelRepeat]
+ bind $canvas <ButtonRelease-1> [list tk::CancelRepeat]
+ bind $canvas <Double-ButtonRelease-1> \
+ [namespace code {my Double1 %x %y}]
+
+ bind $canvas <Control-B1-Motion> {;}
+ bind $canvas <Shift-B1-Motion> [namespace code {my ShiftMotion1 %x %y}]
+
+ bind $canvas <Shift-MouseWheel> [namespace code {my MouseWheel %D}]
+ bind $canvas <Option-Shift-MouseWheel> [namespace code {my MouseWheel %D -12}]
+
+
+ bind $canvas <<PrevLine>> [namespace code {my UpDown -1}]
+ bind $canvas <<NextLine>> [namespace code {my UpDown 1}]
+ bind $canvas <<PrevChar>> [namespace code {my LeftRight -1}]
+ bind $canvas <<NextChar>> [namespace code {my LeftRight 1}]
+ bind $canvas <Return> [namespace code {my ReturnKey}]
+ bind $canvas <Key> [namespace code {my KeyPress %A}]
+ bind $canvas <Alt-Key> {# nothing}
+ bind $canvas <Meta-Key> {# nothing}
+ bind $canvas <Control-Key> {# nothing}
+ bind $canvas <Command-Key> {# nothing}
+ bind $canvas <Fn-Key> {# nothing}
+
+ bind $canvas <FocusIn> [namespace code {my FocusIn}]
+ bind $canvas <FocusOut> [namespace code {my FocusOut}]
+
+ return $w
+ }
+
+ # 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.
+ #
+ method AutoScan {} {
+ if {![winfo exists $w]} return
+ set x $oldX
+ set y $oldY
+ if {$noScroll} {
+ return
+ }
+ if {$x >= [winfo width $canvas]} {
+ $canvas xview scroll 1 units
+ } elseif {$x < 0} {
+ $canvas xview scroll -1 units
+ } elseif {$y >= [winfo height $canvas]} {
+ # do nothing
+ } elseif {$y < 0} {
+ # do nothing
+ } else {
+ return
+ }
+ my Motion1 $x $y
+ set ::tk::Priv(afterId) [after 50 [namespace code {my AutoScan}]]
+ }
+
+ # ----------------------------------------------------------------------
+
+ # Event handlers
+ method MouseWheel {amount {factor -120.0}} {
+ if {$noScroll || $::tk_strictMotif} {
+ return
+ }
+ $canvas xview scroll [expr {$amount/$factor}] units
+ }
+ method Btn1 {x y} {
+ focus $canvas
+ set i [$w index @$x,$y]
+ if {$i eq ""} {
+ return
+ }
+ $w selection clear 0 end
+ $w selection set $i
+ $w selection anchor $i
+ }
+ method CtrlBtn1 {x y} {
+ if {$options(-multiple)} {
+ focus $canvas
+ set i [$w index @$x,$y]
+ if {$i eq ""} {
+ return
+ }
+ if {[$w selection includes $i]} {
+ $w selection clear $i
+ } else {
+ $w selection set $i
+ $w selection anchor $i
+ }
+ }
+ }
+ method ShiftBtn1 {x y} {
+ if {$options(-multiple)} {
+ focus $canvas
+ set i [$w index @$x,$y]
+ if {$i eq ""} {
+ return
+ }
+ if {[$w index anchor] eq ""} {
+ $w selection anchor $i
+ }
+ $w selection clear 0 end
+ $w selection set anchor $i
+ }
+ }
+
+ # Gets called on button-1 motions
+ #
+ method Motion1 {x y} {
+ set oldX $x
+ set oldY $y
+ set i [$w index @$x,$y]
+ if {$i eq ""} {
+ return
+ }
+ $w selection clear 0 end
+ $w selection set $i
+ }
+ method ShiftMotion1 {x y} {
+ set oldX $x
+ set oldY $y
+ set i [$w index @$x,$y]
+ if {$i eq ""} {
+ return
+ }
+ $w selection clear 0 end
+ $w selection set anchor $i
+ }
+ method Double1 {x y} {
+ if {[llength $selection]} {
+ $w invoke
+ }
+ }
+ method ReturnKey {} {
+ $w invoke
+ }
+ method Leave1 {x y} {
+ set oldX $x
+ set oldY $y
+ my AutoScan
+ }
+ method FocusIn {} {
+ $w state focus
+ if {![info exists list]} {
+ return
+ }
+ if {[llength $selection]} {
+ my DrawSelection
+ }
+ }
+ method FocusOut {} {
+ $w state !focus
+ $w selection clear 0 end
+ }
+
+ # Moves the active element up or down by one element
+ #
+ # Arguments:
+ # amount - +1 to move down one item, -1 to move back one item.
+ #
+ method UpDown amount {
+ if {![info exists list]} {
+ return
+ }
+ set curr [$w selection get]
+ if {[llength $curr] == 0} {
+ set i 0
+ } else {
+ set i [$w index anchor]
+ if {$i eq ""} {
+ return
+ }
+ incr i $amount
+ }
+ $w selection clear 0 end
+ $w selection set $i
+ $w selection anchor $i
+ $w see $i
+ }
+
+ # Moves the active element left or right by one column
+ #
+ # Arguments:
+ # amount - +1 to move right one column, -1 to move left one
+ # column
+ #
+ method LeftRight amount {
+ if {![info exists list]} {
+ return
+ }
+ set curr [$w selection get]
+ if {[llength $curr] == 0} {
+ set i 0
+ } else {
+ set i [$w index anchor]
+ if {$i eq ""} {
+ return
+ }
+ incr i [expr {$amount * $itemsPerColumn}]
+ }
+ $w selection clear 0 end
+ $w selection set $i
+ $w selection anchor $i
+ $w see $i
+ }
+
+ # Gets called when user enters an arbitrary key in the listbox.
+ #
+ method KeyPress key {
+ append accel $key
+ my Goto $accel
+ after cancel $accelCB
+ set accelCB [after 500 [namespace code {my Reset}]]
+ }
+
+ method Goto text {
+ if {![info exists list]} {
+ return
+ }
+ if {$text eq "" || $numItems == 0} {
+ return
+ }
+
+ if {[llength [$w selection get]]} {
+ set start [$w index anchor]
+ } else {
+ set start 0
+ }
+ set theIndex -1
+ set less 0
+ set len [string length $text]
+ set len0 [expr {$len - 1}]
+ set i $start
+
+ # Search forward until we find a filename whose prefix is a
+ # case-insensitive match with $text
+ while {1} {
+ if {[string equal -nocase -length $len0 $textList($i) $text]} {
+ set theIndex $i
+ break
+ }
+ incr i
+ if {$i == $numItems} {
+ set i 0
+ }
+ if {$i == $start} {
+ break
+ }
+ }
+
+ if {$theIndex >= 0} {
+ $w selection clear 0 end
+ $w selection set $theIndex
+ $w selection anchor $theIndex
+ $w see $theIndex
+ }
+ }
+ method Reset {} {
+ unset -nocomplain accel
+ }
+}
+
+return
+
+# Local Variables:
+# mode: tcl
+# fill-column: 78
+# End:
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/iconlist.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/icons.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/icons.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/icons.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,54 @@
+# icons.tcl --
+#
+# A set of stock icons for use in Tk dialogs. The icons used here
+# were provided by the Vimix Icon Theme project, which provides a
+# unified set of high quality icons licensed under the
+# Creative Commons Attribution Share-Alike license
+# (https://creativecommons.org/licenses/by-sa/4.0/)
+#
+# See https://github.com/vinceliuice/vimix-icon-theme
+#
+# Copyright © 2009 Pat Thoyts <patthoyts at users.sourceforge.net>
+# Copyright © 2022 Harald Oehlmann <harald.oehlmann at elmicron.de>
+# Copyright © 2022 Csaba Nemethi <csaba.nemethi at t-online.de>
+
+namespace eval ::tk::icons {}
+
+variable ::tk::svgFmt [list svg -scale [expr {[::tk::ScalingPct] / 100.0}]]
+
+image create photo ::tk::icons::error -format $::tk::svgFmt -data {
+ <?xml version="1.0" encoding="UTF-8"?>
+ <svg width="32" height="32" version="1.1" xmlns="http://www.w3.org/2000/svg">
+ <circle cx="16" cy="16" r="16" fill="#d32f2f"/>
+ <g transform="rotate(45,16,16)" fill="#fff">
+ <rect x="6" y="14" width="20" height="4"/>
+ <rect x="14" y="6" width="4" height="20"/>
+ </g>
+ </svg>
+}
+
+image create photo ::tk::icons::warning -format $::tk::svgFmt -data {
+ <?xml version="1.0" encoding="UTF-8"?>
+ <svg width="32" height="32" version="1.1" xmlns="http://www.w3.org/2000/svg">
+ <circle cx="16" cy="16" r="16" fill="#f67400"/>
+ <circle cx="16" cy="24" r="2" fill="#fff"/>
+ <path d="m14 20h4v-14h-4z" fill="#fff"/>
+ </svg>
+}
+
+image create photo ::tk::icons::information -format $::tk::svgFmt -data {
+ <?xml version="1.0" encoding="UTF-8"?>
+ <svg width="32" height="32" version="1.1" xmlns="http://www.w3.org/2000/svg">
+ <circle cx="16" cy="16" r="16" fill="#2091df"/>
+ <circle cx="16" cy="8" r="2" fill="#fff"/>
+ <path d="m14 12h4v14h-4z" fill="#fff"/>
+ </svg>
+}
+
+image create photo ::tk::icons::question -format $::tk::svgFmt -data {
+ <?xml version="1.0" encoding="UTF-8"?>
+ <svg width="32" height="32" version="1.1" xmlns="http://www.w3.org/2000/svg">
+ <circle cx="16" cy="16" r="16" fill="#5c6bc0"/>
+ <path d="m17.6 27.2h-3.2v-3.2h3.2zm3.312-12.4-1.44 1.472c-1.152 1.168-1.872 2.128-1.872 4.528h-3.2v-0.8c0-1.76 0.72-3.36 1.872-4.528l1.984-2.016a3.128 3.128 0 0 0 0.944-2.256c0-1.76-1.44-3.2-3.2-3.2s-3.2 1.44-3.2 3.2h-3.2c0-3.536 2.864-6.4 6.4-6.4s6.4 2.864 6.4 6.4c0 1.408-0.576 2.688-1.488 3.6z" fill="#fff"/>
+ </svg>
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/icons.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/README
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/images/README (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/images/README 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,7 @@
+README - images directory
+
+This directory includes images for the Tcl Logo and the Tcl Powered
+Logo. Please feel free to use the Tcl Powered Logo on any of your
+products that employ the use of Tcl or Tk. The Tcl logo may also be
+used to promote Tcl in your product documentation, web site or other
+places you so desire.
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/README
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/logo.eps
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/logo.eps
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/images/logo.eps 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/images/logo.eps 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/logo.eps
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+application/postscript
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/logo100.gif
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/logo100.gif
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/images/logo100.gif 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/images/logo100.gif 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/logo100.gif
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+image/gif
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/logo64.gif
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/logo64.gif
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/images/logo64.gif 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/images/logo64.gif 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/logo64.gif
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+image/gif
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/logoLarge.gif
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/logoLarge.gif
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/images/logoLarge.gif 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/images/logoLarge.gif 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/logoLarge.gif
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+image/gif
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/logoMed.gif
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/logoMed.gif
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/images/logoMed.gif 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/images/logoMed.gif 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/logoMed.gif
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+image/gif
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/pwrdLogo.eps
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/pwrdLogo.eps
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/images/pwrdLogo.eps 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/images/pwrdLogo.eps 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/pwrdLogo.eps
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+application/postscript
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/pwrdLogo100.gif
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/pwrdLogo100.gif
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/images/pwrdLogo100.gif 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/images/pwrdLogo100.gif 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/pwrdLogo100.gif
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+image/gif
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/pwrdLogo150.gif
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/pwrdLogo150.gif
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/images/pwrdLogo150.gif 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/images/pwrdLogo150.gif 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/pwrdLogo150.gif
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+image/gif
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/pwrdLogo175.gif
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/pwrdLogo175.gif
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/images/pwrdLogo175.gif 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/images/pwrdLogo175.gif 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/pwrdLogo175.gif
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+image/gif
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/pwrdLogo200.gif
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/pwrdLogo200.gif
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/images/pwrdLogo200.gif 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/images/pwrdLogo200.gif 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/pwrdLogo200.gif
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+image/gif
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/pwrdLogo75.gif
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/pwrdLogo75.gif
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/images/pwrdLogo75.gif 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/images/pwrdLogo75.gif 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/pwrdLogo75.gif
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+image/gif
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/tai-ku.gif
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/tai-ku.gif
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/images/tai-ku.gif 2025-02-24 10:14:00 UTC (rev 74254)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/images/tai-ku.gif 2025-02-24 13:59:26 UTC (rev 74255)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/images/tai-ku.gif
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+image/gif
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/listbox.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/listbox.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/listbox.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,522 @@
+# listbox.tcl --
+#
+# This file defines the default bindings for Tk listbox widgets
+# and provides procedures that help in implementing those bindings.
+#
+# Copyright © 1994 The Regents of the University of California.
+# Copyright © 1994-1995 Sun Microsystems, Inc.
+# Copyright © 1998 Scriptics Corporation.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+#--------------------------------------------------------------------------
+# tk::Priv elements used in this file:
+#
+# afterId - Token returned by "after" for autoscanning.
+# listboxPrev - The last element to be selected or deselected
+# during a selection operation.
+# listboxSelection - All of the items that were selected before the
+# current selection operation (such as a mouse
+# drag) started; used to cancel an operation.
+#--------------------------------------------------------------------------
+
+#-------------------------------------------------------------------------
+# The code below creates the default class bindings for listboxes.
+#-------------------------------------------------------------------------
+
+# Note: the check for existence of %W below is because this binding
+# is sometimes invoked after a window has been deleted (e.g. because
+# there is a double-click binding on the widget that deletes it). Users
+# can put "break"s in their bindings to avoid the error, but this check
+# makes that unnecessary.
+
+bind Listbox <Button-1> {
+ if {[winfo exists %W]} {
+ tk::ListboxBeginSelect %W [%W index @%x,%y] 1
+ }
+}
+
+# Ignore double clicks so that users can define their own behaviors.
+# Among other things, this prevents errors if the user deletes the
+# listbox on a double click.
+
+bind Listbox <Double-Button-1> {
+ # Empty script
+}
+
+bind Listbox <B1-Motion> {
+ set tk::Priv(x) %x
+ set tk::Priv(y) %y
+ tk::ListboxMotion %W [%W index @%x,%y]
+}
+bind Listbox <ButtonRelease-1> {
+ tk::CancelRepeat
+ %W activate @%x,%y
+}
+bind Listbox <Shift-Button-1> {
+ tk::ListboxBeginExtend %W [%W index @%x,%y]
+}
+bind Listbox <Control-Button-1> {
+ tk::ListboxBeginToggle %W [%W index @%x,%y]
+}
+bind Listbox <B1-Leave> {
+ set tk::Priv(x) %x
+ set tk::Priv(y) %y
+ tk::ListboxAutoScan %W
+}
+bind Listbox <B1-Enter> {
+ tk::CancelRepeat
+}
+
+bind Listbox <<PrevLine>> {
+ tk::ListboxUpDown %W -1
+}
+bind Listbox <<SelectPrevLine>> {
+ tk::ListboxExtendUpDown %W -1
+}
+bind Listbox <<NextLine>> {
+ tk::ListboxUpDown %W 1
+}
+bind Listbox <<SelectNextLine>> {
+ tk::ListboxExtendUpDown %W 1
+}
+bind Listbox <<PrevChar>> {
+ %W xview scroll -1 units
+}
+bind Listbox <<PrevWord>> {
+ %W xview scroll -1 pages
+}
+bind Listbox <<NextChar>> {
+ %W xview scroll 1 units
+}
+bind Listbox <<NextWord>> {
+ %W xview scroll 1 pages
+}
+bind Listbox <Prior> {
+ %W yview scroll -1 pages
+ %W activate @0,0
+}
+bind Listbox <Next> {
+ %W yview scroll 1 pages
+ %W activate @0,0
+}
+bind Listbox <Control-Prior> {
+ %W xview scroll -1 pages
+}
+bind Listbox <Control-Next> {
+ %W xview scroll 1 pages
+}
+bind Listbox <<LineStart>> {
+ %W xview moveto 0
+}
+bind Listbox <<LineEnd>> {
+ %W xview moveto 1
+}
+bind Listbox <Control-Home> {
+ %W activate 0
+ %W see 0
+ %W selection clear 0 end
+ %W selection set 0
+ tk::FireListboxSelectEvent %W
+}
+bind Listbox <Control-Shift-Home> {
+ tk::ListboxDataExtend %W 0
+}
+bind Listbox <Control-End> {
+ %W activate end
+ %W see end
+ %W selection clear 0 end
+ %W selection set end
+ tk::FireListboxSelectEvent %W
+}
+bind Listbox <Control-Shift-End> {
+ tk::ListboxDataExtend %W [%W index end]
+}
+bind Listbox <<Copy>> {
+ if {[selection own -displayof %W] eq "%W"} {
+ clipboard clear -displayof %W
+ clipboard append -displayof %W [selection get -displayof %W]
+ }
+}
+bind Listbox <space> {
+ tk::ListboxBeginSelect %W [%W index active]
+}
+bind Listbox <<Invoke>> {
+ tk::ListboxBeginSelect %W [%W index active]
+}
+bind Listbox <Select> {
+ tk::ListboxBeginSelect %W [%W index active]
+}
+bind Listbox <Control-Shift-space> {
+ tk::ListboxBeginExtend %W [%W index active]
+}
+bind Listbox <Shift-Select> {
+ tk::ListboxBeginExtend %W [%W index active]
+}
+bind Listbox <Escape> {
+ tk::ListboxCancel %W
+}
+bind Listbox <<SelectAll>> {
+ tk::ListboxSelectAll %W
+}
+bind Listbox <<SelectNone>> {
+ if {[%W cget -selectmode] ne "browse"} {
+ %W selection clear 0 end
+ tk::FireListboxSelectEvent %W
+ }
+}
+
+# Additional Tk bindings that aren't part of the Motif look and feel:
+
+bind Listbox <Button-2> {
+ %W scan mark %x %y
+}
+bind Listbox <B2-Motion> {
+ %W scan dragto %x %y
+}
+bind Listbox <MouseWheel> {
+ tk::MouseWheel %W y %D -40.0 units
+}
+bind Listbox <Option-MouseWheel> {
+ tk::MouseWheel %W y %D -12.0 units
+}
+bind Listbox <Shift-MouseWheel> {
+ tk::MouseWheel %W x %D -40.0 units
+}
+bind Listbox <Shift-Option-MouseWheel> {
+ tk::MouseWheel %W x %D -12.0 units
+}
+bind Listbox <TouchpadScroll> {
+ if {%# %% 5 == 0} {
+ lassign [tk::PreciseScrollDeltas %D] tk::Priv(deltaX) tk::Priv(deltaY)
+ if {$tk::Priv(deltaX) != 0} {
+ %W xview scroll [expr {-$tk::Priv(deltaX)}] units
+ }
+ if {$tk::Priv(deltaY) != 0} {
+ %W yview scroll [expr {-$tk::Priv(deltaY)}] units
+ }
+ }
+}
+
+# ::tk::ListboxBeginSelect --
+#
+# 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 ::tk::ListboxBeginSelect {w el {focus 1}} {
+ variable ::tk::Priv
+ if {[$w cget -selectmode] eq "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 Priv(listboxSelection) {}
+ set Priv(listboxPrev) $el
+ }
+ tk::FireListboxSelectEvent $w
+ # check existence as ListboxSelect may destroy us
+ if {$focus && [winfo exists $w] && [$w cget -state] eq "normal"} {
+ focus $w
+ }
+}
+
+# ::tk::ListboxMotion --
+#
+# 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 ::tk::ListboxMotion {w el} {
+ variable ::tk::Priv
+ if {$el == $Priv(listboxPrev)} {
+ return
+ }
+ set anchor [$w index anchor]
+ switch [$w cget -selectmode] {
+ browse {
+ $w selection clear 0 end
+ $w selection set $el
+ set Priv(listboxPrev) $el
+ tk::FireListboxSelectEvent $w
+ }
+ extended {
+ set i $Priv(listboxPrev)
+ if {$i < 0} {
+ set i $el
+ $w selection set $el
+ }
+ 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
+ }
+ if {![info exists Priv(listboxSelection)]} {
+ set Priv(listboxSelection) [$w curselection]
+ }
+ while {($i < $el) && ($i < $anchor)} {
+ if {$i in $Priv(listboxSelection)} {
+ $w selection set $i
+ }
+ incr i
+ }
+ while {($i > $el) && ($i > $anchor)} {
+ if {$i in $Priv(listboxSelection)} {
+ $w selection set $i
+ }
+ incr i -1
+ }
+ set Priv(listboxPrev) $el
+ tk::FireListboxSelectEvent $w
+ }
+ }
+}
+
+# ::tk::ListboxBeginExtend --
+#
+# 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 ::tk::ListboxBeginExtend {w el} {
+ if {[$w cget -selectmode] eq "extended"} {
+ if {[$w selection includes anchor]} {
+ ListboxMotion $w $el
+ } else {
+ # No selection yet; simulate the begin-select operation.
+ ListboxBeginSelect $w $el
+ }
+ }
+}
+
+# ::tk::ListboxBeginToggle --
+#
+# 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 ::tk::ListboxBeginToggle {w el} {
+ variable ::tk::Priv
+ if {[$w cget -selectmode] eq "extended"} {
+ set Priv(listboxSelection) [$w curselection]
+ set Priv(listboxPrev) $el
+ $w selection anchor $el
+ if {[$w selection includes $el]} {
+ $w selection clear $el
+ } else {
+ $w selection set $el
+ }
+ tk::FireListboxSelectEvent $w
+ }
+}
+
+# ::tk::ListboxAutoScan --
+# 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 ::tk::ListboxAutoScan {w} {
+ variable ::tk::Priv
+ if {![winfo exists $w]} return
+ set x $Priv(x)
+ set y $Priv(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
+ }
+ ListboxMotion $w [$w index @$x,$y]
+ set Priv(afterId) [after 50 [list tk::ListboxAutoScan $w]]
+}
+
+# ::tk::ListboxUpDown --
+#
+# 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 ::tk::ListboxUpDown {w amount} {
+ variable ::tk::Priv
+ $w activate [expr {[$w index active] + $amount}]
+ $w see active
+ switch [$w cget -selectmode] {
+ browse {
+ $w selection clear 0 end
+ $w selection set active
+ tk::FireListboxSelectEvent $w
+ }
+ extended {
+ $w selection clear 0 end
+ $w selection set active
+ $w selection anchor active
+ set Priv(listboxPrev) [$w index active]
+ set Priv(listboxSelection) {}
+ tk::FireListboxSelectEvent $w
+ }
+ }
+}
+
+# ::tk::ListboxExtendUpDown --
+#
+# 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 ::tk::ListboxExtendUpDown {w amount} {
+ variable ::tk::Priv
+ if {[$w cget -selectmode] ne "extended"} {
+ return
+ }
+ set active [$w index active]
+ if {![info exists Priv(listboxSelection)]} {
+ $w selection set $active
+ set Priv(listboxSelection) [$w curselection]
+ }
+ $w activate [expr {$active + $amount}]
+ $w see active
+ ListboxMotion $w [$w index active]
+}
+
+# ::tk::ListboxDataExtend
+#
+# 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 ::tk::ListboxDataExtend {w el} {
+ set mode [$w cget -selectmode]
+ if {$mode eq "extended"} {
+ $w activate $el
+ $w see $el
+ if {[$w selection includes anchor]} {
+ ListboxMotion $w $el
+ }
+ } elseif {$mode eq "multiple"} {
+ $w activate $el
+ $w see $el
+ }
+}
+
+# ::tk::ListboxCancel
+#
+# 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 ::tk::ListboxCancel w {
+ variable ::tk::Priv
+ if {[$w cget -selectmode] ne "extended"} {
+ return
+ }
+ set first [$w index anchor]
+ set last $Priv(listboxPrev)
+ if {$last < 0} {
+ # Not actually doing any selection right now
+ return
+ }
+ if {$first > $last} {
+ set tmp $first
+ set first $last
+ set last $tmp
+ }
+ $w selection clear $first $last
+ while {$first <= $last} {
+ if {$first in $Priv(listboxSelection)} {
+ $w selection set $first
+ }
+ incr first
+ }
+ tk::FireListboxSelectEvent $w
+}
+
+# ::tk::ListboxSelectAll
+#
+# 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 ::tk::ListboxSelectAll w {
+ set mode [$w cget -selectmode]
+ if {$mode eq "single" || $mode eq "browse"} {
+ $w selection clear 0 end
+ $w selection set active
+ } else {
+ $w selection set 0 end
+ }
+ tk::FireListboxSelectEvent $w
+}
+
+# ::tk::FireListboxSelectEvent
+#
+# Fire the <<ListboxSelect>> event if the listbox is not in disabled
+# state.
+#
+# Arguments:
+# w - The listbox widget.
+
+proc ::tk::FireListboxSelectEvent w {
+ if {[$w cget -state] eq "normal"} {
+ event generate $w <<ListboxSelect>>
+ }
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/listbox.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/megawidget.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/megawidget.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/megawidget.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,297 @@
+# megawidget.tcl
+#
+# Basic megawidget support classes. Experimental for any use other than
+# the ::tk::IconList megawdget, which is itself only designed for use in
+# the Unix file dialogs.
+#
+# Copyright © 2009-2010 Donal K. Fellows
+#
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+
+package require tk
+
+::oo::class create ::tk::Megawidget {
+ superclass ::oo::class
+ method unknown {w args} {
+ if {[string match .* $w]} {
+ [self] create $w {*}$args
+ return $w
+ }
+ next $w {*}$args
+ }
+ unexport new unknown
+ self method create {name superclasses body} {
+ next $name [list \
+ superclass ::tk::MegawidgetClass {*}$superclasses]\;$body
+ }
+}
+
+::oo::class create ::tk::MegawidgetClass {
+ variable w hull options IdleCallbacks
+ constructor args {
+ # Extract the "widget name" from the object name
+ set w [namespace tail [self]]
+
+ # Configure things
+ tclParseConfigSpec [my varname options] [my GetSpecs] "" $args
+
+ # Move the object out of the way of the hull widget
+ rename [self] _tmp
+
+ # Make the hull widget(s)
+ my CreateHull
+ bind $hull <Destroy> [list [namespace which my] destroy]
+
+ # Rename things into their final places
+ rename ::$w theWidget
+ rename [self] ::$w
+
+ # Make the contents
+ my Create
+ }
+ destructor {
+ foreach {name cb} [array get IdleCallbacks] {
+ after cancel $cb
+ unset IdleCallbacks($name)
+ }
+ if {[winfo exists $w]} {
+ bind $hull <Destroy> {}
+ destroy $w
+ }
+ }
+
+ ####################################################################
+ #
+ # MegawidgetClass::configure --
+ #
+ # Implementation of 'configure' for megawidgets. Emulates the operation
+ # of the standard Tk configure method fairly closely, which makes things
+ # substantially more complex than they otherwise would be.
+ #
+ # This method assumes that the 'GetSpecs' method returns a description
+ # of all the specifications of the options (i.e., as Tk returns except
+ # with the actual values removed). It also assumes that the 'options'
+ # array in the class holds all options; it is up to subclasses to set
+ # traces on that array if they want to respond to configuration changes.
+ #
+ # TODO: allow unambiguous abbreviations.
+ #
+ method configure args {
+ # Configure behaves differently depending on the number of arguments
+ set argc [llength $args]
+ if {$argc == 0} {
+ return [lmap spec [my GetSpecs] {
+ lappend spec $options([lindex $spec 0])
+ }]
+ } elseif {$argc == 1} {
+ set opt [lindex $args 0]
+ if {[info exists options($opt)]} {
+ set spec [lsearch -inline -index 0 -exact [my GetSpecs] $opt]
+ return [linsert $spec end $options($opt)]
+ }
+ } elseif {$argc == 2} {
+ # Special case for where we're setting a single option. This
+ # avoids some of the costly operations. We still do the [array
+ # get] as this gives a sufficiently-consistent trace.
+ set opt [lindex $args 0]
+ if {[dict exists [array get options] $opt]} {
+ # Actually set the new value of the option. Use a catch to
+ # allow a megawidget user to throw an error from a write trace
+ # on the options array to reject invalid values.
+ try {
+ array set options $args
+ } on error {ret info} {
+ # Rethrow the error to get a clean stack trace
+ return -code error -errorcode [dict get $info -errorcode] $ret
+ }
+ return
+ }
+ } elseif {$argc % 2 == 0} {
+ # Check that all specified options exist. Any unknown option will
+ # cause the merged dictionary to be bigger than the options array
+ set merge [dict merge [array get options] $args]
+ if {[dict size $merge] == [array size options]} {
+ # Actually set the new values of the options. Use a catch to
+ # allow a megawidget user to throw an error from a write trace
+ # on the options array to reject invalid values
+ try {
+ array set options $args
+ } on error {ret info} {
+ # Rethrow the error to get a clean stack trace
+ return -code error -errorcode [dict get $info -errorcode] $ret
+ }
+ return
+ }
+ # Due to the order of the merge, the unknown options will be at
+ # the end of the dict. This makes the first unknown option easy to
+ # find.
+ set opt [lindex [dict keys $merge] [array size options]]
+ } else {
+ set opt [lindex $args end]
+ return -code error -errorcode [list TK VALUE_MISSING] \
+ "value for \"$opt\" missing"
+ }
+ return -code error -errorcode [list TK LOOKUP OPTION $opt] \
+ "bad option \"$opt\": must be [tclListValidFlags options]"
+ }
+
+ ####################################################################
+ #
+ # MegawidgetClass::cget --
+ #
+ # Implementation of 'cget' for megawidgets. Emulates the operation of
+ # the standard Tk cget method fairly closely.
+ #
+ # This method assumes that the 'options' array in the class holds all
+ # options; it is up to subclasses to set traces on that array if they
+ # want to respond to configuration reads.
+ #
+ # TODO: allow unambiguous abbreviations.
+ #
+ method cget option {
+ return $options($option)
+ }
+
+ ####################################################################
+ #
+ # MegawidgetClass::TraceOption --
+ #
+ # Sets up the tracing of an element of the options variable.
+ #
+ method TraceOption {option method args} {
+ set callback [list my $method {*}$args]
+ trace add variable options($option) write [namespace code $callback]
+ }
+
+ ####################################################################
+ #
+ # MegawidgetClass::GetSpecs --
+ #
+ # Return a list of descriptions of options supported by this
+ # megawidget. Each option is described by the 4-tuple list, consisting
+ # of the name of the option, the "option database" name, the "option
+ # database" class-name, and the default value of the option. These are
+ # the same values returned by calling the configure method of a widget,
+ # except without the current values of the options.
+ #
+ method GetSpecs {} {
+ return {
+ {-takefocus takeFocus TakeFocus {}}
+ }
+ }
+
+ ####################################################################
+ #
+ # MegawidgetClass::CreateHull --
+ #
+ # Creates the real main widget of the megawidget. This is often a frame
+ # or toplevel widget, but isn't always (lightweight megawidgets might
+ # use a content widget directly).
+ #
+ # The name of the hull widget is given by the 'w' instance variable. The
+ # name should be written into the 'hull' instance variable. The command
+ # created by this method will be renamed.
+ #
+ method CreateHull {} {
+ return -code error -errorcode {TCL OO ABSTRACT_METHOD} \
+ "method must be overridden"
+ }
+
+ ####################################################################
+ #
+ # MegawidgetClass::Create --
+ #
+ # Creates the content of the megawidget. The name of the widget to
+ # create the content in will be in the 'hull' instance variable.
+ #
+ method Create {} {
+ return -code error -errorcode {TCL OO ABSTRACT_METHOD} \
+ "method must be overridden"
+ }
+
+ ####################################################################
+ #
+ # MegawidgetClass::WhenIdle --
+ #
+ # Arrange for a method to be called on the current instance when Tk is
+ # idle. Only one such method call per method will be queued; subsequent
+ # queuing actions before the callback fires will be silently ignored.
+ # The additional args will be passed to the callback, and the callbacks
+ # will be properly cancelled if the widget is destroyed.
+ #
+ method WhenIdle {method args} {
+ if {![info exists IdleCallbacks($method)]} {
+ set IdleCallbacks($method) [after idle [list \
+ [namespace which my] DoWhenIdle $method $args]]
+ }
+ }
+ method DoWhenIdle {method arguments} {
+ unset IdleCallbacks($method)
+ tailcall my $method {*}$arguments
+ }
+}
+
+####################################################################
+#
+# tk::SimpleWidget --
+#
+# Simple megawidget class that makes it easy create widgets that behave
+# like a ttk widget. It creates the hull as a ttk::frame and maps the
+# state manipulation methods of the overall megawidget to the equivalent
+# operations on the ttk::frame.
+#
+::tk::Megawidget create ::tk::SimpleWidget {} {
+ variable w hull options
+ method GetSpecs {} {
+ return {
+ {-cursor cursor Cursor {}}
+ {-takefocus takeFocus TakeFocus {}}
+ }
+ }
+ method CreateHull {} {
+ set hull [::ttk::frame $w -cursor $options(-cursor)]
+ my TraceOption -cursor UpdateCursorOption
+ }
+ method UpdateCursorOption args {
+ $hull configure -cursor $options(-cursor)
+ }
+ # Not fixed names, so can't forward
+ method state args {
+ tailcall $hull state {*}$args
+ }
+ method instate args {
+ tailcall $hull instate {*}$args
+ }
+}
+
+####################################################################
+#
+# tk::FocusableWidget --
+#
+# Simple megawidget class that makes a ttk-like widget that has a focus
+# ring.
+#
+::tk::Megawidget create ::tk::FocusableWidget ::tk::SimpleWidget {
+ variable w hull options
+ method GetSpecs {} {
+ return {
+ {-cursor cursor Cursor {}}
+ {-takefocus takeFocus TakeFocus ::ttk::takefocus}
+ }
+ }
+ method CreateHull {} {
+ ttk::frame $w
+ set hull [ttk::entry $w.cHull -takefocus 0 -cursor $options(-cursor)]
+ pack $hull -expand yes -fill both -ipadx 1.5p -ipady 1.5p
+ my TraceOption -cursor UpdateCursorOption
+ }
+}
+
+return
+
+# Local Variables:
+# mode: tcl
+# fill-column: 78
+# End:
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/megawidget.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/menu.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/menu.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/menu.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,1372 @@
+# 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.
+#
+# Copyright © 1992-1994 The Regents of the University of California.
+# Copyright © 1994-1997 Sun Microsystems, Inc.
+# Copyright © 1998-1999 Scriptics Corporation.
+# Copyright © 2007 Daniel A. Steffen <das at users.sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+
+#-------------------------------------------------------------------------
+# Elements of tk::Priv 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 tk::Priv(oldGrab): if
+# tk::Priv(oldGrab) is non-empty, then tk::Priv(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 <<MenuSelect>> virtual event.
+# activeItem - This is the last active menu item for
+# use with the <<MenuSelect>> 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
+# tk::Priv(postedMb) identifies the posted menubutton.
+# 2. As a torn-off menu copied from some other menu. In this style
+# tk::Priv(postedMb) is empty, and menu's type is "tearoff".
+# 3. As an option menu, triggered from an option menubutton. In this
+# style tk::Priv(postedMb) identifies the posted menubutton.
+# 4. As a popup menu. In this style tk::Priv(postedMb) is empty and
+# the top-level menu's type is "normal".
+# 5. As a pulldown from a menubar. The variable tk::Priv(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 <FocusIn> {}
+bind Menubutton <Enter> {
+ tk::MbEnter %W
+}
+bind Menubutton <Leave> {
+ tk::MbLeave %W
+}
+bind Menubutton <Button-1> {
+ if {$tk::Priv(inMenubutton) ne ""} {
+ tk::MbPost $tk::Priv(inMenubutton) %X %Y
+ }
+}
+bind Menubutton <Motion> {
+ tk::MbMotion %W up %X %Y
+}
+bind Menubutton <B1-Motion> {
+ tk::MbMotion %W down %X %Y
+}
+bind Menubutton <ButtonRelease-1> {
+ tk::MbButtonUp %W
+}
+bind Menubutton <space> {
+ tk::MbPost %W
+ tk::MenuFirstEntry [%W cget -menu]
+}
+bind Menubutton <<Invoke>> {
+ tk::MbPost %W
+ tk::MenuFirstEntry [%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 <FocusIn> {}
+
+bind Menu <Enter> {
+ set tk::Priv(window) %W
+ if {[%W cget -type] eq "tearoff"} {
+ if {"%m" ne "NotifyUngrab"} {
+ if {[tk windowingsystem] eq "x11"} {
+ tk_menuSetFocus %W
+ }
+ }
+ }
+ tk::MenuMotion %W %x %y %s
+}
+
+bind Menu <Leave> {
+ tk::MenuLeave %W %X %Y %s
+}
+bind Menu <Motion> {
+ tk::MenuMotion %W %x %y %s
+}
+bind Menu <Button> {
+ tk::MenuButtonDown %W
+}
+bind Menu <ButtonRelease> {
+ tk::MenuInvoke %W 1
+}
+bind Menu <space> {
+ tk::MenuInvoke %W 0
+}
+bind Menu <<Invoke>> {
+ tk::MenuInvoke %W 0
+}
+bind Menu <Return> {
+ tk::MenuInvoke %W 0
+}
+bind Menu <Escape> {
+ tk::MenuEscape %W
+}
+bind Menu <<PrevChar>> {
+ tk::MenuLeftArrow %W
+}
+bind Menu <<NextChar>> {
+ tk::MenuRightArrow %W
+}
+bind Menu <<PrevLine>> {
+ tk::MenuUpArrow %W
+}
+bind Menu <<NextLine>> {
+ tk::MenuDownArrow %W
+}
+bind Menu <Key> {
+ tk::TraverseWithinMenu %W %A
+ break
+}
+
+# The following bindings apply to all windows, and are used to
+# implement keyboard menu traversal.
+
+if {[tk windowingsystem] eq "x11"} {
+ bind all <Alt-Key> {
+ tk::TraverseToMenu %W %A
+ }
+
+ bind all <F10> {
+ tk::FirstMenu %W
+ }
+} else {
+ bind Menubutton <Alt-Key> {
+ tk::TraverseToMenu %W %A
+ }
+
+ bind Menubutton <F10> {
+ tk::FirstMenu %W
+ }
+}
+
+# ::tk::MbEnter --
+# 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 ::tk::MbB1Enter is invoked if the button is down.
+#
+# Arguments:
+# w - The name of the widget.
+
+proc ::tk::MbEnter w {
+ variable ::tk::Priv
+
+ if {$Priv(inMenubutton) ne ""} {
+ MbLeave $Priv(inMenubutton)
+ }
+ set Priv(inMenubutton) $w
+ if {[$w cget -state] ne "disabled" && [tk windowingsystem] ne "aqua"} {
+ $w configure -state active
+ }
+}
+
+# ::tk::MbLeave --
+# 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 ::tk::MbLeave w {
+ variable ::tk::Priv
+
+ set Priv(inMenubutton) {}
+ if {![winfo exists $w]} {
+ return
+ }
+ if {[$w cget -state] eq "active" && [tk windowingsystem] ne "aqua"} {
+ $w configure -state normal
+ }
+}
+
+
+# ::tk::MbPost --
+# 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 ::tk::MbPost {w {x {}} {y {}}} {
+ global errorInfo
+ variable ::tk::Priv
+
+ if {[$w cget -state] eq "disabled" || $w eq $Priv(postedMb)} {
+ return
+ }
+ set menu [$w cget -menu]
+ if {$menu eq ""} {
+ return
+ }
+ set tearoff [expr {[tk windowingsystem] eq "x11" \
+ || [$menu cget -type] eq "tearoff"}]
+ if {[string first $w $menu] != 0} {
+ return -code error -errorcode {TK MENUBUTTON POST_NONCHILD} \
+ "can't post $menu: it isn't a descendant of $w"
+ }
+ set cur $Priv(postedMb)
+ if {$cur ne ""} {
+ MenuUnpost {}
+ }
+ if {$::tk_strictMotif} {
+ set Priv(cursor) [$w cget -cursor]
+ $w configure -cursor arrow
+ }
+ if {[tk windowingsystem] ne "aqua"} {
+ set Priv(relief) [$w cget -relief]
+ $w configure -relief raised
+ } else {
+ $w configure -state active
+ }
+
+ set Priv(postedMb) $w
+ set Priv(focus) [focus]
+ $menu activate {}
+ GenerateMenuSelect $menu
+ update idletasks
+
+ if {[catch {PostMenubuttonMenu $w $menu $x $y} msg opt]} {
+ # Error posting menu (e.g. bogus -postcommand). Unpost it and
+ # reflect the error.
+ MenuUnpost {}
+ return -options $opt $msg
+ }
+
+ set Priv(tearoff) $tearoff
+ if {$tearoff != 0 && [tk windowingsystem] ne "aqua"} {
+ focus $menu
+ if {[winfo viewable $w]} {
+ SaveGrabInfo $w
+ grab -global $w
+ }
+ }
+}
+
+# ::tk::MenuUnpost --
+# 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 ::tk::MenuUnpost menu {
+ variable ::tk::Priv
+ set mb $Priv(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 $Priv(focus)}
+ set Priv(focus) ""
+
+ # Unpost menu(s) and restore some stuff that's dependent on
+ # what was posted.
+
+ after cancel [array get Priv menuActivatedTimer]
+ unset -nocomplain Priv(menuActivated)
+ after cancel [array get Priv menuDeactivatedTimer]
+ unset -nocomplain Priv(menuDeactivated)
+
+ catch {
+ if {$mb ne ""} {
+ set menu [$mb cget -menu]
+ $menu unpost
+ set Priv(postedMb) {}
+ if {$::tk_strictMotif} {
+ $mb configure -cursor $Priv(cursor)
+ }
+ if {[tk windowingsystem] ne "aqua"} {
+ $mb configure -relief $Priv(relief)
+ } else {
+ $mb configure -state normal
+ }
+ } elseif {$Priv(popup) ne ""} {
+ $Priv(popup) unpost
+ set Priv(popup) {}
+ } elseif {[$menu cget -type] ne "menubar" && [$menu cget -type] ne "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] ne "Menu" || ![winfo ismapped $parent]} {
+ break
+ }
+ $parent activate {}
+ $parent postcascade {}
+ GenerateMenuSelect $parent
+ set type [$parent cget -type]
+ if {$type eq "menubar" || $type eq "tearoff"} {
+ break
+ }
+ set menu $parent
+ }
+ if {[$menu cget -type] ne "menubar"} {
+ $menu unpost
+ }
+ }
+ }
+
+ if {($Priv(tearoff) != 0) || $Priv(menuBar) ne ""} {
+ # Release grab, if any, and restore the previous grab, if there
+ # was one.
+ if {$menu ne ""} {
+ set grab [grab current $menu]
+ if {$grab ne ""} {
+ grab release $grab
+ }
+ }
+ RestoreOldGrab
+ if {$Priv(menuBar) ne ""} {
+ if {$::tk_strictMotif} {
+ $Priv(menuBar) configure -cursor $Priv(cursor)
+ }
+ set Priv(menuBar) {}
+ }
+ if {[tk windowingsystem] ne "x11"} {
+ set Priv(tearoff) 0
+ }
+ }
+}
+
+# ::tk::MbMotion --
+# 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 ::tk::MbMotion {w upDown rootx rooty} {
+ variable ::tk::Priv
+
+ if {$Priv(inMenubutton) eq $w} {
+ return
+ }
+ set new [winfo containing $rootx $rooty]
+ if {$new ne $Priv(inMenubutton) \
+ && ($new eq "" || [winfo toplevel $new] eq [winfo toplevel $w])} {
+ if {$Priv(inMenubutton) ne ""} {
+ MbLeave $Priv(inMenubutton)
+ }
+ if {$new ne "" \
+ && [winfo class $new] eq "Menubutton" \
+ && ([$new cget -indicatoron] == 0) \
+ && ([$w cget -indicatoron] == 0)} {
+ if {$upDown eq "down"} {
+ MbPost $new $rootx $rooty
+ } else {
+ MbEnter $new
+ }
+ }
+ }
+}
+
+# ::tk::MbButtonUp --
+# 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 ::tk::MbButtonUp w {
+ variable ::tk::Priv
+
+ set menu [$w cget -menu]
+ set tearoff [expr {[tk windowingsystem] eq "x11" || \
+ ($menu ne "" && [$menu cget -type] eq "tearoff")}]
+ if {($tearoff != 0) && $Priv(postedMb) eq $w \
+ && $Priv(inMenubutton) eq $w} {
+ MenuFirstEntry [$Priv(postedMb) cget -menu]
+ } else {
+ MenuUnpost {}
+ }
+}
+
+# ::tk::MenuMotion --
+# 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 ::tk::MenuMotion {menu x y state} {
+ variable ::tk::Priv
+ if {$menu eq $Priv(window)} {
+ set activeindex [$menu index active]
+ if {[$menu cget -type] eq "menubar"} {
+ if {[info exists Priv(focus)] && $menu ne $Priv(focus)} {
+ $menu activate @$x,$y
+ GenerateMenuSelect $menu
+ }
+ } else {
+ $menu activate @$x,$y
+ GenerateMenuSelect $menu
+ }
+ set index [$menu index @$x,$y]
+ if {[info exists Priv(menuActivated)] \
+ && $index >= 0 \
+ && $index ne $activeindex} {
+ set mode [option get $menu clickToFocus ClickToFocus]
+ if {[string is false $mode]} {
+ set delay [expr {[$menu cget -type] eq "menubar" ? 0 : 50}]
+ if {[$menu type $index] eq "cascade"} {
+ # Catch these postcascade commands since the menu could be
+ # destroyed before they run.
+ set Priv(menuActivatedTimer) \
+ [after $delay [list catch [list \
+ $menu postcascade active]]]
+ } else {
+ set Priv(menuDeactivatedTimer) \
+ [after $delay [list catch [list
+ $menu postcascade {}]]]
+ }
+ }
+ }
+ }
+}
+
+# ::tk::MenuButtonDown --
+# 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 ::tk::MenuButtonDown menu {
+ variable ::tk::Priv
+
+ if {![winfo viewable $menu]} {
+ return
+ }
+ if {[$menu index active] < 0} {
+ if {[$menu cget -type] ne "menubar" } {
+ set Priv(window) {}
+ }
+ return
+ }
+ $menu postcascade active
+ if {$Priv(postedMb) ne "" && [winfo viewable $Priv(postedMb)]} {
+ grab -global $Priv(postedMb)
+ } else {
+ while {[$menu cget -type] eq "normal" \
+ && [winfo class [winfo parent $menu]] eq "Menu" \
+ && [winfo ismapped [winfo parent $menu]]} {
+ set menu [winfo parent $menu]
+ }
+
+ if {$Priv(menuBar) eq {}} {
+ set Priv(menuBar) $menu
+ if {$::tk_strictMotif} {
+ set Priv(cursor) [$menu cget -cursor]
+ $menu configure -cursor arrow
+ }
+ if {[$menu type active] eq "cascade"} {
+ set Priv(menuActivated) 1
+ }
+ }
+
+ # 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 ne [grab current $menu]} {
+ SaveGrabInfo $menu
+ }
+
+ # Must re-grab even if the grab window hasn't changed, in order
+ # to release the implicit grab from the button press.
+
+ if {[tk windowingsystem] eq "x11"} {
+ grab -global $menu
+ }
+ }
+}
+
+# ::tk::MenuLeave --
+# 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 ::tk::MenuLeave {menu rootx rooty state} {
+ variable ::tk::Priv
+ set Priv(window) {}
+ if {[$menu index active] < 0} {
+ return
+ }
+ if {[$menu type active] eq "cascade" \
+ && [winfo containing $rootx $rooty] eq \
+ [$menu entrycget active -menu]} {
+ return
+ }
+ $menu activate {}
+ GenerateMenuSelect $menu
+}
+
+# ::tk::MenuInvoke --
+# 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 ::tk::MenuInvoke {w buttonRelease} {
+ variable ::tk::Priv
+
+ if {$buttonRelease && $Priv(window) eq ""} {
+ # 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 {}
+ $w activate {}
+ event generate $w <<MenuSelect>>
+ MenuUnpost $w
+ return
+ }
+ if {[$w type active] eq "cascade"} {
+ $w postcascade active
+ set menu [$w entrycget active -menu]
+ MenuFirstEntry $menu
+ } elseif {[$w type active] eq "tearoff"} {
+ ::tk::TearOffMenu $w
+ MenuUnpost $w
+ } elseif {[$w cget -type] eq "menubar"} {
+ $w postcascade {}
+ set activeindex [$w index active]
+ set isCascade [string equal [$w type $activeindex] "cascade"]
+
+ # Only de-activate the active item if it's a cascade; this prevents
+ # the annoying "activation flicker" you otherwise get with
+ # checkbuttons/commands/etc. on menubars
+
+ if { $isCascade } {
+ $w activate {}
+ event generate $w <<MenuSelect>>
+ }
+
+ MenuUnpost $w
+
+ # If the active item is not a cascade, invoke it. This enables
+ # the use of checkbuttons/commands/etc. on menubars (which is legal,
+ # but not recommended)
+
+ if { !$isCascade } {
+ uplevel #0 [list $w invoke $activeindex]
+ }
+ } else {
+ if {$Priv(popup) eq "" || [$w index active] >= 0} {
+ MenuUnpost $w
+ }
+ uplevel #0 [list $w invoke active]
+ }
+}
+
+# ::tk::MenuEscape --
+# 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 ::tk::MenuEscape menu {
+ set parent [winfo parent $menu]
+ if {[winfo class $parent] ne "Menu"} {
+ MenuUnpost $menu
+ } elseif {[$parent cget -type] eq "menubar"} {
+ MenuUnpost $menu
+ RestoreOldGrab
+ } else {
+ MenuNextMenu $menu left
+ }
+}
+
+# The following routines handle arrow keys. Arrow keys behave
+# differently depending on whether the menu is a menu bar or not.
+
+proc ::tk::MenuUpArrow {menu} {
+ if {[$menu cget -type] eq "menubar"} {
+ MenuNextMenu $menu left
+ } else {
+ MenuNextEntry $menu -1
+ }
+}
+
+proc ::tk::MenuDownArrow {menu} {
+ if {[$menu cget -type] eq "menubar"} {
+ MenuNextMenu $menu right
+ } else {
+ MenuNextEntry $menu 1
+ }
+}
+
+proc ::tk::MenuLeftArrow {menu} {
+ if {[$menu cget -type] eq "menubar"} {
+ MenuNextEntry $menu -1
+ } else {
+ MenuNextMenu $menu left
+ }
+}
+
+proc ::tk::MenuRightArrow {menu} {
+ if {[$menu cget -type] eq "menubar"} {
+ MenuNextEntry $menu 1
+ } else {
+ MenuNextMenu $menu right
+ }
+}
+
+# ::tk::MenuNextMenu --
+# 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 ::tk::MenuNextMenu {menu direction} {
+ variable ::tk::Priv
+
+ # First handle traversals into and out of cascaded menus.
+
+ if {$direction eq "right"} {
+ set count 1
+ set parent [winfo parent $menu]
+ set class [winfo class $parent]
+ if {[$menu type active] eq "cascade"} {
+ $menu postcascade active
+ set m2 [$menu entrycget active -menu]
+ if {$m2 ne ""} {
+ MenuFirstEntry $m2
+ }
+ return
+ } else {
+ set parent [winfo parent $menu]
+ while {$parent ne "."} {
+ if {[winfo class $parent] eq "Menu" \
+ && [$parent cget -type] eq "menubar"} {
+ tk_menuSetFocus $parent
+ MenuNextEntry $parent 1
+ return
+ }
+ set parent [winfo parent $parent]
+ }
+ }
+ } else {
+ set count -1
+ set m2 [winfo parent $menu]
+ if {[winfo class $m2] eq "Menu"} {
+ $menu activate {}
+ GenerateMenuSelect $menu
+ tk_menuSetFocus $m2
+
+ $m2 postcascade {}
+
+ if {[$m2 cget -type] ne "menubar"} {
+ 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] eq "Menu" && [$m2 cget -type] eq "menubar"} {
+ tk_menuSetFocus $m2
+ MenuNextEntry $m2 -1
+ return
+ }
+
+ set w $Priv(postedMb)
+ if {$w eq ""} {
+ 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] eq "Menubutton" \
+ && [$mb cget -state] ne "disabled" \
+ && [$mb cget -menu] ne "" \
+ && [[$mb cget -menu] index last] >= 0} {
+ break
+ }
+ if {$mb eq $w} {
+ return
+ }
+ incr i $count
+ }
+ MbPost $mb
+ MenuFirstEntry [$mb cget -menu]
+}
+
+# ::tk::MenuNextEntry --
+# 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 ::tk::MenuNextEntry {menu count} {
+ set last [$menu index last]
+ if {$last < 0} {
+ return
+ }
+ set length [expr {$last+1}]
+ set quitAfter $length
+ set activeindex [$menu index active]
+ if {$activeindex < 0} {
+ set i 0
+ } else {
+ set i [expr {$activeindex + $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 ne "disabled" && \
+ ($i!=0 || [$menu cget -type] ne "tearoff" \
+ || [$menu type 0] ne "tearoff")} {
+ break
+ }
+ }
+ if {$i == $activeindex} {
+ return
+ }
+ incr i $count
+ incr quitAfter -1
+ }
+ $menu activate $i
+ GenerateMenuSelect $menu
+
+ if {[$menu type $i] eq "cascade" && [$menu cget -type] eq "menubar"} {
+ set cascade [$menu entrycget $i -menu]
+ if {$cascade ne ""} {
+ # Here we auto-post a cascade. This is necessary when
+ # we traverse left/right in the menubar, but undesirable when
+ # we traverse up/down in a menu.
+ $menu postcascade $i
+ MenuFirstEntry $cascade
+ }
+ }
+}
+
+# ::tk::MenuFind --
+# 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 ::tk::MenuFind {w char} {
+ set char [string tolower $char]
+ set windowlist [winfo child $w]
+
+ foreach child $windowlist {
+ # Don't descend into other toplevels.
+ if {[winfo toplevel $w] ne [winfo toplevel $child]} {
+ continue
+ }
+ if {[winfo class $child] eq "Menu" && \
+ [$child cget -type] eq "menubar"} {
+ if {$char eq ""} {
+ return $child
+ }
+ set last [$child index last]
+ for {set i [$child cget -tearoff]} {$i <= $last} {incr i} {
+ if {([$child type $i] eq "separator") || ([$child entrycget $i -state] eq "disabled")} {
+ continue
+ }
+ set underline [$child entrycget $i -underline]
+ if {$underline >= 0} {
+ if {$char eq [string tolower [string index [$child entrycget $i -label] $underline]]} {
+ return $child
+ }
+ }
+ }
+ }
+ }
+
+ foreach child $windowlist {
+ # Don't descend into other toplevels.
+ if {[winfo toplevel $w] ne [winfo toplevel $child]} {
+ continue
+ }
+ switch -- [winfo class $child] {
+ Menubutton {
+ set char2 [string index [$child cget -text] \
+ [$child cget -underline]]
+ if {$char eq [string tolower $char2] || $char eq ""} {
+ if {[$child cget -state] ne "disabled"} {
+ return $child
+ }
+ }
+ }
+
+ default {
+ set match [MenuFind $child $char]
+ if {$match ne ""} {
+ return $match
+ }
+ }
+ }
+ }
+ return {}
+}
+
+# ::tk::TraverseToMenu --
+# 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 ::tk::TraverseToMenu {w char} {
+ variable ::tk::Priv
+ if {![winfo exists $w] || $char eq ""} {
+ return
+ }
+ while {[winfo class $w] eq "Menu"} {
+ if {[$w cget -type] eq "menubar"} {
+ break
+ } elseif {$Priv(postedMb) eq ""} {
+ return
+ }
+ set w [winfo parent $w]
+ }
+ set w [MenuFind [winfo toplevel $w] $char]
+ if {$w ne ""} {
+ if {[winfo class $w] eq "Menu"} {
+ tk_menuSetFocus $w
+ set Priv(window) $w
+ SaveGrabInfo $w
+ grab -global $w
+ TraverseWithinMenu $w $char
+ } else {
+ MbPost $w
+ MenuFirstEntry [$w cget -menu]
+ }
+ }
+}
+
+# ::tk::FirstMenu --
+# 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 ::tk::FirstMenu w {
+ variable ::tk::Priv
+ set w [MenuFind [winfo toplevel $w] ""]
+ if {$w ne ""} {
+ if {[winfo class $w] eq "Menu"} {
+ tk_menuSetFocus $w
+ set Priv(window) $w
+ SaveGrabInfo $w
+ grab -global $w
+ MenuFirstEntry $w
+ } else {
+ MbPost $w
+ MenuFirstEntry [$w cget -menu]
+ }
+ }
+}
+
+# ::tk::TraverseWithinMenu
+# 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 ::tk::TraverseWithinMenu {w char} {
+ if {$char eq ""} {
+ return
+ }
+ set char [string tolower $char]
+ set last [$w index last]
+ for {set i 0} {$i <= $last} {incr i} {
+ if {[catch {set char2 [string index \
+ [$w entrycget $i -label] [$w entrycget $i -underline]]}]} {
+ continue
+ }
+ if {$char eq [string tolower $char2]} {
+ if {[$w type $i] eq "cascade"} {
+ $w activate $i
+ $w postcascade active
+ event generate $w <<MenuSelect>>
+ set m2 [$w entrycget $i -menu]
+ if {$m2 ne ""} {
+ MenuFirstEntry $m2
+ }
+ } else {
+ MenuUnpost $w
+ uplevel #0 [list $w invoke $i]
+ }
+ return
+ }
+ }
+}
+
+# ::tk::MenuFirstEntry --
+# 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 tk::PostOverPoint) 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 ::tk::MenuFirstEntry menu {
+ if {$menu eq ""} {
+ return
+ }
+ tk_menuSetFocus $menu
+ if {[$menu index active] >= 0} {
+ return
+ }
+ set last [$menu index last]
+ for {set i 0} {$i <= $last} {incr i} {
+ if {([catch {set state [$menu entrycget $i -state]}] == 0) \
+ && $state ne "disabled" && [$menu type $i] ne "tearoff"} {
+ $menu activate $i
+ GenerateMenuSelect $menu
+ # Only post the cascade if the current menu is a menubar;
+ # otherwise, if the first entry of the cascade is a cascade,
+ # we can get an annoying cascading effect resulting in a bunch of
+ # menus getting posted (bug 676)
+ if {[$menu type $i] eq "cascade" && [$menu cget -type] eq "menubar"} {
+ set cascade [$menu entrycget $i -menu]
+ if {$cascade ne ""} {
+ $menu postcascade $i
+ MenuFirstEntry $cascade
+ }
+ }
+ return
+ }
+ }
+}
+
+# ::tk::MenuFindName --
+# 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 ::tk::MenuFindName {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]
+ for {set i 0} {$i <= $last} {incr i} {
+ if {![catch {$menu entrycget $i -label} label]} {
+ if {$label eq $s} {
+ return $i
+ }
+ }
+ }
+ return ""
+}
+
+# ::tk::PostMenubuttonMenu --
+#
+# Given a menubutton and a menu, this procedure posts the menu at the
+# appropriate location. If the menubutton looks like an option
+# menubutton, meaning that the indicator is on and the direction is
+# neither above nor below, then the menu is posted so that the current
+# entry is vertically aligned with the menubutton. On the Mac this
+# will expose a small amount of the blue indicator on the right hand
+# side. On other platforms the entry is centered over the button.
+
+if {[tk windowingsystem] eq "aqua"} {
+ proc ::tk::PostMenubuttonMenu {button menu cx cy} {
+ set entry ""
+ if {[$button cget -indicatoron]} {
+ set entry [MenuFindName $menu [$button cget -text]]
+ if {$entry eq ""} {
+ set entry 0
+ }
+ }
+ set x [winfo rootx $button]
+ set y [expr {2 + [winfo rooty $button]}]
+ switch [$button cget -direction] {
+ above {
+ set entry ""
+ incr y [expr {4 - [winfo reqheight $menu]}]
+ }
+ below {
+ set entry ""
+ incr y [expr {2 + [winfo height $button]}]
+ }
+ left {
+ incr x [expr {-[winfo reqwidth $menu]}]
+ }
+ right {
+ incr x [winfo width $button]
+ }
+ default { # flush
+ incr x [expr {[winfo width $button] - [winfo reqwidth $menu] - 5}]
+ }
+ }
+ PostOverPoint $menu $x $y $entry
+ }
+} else {
+ proc ::tk::PostMenubuttonMenu {button menu cx cy} {
+ set entry ""
+ if {[$button cget -indicatoron]} {
+ set entry [MenuFindName $menu [$button cget -text]]
+ if {$entry eq ""} {
+ set entry 0
+ }
+ }
+ set x [winfo rootx $button]
+ set y [winfo rooty $button]
+ switch [$button cget -direction] {
+ above {
+ incr y [expr {-[winfo reqheight $menu]}]
+ # if we go offscreen to the top, show as 'below'
+ if {$y < [winfo vrooty $button]} {
+ set y [expr {[winfo vrooty $button] + [winfo rooty $button]\
+ + [winfo reqheight $button]}]
+ }
+ set entry {}
+ }
+ below {
+ incr y [winfo height $button]
+ # if we go offscreen to the bottom, show as 'above'
+ set mh [winfo reqheight $menu]
+ if {($y + $mh) > ([winfo vrooty $button] + [winfo vrootheight $button])} {
+ set y [expr {[winfo vrooty $button] + [winfo vrootheight $button] \
+ + [winfo rooty $button] - $mh}]
+ }
+ set entry {}
+ }
+ left {
+ incr x [expr {- [winfo reqwidth $menu]}]
+ }
+ right {
+ incr x [expr {[winfo width $button]}]
+ }
+ default { # flush
+ if {[$button cget -indicatoron]} {
+ if {$cx ne ""} {
+ set x [expr {$cx - [winfo reqwidth $menu] / 2}]
+ set l [font metrics [$menu cget -font] -linespace]
+ set y [expr {$cy - $l/2 - 2}]
+ } else {
+ incr x [expr {([winfo width $button] - \
+ [winfo reqwidth $menu])/ 2}]
+ }
+ } else {
+ incr y [winfo height $button]
+ }
+ }
+ }
+ PostOverPoint $menu $x $y $entry
+ }
+}
+
+# ::tk::PostOverPoint --
+#
+# This procedure posts a menu on the screen so that a given entry in
+# the menu is positioned with its upper left corner at a given point
+# in the root window. The procedure also activates that entry. If no
+# entry is specified the upper left corner of the entire menu is
+# placed at the point.
+#
+# 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).
+
+if {[tk windowingsystem] ne "win32"} {
+ proc ::tk::PostOverPoint {menu x y {entry {}}} {
+ if {$entry ne ""} {
+ $menu post $x $y $entry
+ if {[$menu type $entry] ni {separator tearoff} &&
+ [$menu entrycget $entry -state] ne "disabled"} {
+ $menu activate $entry
+ GenerateMenuSelect $menu
+ }
+ } else {
+ $menu post $x $y
+ }
+ return
+ }
+} else {
+ proc ::tk::PostOverPoint {menu x y {entry {}}} {
+ if {$entry ne ""} {
+ incr y [expr {-[$menu yposition $entry]}]
+ }
+ # osVersion is not available in safe interps
+ set ver 5
+ if {[info exists ::tcl_platform(osVersion)]} {
+ scan $::tcl_platform(osVersion) %d ver
+ }
+
+ # We need to fix some problems with menu posting on Windows,
+ # where, if the menu would overlap top or bottom of screen,
+ # Windows puts it in the wrong place for us. We must also
+ # subtract an extra amount for half the height of the current
+ # entry. To be safe we subtract an extra 10.
+ # NOTE: this issue appears to have been resolved in the Window
+ # manager provided with Vista and Windows 7.
+ if {$ver < 6} {
+ set yoffset [expr {[winfo screenheight $menu] \
+ - $y - [winfo reqheight $menu] - 10}]
+ if {$yoffset < [winfo vrooty $menu]} {
+ # The bottom of the menu is offscreen, so adjust upwards
+ incr y [expr {$yoffset - [winfo vrooty $menu]}]
+ }
+ # If we're off the top of the screen (either because we were
+ # originally or because we just adjusted too far upwards),
+ # then make the menu popup on the top edge.
+ if {$y < [winfo vrooty $menu]} {
+ set y [winfo vrooty $menu]
+ }
+ }
+ $menu post $x $y
+ if {$entry ne "" && [$menu entrycget $entry -state] ne "disabled"} {
+ $menu activate $entry
+ GenerateMenuSelect $menu
+ }
+ }
+}
+
+# ::tk::SaveGrabInfo --
+# Sets the variables tk::Priv(oldGrab) and tk::Priv(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 tk::SaveGrabInfo w {
+ variable ::tk::Priv
+ set Priv(oldGrab) [grab current $w]
+ if {$Priv(oldGrab) ne ""} {
+ set Priv(grabStatus) [grab status $Priv(oldGrab)]
+ }
+}
+
+# ::tk::RestoreOldGrab --
+# Restores the grab to what it was before TkSaveGrabInfo was called.
+#
+
+proc ::tk::RestoreOldGrab {} {
+ variable ::tk::Priv
+
+ if {$Priv(oldGrab) ne ""} {
+ # Be careful restoring the old grab, since it's window may not
+ # be visible anymore.
+
+ catch {
+ if {$Priv(grabStatus) eq "global"} {
+ grab set -global $Priv(oldGrab)
+ } else {
+ grab set $Priv(oldGrab)
+ }
+ }
+ set Priv(oldGrab) ""
+ }
+}
+
+proc ::tk_menuSetFocus {menu} {
+ variable ::tk::Priv
+ if {![info exists Priv(focus)] || $Priv(focus) eq ""} {
+ set Priv(focus) [focus]
+ }
+ focus $menu
+}
+
+proc ::tk::GenerateMenuSelect {menu} {
+ variable ::tk::Priv
+
+ if {$Priv(activeMenu) ne $menu \
+ || $Priv(activeItem) ne [$menu index active]} {
+ set Priv(activeMenu) $menu
+ set Priv(activeItem) [$menu index active]
+ event generate $menu <<MenuSelect>>
+ }
+}
+
+# ::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 {}}} {
+ variable ::tk::Priv
+ if {$Priv(popup) ne "" || $Priv(postedMb) ne ""} {
+ tk::MenuUnpost {}
+ }
+ tk::PostOverPoint $menu $x $y $entry
+ if {[tk windowingsystem] eq "x11" && [winfo viewable $menu]} {
+ tk::SaveGrabInfo $menu
+ grab -global $menu
+ set Priv(popup) $menu
+ set Priv(window) $menu
+ set Priv(menuActivated) 1
+ tk_menuSetFocus $menu
+ }
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/menu.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/mkpsenc.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/mkpsenc.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/mkpsenc.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,1488 @@
+# mkpsenc.tcl --
+#
+# This file generates the postscript prolog used by Tk.
+
+namespace eval ::tk {
+ # Creates Postscript encoding vector for ISO-8859-1 (could theoretically
+ # handle any 8-bit encoding, but Tk never generates characters outside
+ # ASCII).
+ #
+ proc CreatePostscriptEncoding {} {
+ variable psglyphs
+ # Now check for known. Even if it is known, it can be other than we
+ # need. GhostScript seems to be happy with such approach
+ set result "\[\n"
+ for {set i 0} {$i<256} {incr i 8} {
+ for {set j 0} {$j<8} {incr j} {
+ set enc [encoding convertfrom "iso8859-1" \
+ [format %c [expr {$i+$j}]]]
+ catch {
+ set hexcode {}
+ set hexcode [format %04X [scan $enc %c]]
+ }
+ if {[info exists psglyphs($hexcode)]} {
+ append result "/$psglyphs($hexcode)"
+ } else {
+ append result "/space"
+ }
+ }
+ append result "\n"
+ }
+ append result "\]"
+ return $result
+ }
+
+ # List of adobe glyph names. Converted from glyphlist.txt, downloaded from
+ # Adobe.
+
+ variable psglyphs
+ array set psglyphs {
+ 0020 space
+ 0021 exclam
+ 0022 quotedbl
+ 0023 numbersign
+ 0024 dollar
+ 0025 percent
+ 0026 ampersand
+ 0027 quotesingle
+ 0028 parenleft
+ 0029 parenright
+ 002A asterisk
+ 002B plus
+ 002C comma
+ 002D hyphen
+ 002E period
+ 002F slash
+ 0030 zero
+ 0031 one
+ 0032 two
+ 0033 three
+ 0034 four
+ 0035 five
+ 0036 six
+ 0037 seven
+ 0038 eight
+ 0039 nine
+ 003A colon
+ 003B semicolon
+ 003C less
+ 003D equal
+ 003E greater
+ 003F question
+ 0040 at
+ 0041 A
+ 0042 B
+ 0043 C
+ 0044 D
+ 0045 E
+ 0046 F
+ 0047 G
+ 0048 H
+ 0049 I
+ 004A J
+ 004B K
+ 004C L
+ 004D M
+ 004E N
+ 004F O
+ 0050 P
+ 0051 Q
+ 0052 R
+ 0053 S
+ 0054 T
+ 0055 U
+ 0056 V
+ 0057 W
+ 0058 X
+ 0059 Y
+ 005A Z
+ 005B bracketleft
+ 005C backslash
+ 005D bracketright
+ 005E asciicircum
+ 005F underscore
+ 0060 grave
+ 0061 a
+ 0062 b
+ 0063 c
+ 0064 d
+ 0065 e
+ 0066 f
+ 0067 g
+ 0068 h
+ 0069 i
+ 006A j
+ 006B k
+ 006C l
+ 006D m
+ 006E n
+ 006F o
+ 0070 p
+ 0071 q
+ 0072 r
+ 0073 s
+ 0074 t
+ 0075 u
+ 0076 v
+ 0077 w
+ 0078 x
+ 0079 y
+ 007A z
+ 007B braceleft
+ 007C bar
+ 007D braceright
+ 007E asciitilde
+ 00A0 space
+ 00A1 exclamdown
+ 00A2 cent
+ 00A3 sterling
+ 00A4 currency
+ 00A5 yen
+ 00A6 brokenbar
+ 00A7 section
+ 00A8 dieresis
+ 00A9 copyright
+ 00AA ordfeminine
+ 00AB guillemotleft
+ 00AC logicalnot
+ 00AD hyphen
+ 00AE registered
+ 00AF macron
+ 00B0 degree
+ 00B1 plusminus
+ 00B2 twosuperior
+ 00B3 threesuperior
+ 00B4 acute
+ 00B5 mu
+ 00B6 paragraph
+ 00B7 periodcentered
+ 00B8 cedilla
+ 00B9 onesuperior
+ 00BA ordmasculine
+ 00BB guillemotright
+ 00BC onequarter
+ 00BD onehalf
+ 00BE threequarters
+ 00BF questiondown
+ 00C0 Agrave
+ 00C1 Aacute
+ 00C2 Acircumflex
+ 00C3 Atilde
+ 00C4 Adieresis
+ 00C5 Aring
+ 00C6 AE
+ 00C7 Ccedilla
+ 00C8 Egrave
+ 00C9 Eacute
+ 00CA Ecircumflex
+ 00CB Edieresis
+ 00CC Igrave
+ 00CD Iacute
+ 00CE Icircumflex
+ 00CF Idieresis
+ 00D0 Eth
+ 00D1 Ntilde
+ 00D2 Ograve
+ 00D3 Oacute
+ 00D4 Ocircumflex
+ 00D5 Otilde
+ 00D6 Odieresis
+ 00D7 multiply
+ 00D8 Oslash
+ 00D9 Ugrave
+ 00DA Uacute
+ 00DB Ucircumflex
+ 00DC Udieresis
+ 00DD Yacute
+ 00DE Thorn
+ 00DF germandbls
+ 00E0 agrave
+ 00E1 aacute
+ 00E2 acircumflex
+ 00E3 atilde
+ 00E4 adieresis
+ 00E5 aring
+ 00E6 ae
+ 00E7 ccedilla
+ 00E8 egrave
+ 00E9 eacute
+ 00EA ecircumflex
+ 00EB edieresis
+ 00EC igrave
+ 00ED iacute
+ 00EE icircumflex
+ 00EF idieresis
+ 00F0 eth
+ 00F1 ntilde
+ 00F2 ograve
+ 00F3 oacute
+ 00F4 ocircumflex
+ 00F5 otilde
+ 00F6 odieresis
+ 00F7 divide
+ 00F8 oslash
+ 00F9 ugrave
+ 00FA uacute
+ 00FB ucircumflex
+ 00FC udieresis
+ 00FD yacute
+ 00FE thorn
+ 00FF ydieresis
+ 0100 Amacron
+ 0101 amacron
+ 0102 Abreve
+ 0103 abreve
+ 0104 Aogonek
+ 0105 aogonek
+ 0106 Cacute
+ 0107 cacute
+ 0108 Ccircumflex
+ 0109 ccircumflex
+ 010A Cdotaccent
+ 010B cdotaccent
+ 010C Ccaron
+ 010D ccaron
+ 010E Dcaron
+ 010F dcaron
+ 0110 Dcroat
+ 0111 dcroat
+ 0112 Emacron
+ 0113 emacron
+ 0114 Ebreve
+ 0115 ebreve
+ 0116 Edotaccent
+ 0117 edotaccent
+ 0118 Eogonek
+ 0119 eogonek
+ 011A Ecaron
+ 011B ecaron
+ 011C Gcircumflex
+ 011D gcircumflex
+ 011E Gbreve
+ 011F gbreve
+ 0120 Gdotaccent
+ 0121 gdotaccent
+ 0122 Gcommaaccent
+ 0123 gcommaaccent
+ 0124 Hcircumflex
+ 0125 hcircumflex
+ 0126 Hbar
+ 0127 hbar
+ 0128 Itilde
+ 0129 itilde
+ 012A Imacron
+ 012B imacron
+ 012C Ibreve
+ 012D ibreve
+ 012E Iogonek
+ 012F iogonek
+ 0130 Idotaccent
+ 0131 dotlessi
+ 0132 IJ
+ 0133 ij
+ 0134 Jcircumflex
+ 0135 jcircumflex
+ 0136 Kcommaaccent
+ 0137 kcommaaccent
+ 0138 kgreenlandic
+ 0139 Lacute
+ 013A lacute
+ 013B Lcommaaccent
+ 013C lcommaaccent
+ 013D Lcaron
+ 013E lcaron
+ 013F Ldot
+ 0140 ldot
+ 0141 Lslash
+ 0142 lslash
+ 0143 Nacute
+ 0144 nacute
+ 0145 Ncommaaccent
+ 0146 ncommaaccent
+ 0147 Ncaron
+ 0148 ncaron
+ 0149 napostrophe
+ 014A Eng
+ 014B eng
+ 014C Omacron
+ 014D omacron
+ 014E Obreve
+ 014F obreve
+ 0150 Ohungarumlaut
+ 0151 ohungarumlaut
+ 0152 OE
+ 0153 oe
+ 0154 Racute
+ 0155 racute
+ 0156 Rcommaaccent
+ 0157 rcommaaccent
+ 0158 Rcaron
+ 0159 rcaron
+ 015A Sacute
+ 015B sacute
+ 015C Scircumflex
+ 015D scircumflex
+ 015E Scedilla
+ 015F scedilla
+ 0160 Scaron
+ 0161 scaron
+ 0162 Tcommaaccent
+ 0163 tcommaaccent
+ 0164 Tcaron
+ 0165 tcaron
+ 0166 Tbar
+ 0167 tbar
+ 0168 Utilde
+ 0169 utilde
+ 016A Umacron
+ 016B umacron
+ 016C Ubreve
+ 016D ubreve
+ 016E Uring
+ 016F uring
+ 0170 Uhungarumlaut
+ 0171 uhungarumlaut
+ 0172 Uogonek
+ 0173 uogonek
+ 0174 Wcircumflex
+ 0175 wcircumflex
+ 0176 Ycircumflex
+ 0177 ycircumflex
+ 0178 Ydieresis
+ 0179 Zacute
+ 017A zacute
+ 017B Zdotaccent
+ 017C zdotaccent
+ 017D Zcaron
+ 017E zcaron
+ 017F longs
+ 0192 florin
+ 01A0 Ohorn
+ 01A1 ohorn
+ 01AF Uhorn
+ 01B0 uhorn
+ 01E6 Gcaron
+ 01E7 gcaron
+ 01FA Aringacute
+ 01FB aringacute
+ 01FC AEacute
+ 01FD aeacute
+ 01FE Oslashacute
+ 01FF oslashacute
+ 0218 Scommaaccent
+ 0219 scommaaccent
+ 021A Tcommaaccent
+ 021B tcommaaccent
+ 02BC afii57929
+ 02BD afii64937
+ 02C6 circumflex
+ 02C7 caron
+ 02C9 macron
+ 02D8 breve
+ 02D9 dotaccent
+ 02DA ring
+ 02DB ogonek
+ 02DC tilde
+ 02DD hungarumlaut
+ 0300 gravecomb
+ 0301 acutecomb
+ 0303 tildecomb
+ 0309 hookabovecomb
+ 0323 dotbelowcomb
+ 0384 tonos
+ 0385 dieresistonos
+ 0386 Alphatonos
+ 0387 anoteleia
+ 0388 Epsilontonos
+ 0389 Etatonos
+ 038A Iotatonos
+ 038C Omicrontonos
+ 038E Upsilontonos
+ 038F Omegatonos
+ 0390 iotadieresistonos
+ 0391 Alpha
+ 0392 Beta
+ 0393 Gamma
+ 0394 Delta
+ 0395 Epsilon
+ 0396 Zeta
+ 0397 Eta
+ 0398 Theta
+ 0399 Iota
+ 039A Kappa
+ 039B Lambda
+ 039C Mu
+ 039D Nu
+ 039E Xi
+ 039F Omicron
+ 03A0 Pi
+ 03A1 Rho
+ 03A3 Sigma
+ 03A4 Tau
+ 03A5 Upsilon
+ 03A6 Phi
+ 03A7 Chi
+ 03A8 Psi
+ 03A9 Omega
+ 03AA Iotadieresis
+ 03AB Upsilondieresis
+ 03AC alphatonos
+ 03AD epsilontonos
+ 03AE etatonos
+ 03AF iotatonos
+ 03B0 upsilondieresistonos
+ 03B1 alpha
+ 03B2 beta
+ 03B3 gamma
+ 03B4 delta
+ 03B5 epsilon
+ 03B6 zeta
+ 03B7 eta
+ 03B8 theta
+ 03B9 iota
+ 03BA kappa
+ 03BB lambda
+ 03BC mu
+ 03BD nu
+ 03BE xi
+ 03BF omicron
+ 03C0 pi
+ 03C1 rho
+ 03C2 sigma1
+ 03C3 sigma
+ 03C4 tau
+ 03C5 upsilon
+ 03C6 phi
+ 03C7 chi
+ 03C8 psi
+ 03C9 omega
+ 03CA iotadieresis
+ 03CB upsilondieresis
+ 03CC omicrontonos
+ 03CD upsilontonos
+ 03CE omegatonos
+ 03D1 theta1
+ 03D2 Upsilon1
+ 03D5 phi1
+ 03D6 omega1
+ 0401 afii10023
+ 0402 afii10051
+ 0403 afii10052
+ 0404 afii10053
+ 0405 afii10054
+ 0406 afii10055
+ 0407 afii10056
+ 0408 afii10057
+ 0409 afii10058
+ 040A afii10059
+ 040B afii10060
+ 040C afii10061
+ 040E afii10062
+ 040F afii10145
+ 0410 afii10017
+ 0411 afii10018
+ 0412 afii10019
+ 0413 afii10020
+ 0414 afii10021
+ 0415 afii10022
+ 0416 afii10024
+ 0417 afii10025
+ 0418 afii10026
+ 0419 afii10027
+ 041A afii10028
+ 041B afii10029
+ 041C afii10030
+ 041D afii10031
+ 041E afii10032
+ 041F afii10033
+ 0420 afii10034
+ 0421 afii10035
+ 0422 afii10036
+ 0423 afii10037
+ 0424 afii10038
+ 0425 afii10039
+ 0426 afii10040
+ 0427 afii10041
+ 0428 afii10042
+ 0429 afii10043
+ 042A afii10044
+ 042B afii10045
+ 042C afii10046
+ 042D afii10047
+ 042E afii10048
+ 042F afii10049
+ 0430 afii10065
+ 0431 afii10066
+ 0432 afii10067
+ 0433 afii10068
+ 0434 afii10069
+ 0435 afii10070
+ 0436 afii10072
+ 0437 afii10073
+ 0438 afii10074
+ 0439 afii10075
+ 043A afii10076
+ 043B afii10077
+ 043C afii10078
+ 043D afii10079
+ 043E afii10080
+ 043F afii10081
+ 0440 afii10082
+ 0441 afii10083
+ 0442 afii10084
+ 0443 afii10085
+ 0444 afii10086
+ 0445 afii10087
+ 0446 afii10088
+ 0447 afii10089
+ 0448 afii10090
+ 0449 afii10091
+ 044A afii10092
+ 044B afii10093
+ 044C afii10094
+ 044D afii10095
+ 044E afii10096
+ 044F afii10097
+ 0451 afii10071
+ 0452 afii10099
+ 0453 afii10100
+ 0454 afii10101
+ 0455 afii10102
+ 0456 afii10103
+ 0457 afii10104
+ 0458 afii10105
+ 0459 afii10106
+ 045A afii10107
+ 045B afii10108
+ 045C afii10109
+ 045E afii10110
+ 045F afii10193
+ 0462 afii10146
+ 0463 afii10194
+ 0472 afii10147
+ 0473 afii10195
+ 0474 afii10148
+ 0475 afii10196
+ 0490 afii10050
+ 0491 afii10098
+ 04D9 afii10846
+ 05B0 afii57799
+ 05B1 afii57801
+ 05B2 afii57800
+ 05B3 afii57802
+ 05B4 afii57793
+ 05B5 afii57794
+ 05B6 afii57795
+ 05B7 afii57798
+ 05B8 afii57797
+ 05B9 afii57806
+ 05BB afii57796
+ 05BC afii57807
+ 05BD afii57839
+ 05BE afii57645
+ 05BF afii57841
+ 05C0 afii57842
+ 05C1 afii57804
+ 05C2 afii57803
+ 05C3 afii57658
+ 05D0 afii57664
+ 05D1 afii57665
+ 05D2 afii57666
+ 05D3 afii57667
+ 05D4 afii57668
+ 05D5 afii57669
+ 05D6 afii57670
+ 05D7 afii57671
+ 05D8 afii57672
+ 05D9 afii57673
+ 05DA afii57674
+ 05DB afii57675
+ 05DC afii57676
+ 05DD afii57677
+ 05DE afii57678
+ 05DF afii57679
+ 05E0 afii57680
+ 05E1 afii57681
+ 05E2 afii57682
+ 05E3 afii57683
+ 05E4 afii57684
+ 05E5 afii57685
+ 05E6 afii57686
+ 05E7 afii57687
+ 05E8 afii57688
+ 05E9 afii57689
+ 05EA afii57690
+ 05F0 afii57716
+ 05F1 afii57717
+ 05F2 afii57718
+ 060C afii57388
+ 061B afii57403
+ 061F afii57407
+ 0621 afii57409
+ 0622 afii57410
+ 0623 afii57411
+ 0624 afii57412
+ 0625 afii57413
+ 0626 afii57414
+ 0627 afii57415
+ 0628 afii57416
+ 0629 afii57417
+ 062A afii57418
+ 062B afii57419
+ 062C afii57420
+ 062D afii57421
+ 062E afii57422
+ 062F afii57423
+ 0630 afii57424
+ 0631 afii57425
+ 0632 afii57426
+ 0633 afii57427
+ 0634 afii57428
+ 0635 afii57429
+ 0636 afii57430
+ 0637 afii57431
+ 0638 afii57432
+ 0639 afii57433
+ 063A afii57434
+ 0640 afii57440
+ 0641 afii57441
+ 0642 afii57442
+ 0643 afii57443
+ 0644 afii57444
+ 0645 afii57445
+ 0646 afii57446
+ 0647 afii57470
+ 0648 afii57448
+ 0649 afii57449
+ 064A afii57450
+ 064B afii57451
+ 064C afii57452
+ 064D afii57453
+ 064E afii57454
+ 064F afii57455
+ 0650 afii57456
+ 0651 afii57457
+ 0652 afii57458
+ 0660 afii57392
+ 0661 afii57393
+ 0662 afii57394
+ 0663 afii57395
+ 0664 afii57396
+ 0665 afii57397
+ 0666 afii57398
+ 0667 afii57399
+ 0668 afii57400
+ 0669 afii57401
+ 066A afii57381
+ 066D afii63167
+ 0679 afii57511
+ 067E afii57506
+ 0686 afii57507
+ 0688 afii57512
+ 0691 afii57513
+ 0698 afii57508
+ 06A4 afii57505
+ 06AF afii57509
+ 06BA afii57514
+ 06D2 afii57519
+ 06D5 afii57534
+ 1E80 Wgrave
+ 1E81 wgrave
+ 1E82 Wacute
+ 1E83 wacute
+ 1E84 Wdieresis
+ 1E85 wdieresis
+ 1EF2 Ygrave
+ 1EF3 ygrave
+ 200C afii61664
+ 200D afii301
+ 200E afii299
+ 200F afii300
+ 2012 figuredash
+ 2013 endash
+ 2014 emdash
+ 2015 afii00208
+ 2017 underscoredbl
+ 2018 quoteleft
+ 2019 quoteright
+ 201A quotesinglbase
+ 201B quotereversed
+ 201C quotedblleft
+ 201D quotedblright
+ 201E quotedblbase
+ 2020 dagger
+ 2021 daggerdbl
+ 2022 bullet
+ 2024 onedotenleader
+ 2025 twodotenleader
+ 2026 ellipsis
+ 202C afii61573
+ 202D afii61574
+ 202E afii61575
+ 2030 perthousand
+ 2032 minute
+ 2033 second
+ 2039 guilsinglleft
+ 203A guilsinglright
+ 203C exclamdbl
+ 2044 fraction
+ 2070 zerosuperior
+ 2074 foursuperior
+ 2075 fivesuperior
+ 2076 sixsuperior
+ 2077 sevensuperior
+ 2078 eightsuperior
+ 2079 ninesuperior
+ 207D parenleftsuperior
+ 207E parenrightsuperior
+ 207F nsuperior
+ 2080 zeroinferior
+ 2081 oneinferior
+ 2082 twoinferior
+ 2083 threeinferior
+ 2084 fourinferior
+ 2085 fiveinferior
+ 2086 sixinferior
+ 2087 seveninferior
+ 2088 eightinferior
+ 2089 nineinferior
+ 208D parenleftinferior
+ 208E parenrightinferior
+ 20A1 colonmonetary
+ 20A3 franc
+ 20A4 lira
+ 20A7 peseta
+ 20AA afii57636
+ 20AB dong
+ 20AC Euro
+ 2105 afii61248
+ 2111 Ifraktur
+ 2113 afii61289
+ 2116 afii61352
+ 2118 weierstrass
+ 211C Rfraktur
+ 211E prescription
+ 2122 trademark
+ 2126 Omega
+ 212E estimated
+ 2135 aleph
+ 2153 onethird
+ 2154 twothirds
+ 215B oneeighth
+ 215C threeeighths
+ 215D fiveeighths
+ 215E seveneighths
+ 2190 arrowleft
+ 2191 arrowup
+ 2192 arrowright
+ 2193 arrowdown
+ 2194 arrowboth
+ 2195 arrowupdn
+ 21A8 arrowupdnbse
+ 21B5 carriagereturn
+ 21D0 arrowdblleft
+ 21D1 arrowdblup
+ 21D2 arrowdblright
+ 21D3 arrowdbldown
+ 21D4 arrowdblboth
+ 2200 universal
+ 2202 partialdiff
+ 2203 existential
+ 2205 emptyset
+ 2206 Delta
+ 2207 gradient
+ 2208 element
+ 2209 notelement
+ 220B suchthat
+ 220F product
+ 2211 summation
+ 2212 minus
+ 2215 fraction
+ 2217 asteriskmath
+ 2219 periodcentered
+ 221A radical
+ 221D proportional
+ 221E infinity
+ 221F orthogonal
+ 2220 angle
+ 2227 logicaland
+ 2228 logicalor
+ 2229 intersection
+ 222A union
+ 222B integral
+ 2234 therefore
+ 223C similar
+ 2245 congruent
+ 2248 approxequal
+ 2260 notequal
+ 2261 equivalence
+ 2264 lessequal
+ 2265 greaterequal
+ 2282 propersubset
+ 2283 propersuperset
+ 2284 notsubset
+ 2286 reflexsubset
+ 2287 reflexsuperset
+ 2295 circleplus
+ 2297 circlemultiply
+ 22A5 perpendicular
+ 22C5 dotmath
+ 2302 house
+ 2310 revlogicalnot
+ 2320 integraltp
+ 2321 integralbt
+ 2329 angleleft
+ 232A angleright
+ 2500 SF100000
+ 2502 SF110000
+ 250C SF010000
+ 2510 SF030000
+ 2514 SF020000
+ 2518 SF040000
+ 251C SF080000
+ 2524 SF090000
+ 252C SF060000
+ 2534 SF070000
+ 253C SF050000
+ 2550 SF430000
+ 2551 SF240000
+ 2552 SF510000
+ 2553 SF520000
+ 2554 SF390000
+ 2555 SF220000
+ 2556 SF210000
+ 2557 SF250000
+ 2558 SF500000
+ 2559 SF490000
+ 255A SF380000
+ 255B SF280000
+ 255C SF270000
+ 255D SF260000
+ 255E SF360000
+ 255F SF370000
+ 2560 SF420000
+ 2561 SF190000
+ 2562 SF200000
+ 2563 SF230000
+ 2564 SF470000
+ 2565 SF480000
+ 2566 SF410000
+ 2567 SF450000
+ 2568 SF460000
+ 2569 SF400000
+ 256A SF540000
+ 256B SF530000
+ 256C SF440000
+ 2580 upblock
+ 2584 dnblock
+ 2588 block
+ 258C lfblock
+ 2590 rtblock
+ 2591 ltshade
+ 2592 shade
+ 2593 dkshade
+ 25A0 filledbox
+ 25A1 H22073
+ 25AA H18543
+ 25AB H18551
+ 25AC filledrect
+ 25B2 triagup
+ 25BA triagrt
+ 25BC triagdn
+ 25C4 triaglf
+ 25CA lozenge
+ 25CB circle
+ 25CF H18533
+ 25D8 invbullet
+ 25D9 invcircle
+ 25E6 openbullet
+ 263A smileface
+ 263B invsmileface
+ 263C sun
+ 2640 female
+ 2642 male
+ 2660 spade
+ 2663 club
+ 2665 heart
+ 2666 diamond
+ 266A musicalnote
+ 266B musicalnotedbl
+ F6BE dotlessj
+ F6BF LL
+ F6C0 ll
+ F6C1 Scedilla
+ F6C2 scedilla
+ F6C3 commaaccent
+ F6C4 afii10063
+ F6C5 afii10064
+ F6C6 afii10192
+ F6C7 afii10831
+ F6C8 afii10832
+ F6C9 Acute
+ F6CA Caron
+ F6CB Dieresis
+ F6CC DieresisAcute
+ F6CD DieresisGrave
+ F6CE Grave
+ F6CF Hungarumlaut
+ F6D0 Macron
+ F6D1 cyrBreve
+ F6D2 cyrFlex
+ F6D3 dblGrave
+ F6D4 cyrbreve
+ F6D5 cyrflex
+ F6D6 dblgrave
+ F6D7 dieresisacute
+ F6D8 dieresisgrave
+ F6D9 copyrightserif
+ F6DA registerserif
+ F6DB trademarkserif
+ F6DC onefitted
+ F6DD rupiah
+ F6DE threequartersemdash
+ F6DF centinferior
+ F6E0 centsuperior
+ F6E1 commainferior
+ F6E2 commasuperior
+ F6E3 dollarinferior
+ F6E4 dollarsuperior
+ F6E5 hypheninferior
+ F6E6 hyphensuperior
+ F6E7 periodinferior
+ F6E8 periodsuperior
+ F6E9 asuperior
+ F6EA bsuperior
+ F6EB dsuperior
+ F6EC esuperior
+ F6ED isuperior
+ F6EE lsuperior
+ F6EF msuperior
+ F6F0 osuperior
+ F6F1 rsuperior
+ F6F2 ssuperior
+ F6F3 tsuperior
+ F6F4 Brevesmall
+ F6F5 Caronsmall
+ F6F6 Circumflexsmall
+ F6F7 Dotaccentsmall
+ F6F8 Hungarumlautsmall
+ F6F9 Lslashsmall
+ F6FA OEsmall
+ F6FB Ogoneksmall
+ F6FC Ringsmall
+ F6FD Scaronsmall
+ F6FE Tildesmall
+ F6FF Zcaronsmall
+ F721 exclamsmall
+ F724 dollaroldstyle
+ F726 ampersandsmall
+ F730 zerooldstyle
+ F731 oneoldstyle
+ F732 twooldstyle
+ F733 threeoldstyle
+ F734 fouroldstyle
+ F735 fiveoldstyle
+ F736 sixoldstyle
+ F737 sevenoldstyle
+ F738 eightoldstyle
+ F739 nineoldstyle
+ F73F questionsmall
+ F760 Gravesmall
+ F761 Asmall
+ F762 Bsmall
+ F763 Csmall
+ F764 Dsmall
+ F765 Esmall
+ F766 Fsmall
+ F767 Gsmall
+ F768 Hsmall
+ F769 Ismall
+ F76A Jsmall
+ F76B Ksmall
+ F76C Lsmall
+ F76D Msmall
+ F76E Nsmall
+ F76F Osmall
+ F770 Psmall
+ F771 Qsmall
+ F772 Rsmall
+ F773 Ssmall
+ F774 Tsmall
+ F775 Usmall
+ F776 Vsmall
+ F777 Wsmall
+ F778 Xsmall
+ F779 Ysmall
+ F77A Zsmall
+ F7A1 exclamdownsmall
+ F7A2 centoldstyle
+ F7A8 Dieresissmall
+ F7AF Macronsmall
+ F7B4 Acutesmall
+ F7B8 Cedillasmall
+ F7BF questiondownsmall
+ F7E0 Agravesmall
+ F7E1 Aacutesmall
+ F7E2 Acircumflexsmall
+ F7E3 Atildesmall
+ F7E4 Adieresissmall
+ F7E5 Aringsmall
+ F7E6 AEsmall
+ F7E7 Ccedillasmall
+ F7E8 Egravesmall
+ F7E9 Eacutesmall
+ F7EA Ecircumflexsmall
+ F7EB Edieresissmall
+ F7EC Igravesmall
+ F7ED Iacutesmall
+ F7EE Icircumflexsmall
+ F7EF Idieresissmall
+ F7F0 Ethsmall
+ F7F1 Ntildesmall
+ F7F2 Ogravesmall
+ F7F3 Oacutesmall
+ F7F4 Ocircumflexsmall
+ F7F5 Otildesmall
+ F7F6 Odieresissmall
+ F7F8 Oslashsmall
+ F7F9 Ugravesmall
+ F7FA Uacutesmall
+ F7FB Ucircumflexsmall
+ F7FC Udieresissmall
+ F7FD Yacutesmall
+ F7FE Thornsmall
+ F7FF Ydieresissmall
+ F8E5 radicalex
+ F8E6 arrowvertex
+ F8E7 arrowhorizex
+ F8E8 registersans
+ F8E9 copyrightsans
+ F8EA trademarksans
+ F8EB parenlefttp
+ F8EC parenleftex
+ F8ED parenleftbt
+ F8EE bracketlefttp
+ F8EF bracketleftex
+ F8F0 bracketleftbt
+ F8F1 bracelefttp
+ F8F2 braceleftmid
+ F8F3 braceleftbt
+ F8F4 braceex
+ F8F5 integralex
+ F8F6 parenrighttp
+ F8F7 parenrightex
+ F8F8 parenrightbt
+ F8F9 bracketrighttp
+ F8FA bracketrightex
+ F8FB bracketrightbt
+ F8FC bracerighttp
+ F8FD bracerightmid
+ F8FE bracerightbt
+ FB00 ff
+ FB01 fi
+ FB02 fl
+ FB03 ffi
+ FB04 ffl
+ FB1F afii57705
+ FB2A afii57694
+ FB2B afii57695
+ FB35 afii57723
+ FB4B afii57700
+ }
+
+ variable ps_preamble {}
+
+ namespace eval ps {
+ namespace ensemble create
+ namespace export {[a-z]*}
+ proc literal {string} {
+ upvar 0 ::tk::ps_preamble preamble
+ foreach line [split $string \n] {
+ set line [string trim $line]
+ if {$line eq ""} continue
+ append preamble $line \n
+ }
+ return
+ }
+ proc variable {name value} {
+ upvar 0 ::tk::ps_preamble preamble
+ append preamble "/$name $value def\n"
+ return
+ }
+ proc function {name body} {
+ upvar 0 ::tk::ps_preamble preamble
+ append preamble "/$name \{"
+ foreach line [split $body \n] {
+ set line [string trim $line]
+ # Strip blank lines and comments from the bodies of functions
+ if {$line eq "" } continue
+ if {[string match {[%#]*} $line]} continue
+ append preamble $line " "
+ }
+ append preamble "\} bind def\n"
+ return
+ }
+ }
+
+ ps literal {
+ %%BeginProlog
+ % This is a standard prolog for Postscript generated by Tk's canvas
+ % widget.
+ }
+ ps variable CurrentEncoding [CreatePostscriptEncoding]
+ ps literal {50 dict begin}
+
+ # 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).
+ ps variable baseline 0
+ ps variable stipimage 0
+ ps variable height 0
+ ps variable justify 0
+ ps variable lineLength 0
+ ps variable spacing 0
+ ps variable stipple 0
+ ps variable strings 0
+ ps variable xoffset 0
+ ps variable yoffset 0
+ ps variable tmpstip null
+ ps variable baselineSampler "( TXygqPZ)"
+ # Put an extra-tall character in; done this way to avoid encoding trouble
+ ps literal {baselineSampler 0 196 put}
+
+ ps function cstringshow {
+ {
+ dup type /stringtype eq
+ { show } { glyphshow }
+ ifelse
+ } forall
+ }
+
+ ps function cstringwidth {
+ 0 exch 0 exch
+ {
+ dup type /stringtype eq
+ { stringwidth } {
+ currentfont /Encoding get exch 1 exch put (\001)
+ stringwidth
+ }
+ ifelse
+ exch 3 1 roll add 3 1 roll add exch
+ } forall
+ }
+
+ # font ISOEncode font
+ #
+ # This procedure changes the encoding of a font from the default
+ # Postscript encoding to current system encoding. It's typically invoked
+ # just before invoking "setfont". The body of this procedure comes from
+ # Section 5.6.1 of the Postscript book.
+ ps function ISOEncode {
+ dup length dict begin
+ {1 index /FID ne {def} {pop pop} ifelse} forall
+ /Encoding CurrentEncoding 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
+ }
+
+ # 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.
+ ps function StrokeClip {
+ {strokepath} stopped {
+ (This Postscript printer gets limitcheck overflows when) =
+ (stippling dashed lines; lines will be printed solid instead.) =
+ [] 0 setdash strokepath} if
+ clip
+ }
+
+ # 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.
+ ps function 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
+ }
+
+ # 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.
+ ps function 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
+ }
+
+ # -- 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.
+ ps function AdjustColor {
+ CL 2 lt {
+ currentgray
+ CL 0 eq {
+ .5 lt {0} {1} ifelse
+ } if
+ setgray
+ } if
+ }
+
+ # 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, function 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.
+ ps function 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 {
+ cstringwidth pop
+ dup lineLength gt {/lineLength exch def} {pop} ifelse
+ newpath
+ } forall
+ % Compute the baseline offset and the actual font height.
+ 0 0 moveto baselineSampler false charpath
+ pathbbox dup /baseline exch def
+ exch pop exch sub /height exch def pop
+ newpath
+ % Translate and rotate coordinates first so that the origin is at
+ % the upper-left corner of the text's bounding box. Remember that
+ % angle for rotating, and x and y for positioning are still on the
+ % stack.
+ translate
+ rotate
+ 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 cstringwidth 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
+ {
+ dup type /stringtype eq {
+ % This segment is a string.
+ {
+ char 0 3 -1 roll put
+ currentpoint
+ gsave
+ char true charpath clip StippleText
+ grestore
+ char stringwidth translate
+ moveto
+ } forall
+ } {
+ % This segment is glyph name
+ % Temporary override
+ currentfont /Encoding get exch 1 exch put
+ currentpoint
+ gsave (\001) true charpath clip StippleText
+ grestore
+ (\001) stringwidth translate
+ moveto
+ } ifelse
+ } forall
+ grestore
+ } {cstringshow} ifelse
+ 0 spacing neg translate
+ } forall
+ }
+
+ # Define the "TkPhoto" function variants, which are modified versions
+ # of the original "transparentimage" function posted by ian at five-d.com
+ # (Ian Kemmish) to comp.lang.postscript. For a monochrome colorLevel
+ # this is a slightly different version that uses the imagemask command
+ # instead of image.
+
+ ps function TkPhotoColor {
+ gsave
+ 32 dict begin
+ /tinteger exch def
+ /transparent 1 string def
+ transparent 0 tinteger put
+ /olddict exch def
+ olddict /DataSource get dup type /filetype ne {
+ olddict /DataSource 3 -1 roll
+ 0 () /SubFileDecode filter put
+ } {
+ pop
+ } ifelse
+ /newdict olddict maxlength dict def
+ olddict newdict copy pop
+ /w newdict /Width get def
+ /crpp newdict /Decode get length 2 idiv def
+ /str w string def
+ /pix w crpp mul string def
+ /substrlen 2 w log 2 log div floor exp cvi def
+ /substrs [ {
+ substrlen string
+ 0 1 substrlen 1 sub {
+ 1 index exch tinteger put
+ } for
+ /substrlen substrlen 2 idiv def
+ substrlen 0 eq {exit} if
+ } loop ] def
+ /h newdict /Height get def
+ 1 w div 1 h div matrix scale
+ olddict /ImageMatrix get exch matrix concatmatrix
+ matrix invertmatrix concat
+ newdict /Height 1 put
+ newdict /DataSource pix put
+ /mat [w 0 0 h 0 0] def
+ newdict /ImageMatrix mat put
+ 0 1 h 1 sub {
+ mat 5 3 -1 roll neg put
+ olddict /DataSource get str readstring pop pop
+ /tail str def
+ /x 0 def
+ olddict /DataSource get pix readstring pop pop
+ {
+ tail transparent search dup /done exch not def
+ {exch pop exch pop} if
+ /w1 exch length def
+ w1 0 ne {
+ newdict /DataSource
+ pix x crpp mul w1 crpp mul getinterval put
+ newdict /Width w1 put
+ mat 4 x neg put
+ /x x w1 add def
+ newdict image
+ /tail tail w1 tail length w1 sub getinterval def
+ } if
+ done {exit} if
+ tail substrs {
+ anchorsearch {pop} if
+ } forall
+ /tail exch def
+ tail length 0 eq {exit} if
+ /x w tail length sub def
+ } loop
+ } for
+ end
+ grestore
+ }
+ ps function TkPhotoMono {
+ gsave
+ 32 dict begin
+ /dummyInteger exch def
+ /olddict exch def
+ olddict /DataSource get dup type /filetype ne {
+ olddict /DataSource 3 -1 roll
+ 0 () /SubFileDecode filter put
+ } {
+ pop
+ } ifelse
+ /newdict olddict maxlength dict def
+ olddict newdict copy pop
+ /w newdict /Width get def
+ /pix w 7 add 8 idiv string def
+ /h newdict /Height get def
+ 1 w div 1 h div matrix scale
+ olddict /ImageMatrix get exch matrix concatmatrix
+ matrix invertmatrix concat
+ newdict /Height 1 put
+ newdict /DataSource pix put
+ /mat [w 0 0 h 0 0] def
+ newdict /ImageMatrix mat put
+ 0 1 h 1 sub {
+ mat 5 3 -1 roll neg put
+ 0.000 0.000 0.000 setrgbcolor
+ olddict /DataSource get pix readstring pop pop
+ newdict /DataSource pix put
+ newdict imagemask
+ 1.000 1.000 1.000 setrgbcolor
+ olddict /DataSource get pix readstring pop pop
+ newdict /DataSource pix put
+ newdict imagemask
+ } for
+ end
+ grestore
+ }
+
+ ps literal %%EndProlog
+}
+
+proc tk::ensure_psenc_is_loaded {} {
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/mkpsenc.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgbox.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/msgbox.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/msgbox.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,454 @@
+# msgbox.tcl --
+#
+# Implements messageboxes for platforms that do not have native
+# messagebox support.
+#
+# Copyright © 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.
+#
+
+# Ensure existence of ::tk::dialog namespace
+#
+namespace eval ::tk::dialog {}
+
+image create bitmap ::tk::dialog::b1 -foreground black \
+-data "#define b1_width 32\n#define b1_height 32
+static unsigned char q1_bits[] = {
+ 0x00, 0xf8, 0x1f, 0x00, 0x00, 0x07, 0xe0, 0x00, 0xc0, 0x00, 0x00, 0x03,
+ 0x20, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x08, 0x08, 0x00, 0x00, 0x10,
+ 0x04, 0x00, 0x00, 0x20, 0x02, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x40,
+ 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,
+ 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,
+ 0x01, 0x00, 0x00, 0x80, 0x02, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x40,
+ 0x04, 0x00, 0x00, 0x20, 0x08, 0x00, 0x00, 0x10, 0x10, 0x00, 0x00, 0x08,
+ 0x60, 0x00, 0x00, 0x04, 0x80, 0x03, 0x80, 0x03, 0x00, 0x0c, 0x78, 0x00,
+ 0x00, 0x30, 0x04, 0x00, 0x00, 0x40, 0x04, 0x00, 0x00, 0x40, 0x04, 0x00,
+ 0x00, 0x80, 0x04, 0x00, 0x00, 0x00, 0x05, 0x00, 0x00, 0x00, 0x06, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
+image create bitmap ::tk::dialog::b2 -foreground white \
+-data "#define b2_width 32\n#define b2_height 32
+static unsigned char b2_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0xf8, 0x1f, 0x00, 0x00, 0xff, 0xff, 0x00,
+ 0xc0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x07, 0xf0, 0xff, 0xff, 0x0f,
+ 0xf8, 0xff, 0xff, 0x1f, 0xfc, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x3f,
+ 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f,
+ 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f,
+ 0xfe, 0xff, 0xff, 0x7f, 0xfc, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x3f,
+ 0xf8, 0xff, 0xff, 0x1f, 0xf0, 0xff, 0xff, 0x0f, 0xe0, 0xff, 0xff, 0x07,
+ 0x80, 0xff, 0xff, 0x03, 0x00, 0xfc, 0x7f, 0x00, 0x00, 0xf0, 0x07, 0x00,
+ 0x00, 0xc0, 0x03, 0x00, 0x00, 0x80, 0x03, 0x00, 0x00, 0x80, 0x03, 0x00,
+ 0x00, 0x00, 0x03, 0x00, 0x00, 0x00, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
+image create bitmap ::tk::dialog::q -foreground blue \
+-data "#define q_width 32\n#define q_height 32
+static unsigned char q_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x07, 0x00,
+ 0x00, 0x10, 0x0f, 0x00, 0x00, 0x18, 0x1e, 0x00, 0x00, 0x38, 0x1e, 0x00,
+ 0x00, 0x38, 0x1e, 0x00, 0x00, 0x10, 0x0f, 0x00, 0x00, 0x80, 0x07, 0x00,
+ 0x00, 0xc0, 0x01, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0xc0, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0xe0, 0x01, 0x00,
+ 0x00, 0xe0, 0x01, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
+image create bitmap ::tk::dialog::i -foreground blue \
+-data "#define i_width 32\n#define i_height 32
+static unsigned char i_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0xe0, 0x01, 0x00, 0x00, 0xf0, 0x03, 0x00, 0x00, 0xf0, 0x03, 0x00,
+ 0x00, 0xe0, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0xf8, 0x03, 0x00, 0x00, 0xf0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00,
+ 0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00,
+ 0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00, 0x00, 0xf0, 0x07, 0x00,
+ 0x00, 0xf8, 0x0f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
+image create bitmap ::tk::dialog::w1 -foreground black \
+-data "#define w1_width 32\n#define w1_height 32
+static unsigned char w1_bits[] = {
+ 0x00, 0x80, 0x01, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x20, 0x04, 0x00,
+ 0x00, 0x10, 0x04, 0x00, 0x00, 0x10, 0x08, 0x00, 0x00, 0x08, 0x08, 0x00,
+ 0x00, 0x08, 0x10, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x04, 0x20, 0x00,
+ 0x00, 0x02, 0x20, 0x00, 0x00, 0x02, 0x40, 0x00, 0x00, 0x01, 0x40, 0x00,
+ 0x00, 0x01, 0x80, 0x00, 0x80, 0x00, 0x80, 0x00, 0x80, 0x00, 0x00, 0x01,
+ 0x40, 0x00, 0x00, 0x01, 0x40, 0x00, 0x00, 0x02, 0x20, 0x00, 0x00, 0x02,
+ 0x20, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x08,
+ 0x08, 0x00, 0x00, 0x08, 0x08, 0x00, 0x00, 0x10, 0x04, 0x00, 0x00, 0x10,
+ 0x04, 0x00, 0x00, 0x20, 0x02, 0x00, 0x00, 0x20, 0x01, 0x00, 0x00, 0x40,
+ 0x01, 0x00, 0x00, 0x40, 0x01, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x20,
+ 0xfc, 0xff, 0xff, 0x1f, 0x00, 0x00, 0x00, 0x00};"
+image create bitmap ::tk::dialog::w2 -foreground yellow \
+-data "#define w2_width 32\n#define w2_height 32
+static unsigned char w2_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0xc0, 0x03, 0x00,
+ 0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xf0, 0x07, 0x00,
+ 0x00, 0xf0, 0x0f, 0x00, 0x00, 0xf8, 0x0f, 0x00, 0x00, 0xf8, 0x1f, 0x00,
+ 0x00, 0xfc, 0x1f, 0x00, 0x00, 0xfc, 0x3f, 0x00, 0x00, 0xfe, 0x3f, 0x00,
+ 0x00, 0xfe, 0x7f, 0x00, 0x00, 0xff, 0x7f, 0x00, 0x00, 0xff, 0xff, 0x00,
+ 0x80, 0xff, 0xff, 0x00, 0x80, 0xff, 0xff, 0x01, 0xc0, 0xff, 0xff, 0x01,
+ 0xc0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x07,
+ 0xf0, 0xff, 0xff, 0x07, 0xf0, 0xff, 0xff, 0x0f, 0xf8, 0xff, 0xff, 0x0f,
+ 0xf8, 0xff, 0xff, 0x1f, 0xfc, 0xff, 0xff, 0x1f, 0xfe, 0xff, 0xff, 0x3f,
+ 0xfe, 0xff, 0xff, 0x3f, 0xfe, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x1f,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
+image create bitmap ::tk::dialog::w3 -foreground black \
+-data "#define w3_width 32\n#define w3_height 32
+static unsigned char w3_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0xc0, 0x03, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00,
+ 0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00,
+ 0x00, 0xc0, 0x03, 0x00, 0x00, 0xc0, 0x03, 0x00, 0x00, 0xc0, 0x03, 0x00,
+ 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0xc0, 0x03, 0x00,
+ 0x00, 0xc0, 0x03, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
+
+# ::tk::MessageBox --
+#
+# 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.
+#
+# Color icons are used on Unix displays that have a color
+# depth of 4 or more and $tk_strictMotif is not on.
+#
+# Uses ::tk::Priv.${disp}(button) instead of ::tk::Priv(button) to
+# avoid adverse effects of [::tk::ScreenChanged]. Bug [e2cec2fa41].
+#
+# 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 ::tk::MessageBox {args} {
+ global tk_strictMotif
+ variable ::tk::Priv
+
+ set w ::tk::PrivMsgBox
+ upvar $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 "" "" ""}
+ {-detail "" "" ""}
+ {-icon "" "" "info"}
+ {-message "" "" ""}
+ {-parent "" "" .}
+ {-title "" "" " "}
+ {-type "" "" "ok"}
+ }
+
+ tclParseConfigSpec $w $specs "" $args
+
+ if {$data(-icon) ni {info warning error question}} {
+ return -code error -errorcode [list TK LOOKUP ICON $data(-icon)] \
+ "bad -icon value \"$data(-icon)\": must be error, info, question, or warning"
+ }
+ set windowingsystem [tk windowingsystem]
+ if {$windowingsystem eq "aqua"} {
+ switch -- $data(-icon) {
+ "error" {set data(-icon) "stop"}
+ "warning" {set data(-icon) "caution"}
+ "info" {set data(-icon) "note"}
+ }
+ }
+
+ if {![winfo exists $data(-parent)]} {
+ return -code error -errorcode [list TK LOOKUP WINDOW $data(-parent)] \
+ "bad window path name \"$data(-parent)\""
+ }
+
+ # Select the vwait variable carefully.
+ set oldScreen $Priv(screen)
+ set screen [winfo screen $data(-parent)]
+
+ # Extract the display name (cf. ScreenChanged, including [Bug 2912473] fix).
+ set disp [string range $screen 0 [string last . $screen]-1]
+
+ # Ensure that namespace separators never occur in the display name (as
+ # they cause problems in variable names). Double-colons exist in some VNC
+ # display names. [Bug 2912473]
+ set disp [string map {:: _doublecolon_} $disp]
+
+ if {![info exists ::tk::Priv.${disp}]} {
+ # Use ScreenChanged to create ::tk::Priv.${disp}, then change back to old
+ # screen to avoid interfering with Tk expectations for bindings.
+ ScreenChanged $screen
+ ScreenChanged $oldScreen
+ }
+
+ variable ::tk::Priv.${disp}
+ # Now in place of ::tk::Priv(button), use ::tk::Priv.${disp}(button) which
+ # is the intended target variable of upvar and will not be redefined when
+ # ::tk::ScreenChanged is called.
+
+ switch -- $data(-type) {
+ abortretryignore {
+ set names [list abort retry ignore]
+ set labels [list &Abort &Retry &Ignore]
+ set cancel abort
+ }
+ ok {
+ set names [list ok]
+ set labels {&OK}
+ set cancel ok
+ }
+ okcancel {
+ set names [list ok cancel]
+ set labels [list &OK &Cancel]
+ set cancel cancel
+ }
+ retrycancel {
+ set names [list retry cancel]
+ set labels [list &Retry &Cancel]
+ set cancel cancel
+ }
+ yesno {
+ set names [list yes no]
+ set labels [list &Yes &No]
+ set cancel no
+ }
+ yesnocancel {
+ set names [list yes no cancel]
+ set labels [list &Yes &No &Cancel]
+ set cancel cancel
+ }
+ default {
+ return -code error -errorcode [list TK LOOKUP DLG_TYPE $data(-type)] \
+ "bad -type value \"$data(-type)\": must be\
+ abortretryignore, ok, okcancel, retrycancel,\
+ yesno, or yesnocancel"
+ }
+ }
+
+ set buttons {}
+ foreach name $names lab $labels {
+ lappend buttons [list $name -text [mc $lab]]
+ }
+
+ # If no default button was specified, the default default is the
+ # first button (Bug: 2218).
+
+ if {$data(-default) eq ""} {
+ set data(-default) [lindex [lindex $buttons 0] 0]
+ }
+
+ set valid 0
+ foreach btn $buttons {
+ if {[lindex $btn 0] eq $data(-default)} {
+ set valid 1
+ break
+ }
+ }
+ if {!$valid} {
+ return -code error -errorcode {TK MSGBOX DEFAULT} \
+ "bad -default value \"$data(-default)\": must be\
+ abort, retry, ignore, ok, cancel, no, or yes"
+ }
+
+ # 2. Set the dialog to be a child window of $parent
+ #
+ #
+ if {$data(-parent) ne "."} {
+ set w $data(-parent).__tk__messagebox
+ } else {
+ set w .__tk__messagebox
+ }
+
+ # There is only one background colour for the whole dialog
+ set bg [ttk::style lookup . -background]
+
+ # 3. Create the top-level window and divide it into top
+ # and bottom parts.
+
+ catch {destroy $w}
+ toplevel $w -class Dialog -bg $bg
+ wm title $w $data(-title)
+ wm iconname $w Dialog
+ wm protocol $w WM_DELETE_WINDOW [list $w.$cancel invoke]
+
+ # Message boxes should be transient with respect to their parent so that
+ # they always stay on top of the parent window. But some window managers
+ # will simply create the child window as withdrawn if the parent is not
+ # viewable (because it is withdrawn or iconified). This is not good for
+ # "grab"bed windows. So only make the message box transient if the parent
+ # is viewable.
+ #
+ if {[winfo viewable [winfo toplevel $data(-parent)]] } {
+ wm transient $w $data(-parent)
+ }
+
+ if {$windowingsystem eq "aqua"} {
+ ::tk::unsupported::MacWindowStyle style $w moveableModal {}
+ } elseif {$windowingsystem eq "x11"} {
+ wm attributes $w -type dialog
+ }
+
+ ttk::frame $w.bot
+ grid anchor $w.bot center
+ pack $w.bot -side bottom -fill both
+ ttk::frame $w.top
+ pack $w.top -side top -fill both -expand 1
+
+ # 4. Fill the top part with bitmap, message and detail (use the
+ # option database for -wraplength and -font so that they can be
+ # overridden by the caller).
+
+ option add *Dialog.msg.wrapLength 3i widgetDefault
+ option add *Dialog.dtl.wrapLength 3i widgetDefault
+ option add *Dialog.msg.font TkCaptionFont widgetDefault
+ option add *Dialog.dtl.font TkDefaultFont widgetDefault
+
+ ttk::label $w.msg -anchor nw -justify left -text $data(-message)
+ if {$data(-detail) ne ""} {
+ ttk::label $w.dtl -anchor nw -justify left -text $data(-detail)
+ }
+ if {$data(-icon) ne ""} {
+ if {([winfo depth $w] < 4) || $tk_strictMotif} {
+ # ttk::label has no -bitmap option
+ label $w.bitmap -bitmap $data(-icon) -background $bg
+ } else {
+ switch $data(-icon) {
+ error {
+ ttk::label $w.bitmap -image ::tk::icons::error
+ }
+ info {
+ ttk::label $w.bitmap -image ::tk::icons::information
+ }
+ question {
+ ttk::label $w.bitmap -image ::tk::icons::question
+ }
+ default {
+ ttk::label $w.bitmap -image ::tk::icons::warning
+ }
+ }
+ }
+ }
+ grid $w.bitmap $w.msg -in $w.top -sticky news -padx 2m -pady 2m
+ grid configure $w.bitmap -sticky nw
+ grid columnconfigure $w.top 1 -weight 1
+ if {$data(-detail) ne ""} {
+ grid ^ $w.dtl -in $w.top -sticky news -padx 2m -pady {0 2m}
+ grid rowconfigure $w.top 1 -weight 1
+ } else {
+ grid rowconfigure $w.top 0 -weight 1
+ }
+
+ # 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 {![llength $opts]} {
+ # Capitalize the first letter of $name
+ set capName [string toupper $name 0]
+ set opts [list -text $capName]
+ }
+
+ eval [list tk::AmpWidget ttk::button $w.$name] $opts \
+ [list -command [list set tk::Priv.${disp}(button) $name]]
+
+ if {$name eq $data(-default)} {
+ $w.$name configure -default active
+ } else {
+ $w.$name configure -default normal
+ }
+ grid $w.$name -in $w.bot -row 0 -column $i -padx 3m -pady 2m -sticky ew
+ grid columnconfigure $w.bot $i -uniform buttons
+ # We boost the size of some Mac buttons for l&f
+ if {$windowingsystem eq "aqua"} {
+ set tmp [string tolower $name]
+ if {$tmp eq "ok" || $tmp eq "cancel" || $tmp eq "yes" ||
+ $tmp eq "no" || $tmp eq "abort" || $tmp eq "retry" ||
+ $tmp eq "ignore"} {
+ grid columnconfigure $w.bot $i -minsize 90
+ }
+ grid configure $w.$name -pady 7
+ }
+ incr i
+
+ # 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 <Alt-[string tolower $key]> [list $w.$name invoke]
+ # bind $w <Alt-[string toupper $key]> [list $w.$name invoke]
+ # }
+ }
+ bind $w <Alt-Key> [list ::tk::AltKeyInDialog $w %A]
+
+ if {$data(-default) ne ""} {
+ bind $w <FocusIn> {
+ if {[winfo class %W] in "Button TButton"} {
+ %W configure -default active
+ }
+ }
+ bind $w <FocusOut> {
+ if {[winfo class %W] in "Button TButton"} {
+ %W configure -default normal
+ }
+ }
+ }
+
+ # 6. Create bindings for <Return>, <Escape> and <Destroy> on the dialog
+
+ bind $w <Return> {
+ if {[winfo class %W] in "Button TButton"} {
+ %W invoke
+ }
+ }
+
+ # Invoke the designated cancelling operation
+ bind $w <Escape> [list $w.$cancel invoke]
+
+ # At <Destroy> the buttons have vanished, so must do this directly.
+ bind $w.msg <Destroy> [list set tk::Priv.${disp}(button) $cancel]
+
+ # 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 (Motif style) and de-iconify it.
+
+ ::tk::PlaceWindow $w widget $data(-parent)
+
+ # 8. Set a grab and claim the focus too.
+
+ if {$data(-default) ne ""} {
+ set focus $w.$data(-default)
+ } else {
+ set focus $w
+ }
+ ::tk::SetFocusGrab $w $focus
+
+ # 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.
+
+ vwait ::tk::Priv.${disp}(button)
+ # Copy the result now so any <Destroy> that happens won't cause
+ # trouble
+ set result [set Priv.${disp}(button)]
+
+ ::tk::RestoreFocusGrab $w $focus
+
+ return $result
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgbox.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/cs.msg
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/cs.msg (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/cs.msg 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,95 @@
+namespace eval ::tk {
+ ::msgcat::mcset cs "&Abort" "&Přerušit"
+ ::msgcat::mcset cs "&About..." "&O programu..."
+ ::msgcat::mcset cs "All Files" "Všechny soubory"
+ ::msgcat::mcset cs "Application Error" "Chyba programu"
+ ::msgcat::mcset cs "Bold Italic"
+ ::msgcat::mcset cs "&Blue" "&Modá"
+ ::msgcat::mcset cs "Cancel" "Zrušit"
+ ::msgcat::mcset cs "&Cancel" "&Zrušit"
+ ::msgcat::mcset cs "Cannot change to the directory \"%1\$s\".\nPermission denied." "Nemohu změnit atkálí adreář na \"%1\$s\".\nPístup odítnut."
+ ::msgcat::mcset cs "Choose Directory" "ýběr adreáře"
+ ::msgcat::mcset cs "Cl&ear" "Sma&zat"
+ ::msgcat::mcset cs "&Clear Console" "&Smazat konzolu"
+ ::msgcat::mcset cs "Color" "Barva"
+ ::msgcat::mcset cs "Console" "Konzole"
+ ::msgcat::mcset cs "&Copy" "&Koírovat"
+ ::msgcat::mcset cs "Cu&t" "V&yíznout"
+ ::msgcat::mcset cs "&Delete" "&Smazat"
+ ::msgcat::mcset cs "Details >>" "Detaily >>"
+ ::msgcat::mcset cs "Directory \"%1\$s\" does not exist." "Adreář \"%1\$s\" neexistuje."
+ ::msgcat::mcset cs "&Directory:" "&Adreář:"
+ ::msgcat::mcset cs "&Edit" "Úpravy"
+ ::msgcat::mcset cs "Error: %1\$s" "Chyba: %1\$s"
+ ::msgcat::mcset cs "E&xit" "&Konec"
+ ::msgcat::mcset cs "&File" "&Soubor"
+ ::msgcat::mcset cs "File \"%1\$s\" already exists.\nDo you want to overwrite it?" "Soubor \"%1\$s\" již existuje.\nChcete jej přepsat?"
+ ::msgcat::mcset cs "File \"%1\$s\" already exists.\n\n" "Soubor \"%1\$s\" již existuje.\n\n"
+ ::msgcat::mcset cs "File \"%1\$s\" does not exist." "Soubor \"%1\$s\" neexistuje."
+ ::msgcat::mcset cs "File &name:" "&Jéno souboru:"
+ ::msgcat::mcset cs "File &names:" "&Jéna souborů:"
+ ::msgcat::mcset cs "Files of &type:" "&Typy souborů:"
+ ::msgcat::mcset cs "Fi&les:" "Sou&bory:"
+ ::msgcat::mcset cs "&Filter" "&Filtr"
+ ::msgcat::mcset cs "Fil&ter:" "Fil&tr:"
+ ::msgcat::mcset cs "Font st&yle:"
+ ::msgcat::mcset cs "&Green" "Ze&leá"
+ ::msgcat::mcset cs "&Help" "&ápověda"
+ ::msgcat::mcset cs "Hi" "Ahoj"
+ ::msgcat::mcset cs "&Hide Console" "&Schovat Konzolu"
+ ::msgcat::mcset cs "&Ignore" "&Ignorovat"
+ ::msgcat::mcset cs "Invalid file name \"%1\$s\"." "Špaté jéno souboru \"%1\$s\"."
+ ::msgcat::mcset cs "Log Files" "Log soubory"
+ ::msgcat::mcset cs "&No" "&Ne"
+ ::msgcat::mcset cs "&OK"
+ ::msgcat::mcset cs "OK"
+ ::msgcat::mcset cs "Ok"
+ ::msgcat::mcset cs "Open" "Otevít"
+ ::msgcat::mcset cs "&Open" "&Otevít"
+ ::msgcat::mcset cs "Open Multiple Files" "Otevít íce souborů"
+ ::msgcat::mcset cs "P&aste" "&Vložit"
+ ::msgcat::mcset cs "&Quit" "&Ukončit"
+ ::msgcat::mcset cs "&Red" "Če&rveá"
+ ::msgcat::mcset cs "Replace existing file?" "Nahradit sávaíí soubor?"
+ ::msgcat::mcset cs "&Retry" "Z&novu"
+ ::msgcat::mcset cs "&Save" "&Uložit"
+ ::msgcat::mcset cs "Save As" "Uložit jako"
+ ::msgcat::mcset cs "Save To Log" "Uložit do logu"
+ ::msgcat::mcset cs "Select Log File" "Vybrat log soubor"
+ ::msgcat::mcset cs "Select a file to source" "Vybrat soubor k naháí"
+ ::msgcat::mcset cs "&Selection:" "&ýběr:"
+ ::msgcat::mcset cs "Skip Messages" "Přeskočit zpávy"
+ ::msgcat::mcset cs "&Source..." "&Zdroj..."
+ ::msgcat::mcset cs "Tcl Scripts" "Tcl skripty"
+ ::msgcat::mcset cs "Tcl for Windows" "Tcl pro Windows"
+ ::msgcat::mcset cs "Text Files" "Textoé soubory"
+ ::msgcat::mcset cs "abort" "přerušit"
+ ::msgcat::mcset cs "blue" "modá"
+ ::msgcat::mcset cs "cancel" "zrušit"
+ ::msgcat::mcset cs "extension" "pípona"
+ ::msgcat::mcset cs "extensions" "pípony"
+ ::msgcat::mcset cs "green" "zeleá"
+ ::msgcat::mcset cs "ignore" "ignorovat"
+ ::msgcat::mcset cs "ok"
+ ::msgcat::mcset cs "red" "červeá"
+ ::msgcat::mcset cs "retry" "znovu"
+ ::msgcat::mcset cs "yes" "ano"
+}
+#localization of print terms by Kevin Walzer via Microsoft Translator
+namespace eval ::tk {
+ ::msgcat::mcset cs "Print" "Tisknout"
+ ::msgcat::mcset cs "Printer" "Tiskárna"
+ ::msgcat::mcset cs "Letter " "Dopis "
+ ::msgcat::mcset cs "Legal " "Legální "
+ ::msgcat::mcset cs "A4" "A4"
+ ::msgcat::mcset cs "Grayscale" "Stupně Šedi"
+ ::msgcat::mcset cs "RGB" "RGB"
+ ::msgcat::mcset cs "Options" "Možnosti"
+ ::msgcat::mcset cs "Copies" "Kopie"
+ ::msgcat::mcset cs "Paper" "Papír"
+ ::msgcat::mcset cs "Scale" "Škála"
+ ::msgcat::mcset cs "Orientation" "Orientace"
+ ::msgcat::mcset cs "Portrait" "Portrét"
+ ::msgcat::mcset cs "Landscape" "Krajina"
+ ::msgcat::mcset cs "Output" "Výstup"
+}
\ No newline at end of file
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/cs.msg
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/da.msg
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/da.msg (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/da.msg 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,96 @@
+namespace eval ::tk {
+ ::msgcat::mcset da "&Abort" "&Afbryd"
+ ::msgcat::mcset da "&About..." "&Om..."
+ ::msgcat::mcset da "All Files" "Alle filer"
+ ::msgcat::mcset da "Application Error" "Programfejl"
+ ::msgcat::mcset da "&Blue" "&Blå"
+ ::msgcat::mcset da "Cancel" "Annuller"
+ ::msgcat::mcset da "&Cancel" "&Annuller"
+ ::msgcat::mcset da "Cannot change to the directory \"%1\$s\".\nPermission denied." "Kan ikke skifte til katalog \"%1\$s\".\nIngen rettigheder."
+ ::msgcat::mcset da "Choose Directory" "Vælg katalog"
+ ::msgcat::mcset da "Cl&ear" "&Ryd"
+ ::msgcat::mcset da "&Clear Console" "&Ryd konsolen"
+ ::msgcat::mcset da "Color" "Farve"
+ ::msgcat::mcset da "Console" "Konsol"
+ ::msgcat::mcset da "&Copy" "&Kopier"
+ ::msgcat::mcset da "Cu&t" "Kli&p"
+ ::msgcat::mcset da "&Delete" "&Slet"
+ ::msgcat::mcset da "Details >>" "Detailer"
+ ::msgcat::mcset da "Directory \"%1\$s\" does not exist." "Katalog \"%1\$s\" findes ikke."
+ ::msgcat::mcset da "&Directory:" "&Katalog:"
+ ::msgcat::mcset da "&Edit" "&Rediger"
+ ::msgcat::mcset da "Error: %1\$s" "Fejl: %1\$s"
+ ::msgcat::mcset da "E&xit" "&Afslut"
+ ::msgcat::mcset da "&File" "&Fil"
+ ::msgcat::mcset da "File \"%1\$s\" already exists.\nDo you want to overwrite it?" "Filen \"%1\$s\" findes allerede.\nSkal den overskrives?"
+ ::msgcat::mcset da "File \"%1\$s\" already exists.\n\n" "Filen \"%1\$s\" findes allerede.\n\n"
+ ::msgcat::mcset da "File \"%1\$s\" does not exist." "Filen \"%1\$s\" findes ikke."
+ ::msgcat::mcset da "File &name:" "Fil&navn:"
+ ::msgcat::mcset da "File &names:" "Fil&navne:"
+ ::msgcat::mcset da "Files of &type:" "Fil&typer:"
+ ::msgcat::mcset da "Fi&les:" "Fi&ler:"
+ ::msgcat::mcset da "&Filter"
+ ::msgcat::mcset da "Fil&ter:"
+ ::msgcat::mcset da "&Green" "&Grøn"
+ ::msgcat::mcset da "&Help" "&Hjælp"
+ ::msgcat::mcset da "Hi" "Hej"
+ ::msgcat::mcset da "&Hide Console" "Skjul &konsol"
+ ::msgcat::mcset da "&Ignore" "&Ignorer"
+ ::msgcat::mcset da "Invalid file name \"%1\$s\"." "Ugyldig fil navn \"%1\$s\"."
+ ::msgcat::mcset da "Log Files" "Logfiler"
+ ::msgcat::mcset da "&No" "&Nej"
+ ::msgcat::mcset da "&OK" "&O.K."
+ ::msgcat::mcset da "OK" "O.K."
+ ::msgcat::mcset da "Ok"
+ ::msgcat::mcset da "Open" "Åbn"
+ ::msgcat::mcset da "&Open" "&Åbn"
+ ::msgcat::mcset da "Open Multiple Files" "Åbn flere filer"
+ ::msgcat::mcset da "P&aste" "&Indsæt"
+ ::msgcat::mcset da "&Quit" "&Afslut"
+ ::msgcat::mcset da "&Red" "&Rød"
+ ::msgcat::mcset da "Replace existing file?" "Erstat eksisterende fil?"
+ ::msgcat::mcset da "&Retry" "&Gentag"
+ ::msgcat::mcset da "&Save" "&Gem"
+ ::msgcat::mcset da "Save As" "Gem som"
+ ::msgcat::mcset da "Save To Log" "Gem i log"
+ ::msgcat::mcset da "Select Log File" "Vælg logfil"
+ ::msgcat::mcset da "Select a file to source" "Vælg kørbar fil"
+ ::msgcat::mcset da "&Selection:" "&Udvalg:"
+ ::msgcat::mcset da "Show &Hidden Directories" "Vis &skjulte kataloger"
+ ::msgcat::mcset da "Show &Hidden Files and Directories" "Vis &skjulte filer og kataloger"
+ ::msgcat::mcset da "Skip Messages" "Overspring beskeder"
+ ::msgcat::mcset da "&Source..." "&Kør..."
+ ::msgcat::mcset da "Tcl Scripts" "Tcl-Skripter"
+ ::msgcat::mcset da "Tcl for Windows" "Tcl for Windows"
+ ::msgcat::mcset da "Text Files" "Tekstfiler"
+ ::msgcat::mcset da "&Yes" "&Ja"
+ ::msgcat::mcset da "abort" "afbryd"
+ ::msgcat::mcset da "blue" "blå"
+ ::msgcat::mcset da "cancel" "afbryd"
+ ::msgcat::mcset da "extension"
+ ::msgcat::mcset da "extensions"
+ ::msgcat::mcset da "green" "grøn"
+ ::msgcat::mcset da "ignore" "ignorer"
+ ::msgcat::mcset da "ok"
+ ::msgcat::mcset da "red" "rød"
+ ::msgcat::mcset da "retry" "gentag"
+ ::msgcat::mcset da "yes" "ja"
+}
+#localization of print terms by Kevin Walzer via Microsoft Translator
+namespace eval ::tk {
+ ::msgcat::mcset da "Print" "Trykke"
+ ::msgcat::mcset da "Printer" "Printer"
+ ::msgcat::mcset da "Letter " "Brev"
+ ::msgcat::mcset da "Legal " "Juridisk"
+ ::msgcat::mcset da "A4" "A4"
+ ::msgcat::mcset da "Grayscale" "Gråtoneskala"
+ ::msgcat::mcset da "RGB" "Rgb"
+ ::msgcat::mcset da "Options" "Indstillinger"
+ ::msgcat::mcset da "Copies" "Kopier"
+ ::msgcat::mcset da "Paper" "Papir"
+ ::msgcat::mcset da "Scale" "Skalere"
+ ::msgcat::mcset da "Orientation" "Orientering"
+ ::msgcat::mcset da "Portrait" "Portræt"
+ ::msgcat::mcset da "Landscape" "Landskab"
+ ::msgcat::mcset da "Output" "Udskriv Publikation"
+}
\ No newline at end of file
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/da.msg
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/de.msg
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/de.msg (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/de.msg 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,109 @@
+namespace eval ::tk {
+ ::msgcat::mcset de "&Abort" "&Abbruch"
+ ::msgcat::mcset de "&About..." "&Über..."
+ ::msgcat::mcset de "All Files" "Alle Dateien"
+ ::msgcat::mcset de "Application Error" "Applikationsfehler"
+ ::msgcat::mcset de "&Apply" "&Anwenden"
+ ::msgcat::mcset de "Bold" "Fett"
+ ::msgcat::mcset de "Bold Italic" "Fett kursiv"
+ ::msgcat::mcset de "&Blue" "&Blau"
+ ::msgcat::mcset de "Cancel" "Abbruch"
+ ::msgcat::mcset de "&Cancel" "&Abbruch"
+ ::msgcat::mcset de "Cannot change to the directory \"%1\$s\".\nPermission denied." "Kann nicht in das Verzeichnis \"%1\$s\" wechseln.\nKeine Rechte vorhanden."
+ ::msgcat::mcset de "Choose Directory" "Wähle Verzeichnis"
+ ::msgcat::mcset de "Cl&ear" "&Rücksetzen"
+ ::msgcat::mcset de "&Clear Console" "&Konsole löschen"
+ ::msgcat::mcset de "Color" "Farbe"
+ ::msgcat::mcset de "Console" "Konsole"
+ ::msgcat::mcset de "&Copy" "&Kopieren"
+ ::msgcat::mcset de "Cu&t" "Aus&schneiden"
+ ::msgcat::mcset de "&Delete" "&Löschen"
+ ::msgcat::mcset de "Details >>"
+ ::msgcat::mcset de "Directory \"%1\$s\" does not exist." "Das Verzeichnis \"%1\$s\" existiert nicht."
+ ::msgcat::mcset de "&Directory:" "&Verzeichnis:"
+ ::msgcat::mcset de "&Edit" "&Bearbeiten"
+ ::msgcat::mcset de "Effects" "Effekte"
+ ::msgcat::mcset de "Error: %1\$s" "Fehler: %1\$s"
+ ::msgcat::mcset de "E&xit" "&Ende"
+ ::msgcat::mcset de "&File" "&Datei"
+ ::msgcat::mcset de "File \"%1\$s\" already exists.\nDo you want to overwrite it?" "Die Datei \"%1\$s\" ist bereits vorhanden.\nWollen sie diese Datei überschreiben ?"
+ ::msgcat::mcset de "File \"%1\$s\" already exists.\n\n" "Die Datei \"%1\$s\" ist bereits vorhanden.\n\n"
+ ::msgcat::mcset de "File \"%1\$s\" does not exist." "Die Datei \"%1\$s\" existiert nicht."
+ ::msgcat::mcset de "File &name:" "Datei&name:"
+ ::msgcat::mcset de "File &names:" "Datei&namen:"
+ ::msgcat::mcset de "Files of &type:" "Dateien des &Typs:"
+ ::msgcat::mcset de "Fi&les:" "Dat&eien:"
+ ::msgcat::mcset de "&Filter"
+ ::msgcat::mcset de "Fil&ter:"
+ ::msgcat::mcset de "Font" "Schriftart"
+ ::msgcat::mcset de "&Font:" "Schriftart:"
+ ::msgcat::mcset de "Font st&yle:" "Schriftschnitt:"
+ ::msgcat::mcset de "&Green" "&Grün"
+ ::msgcat::mcset de "&Help" "&Hilfe"
+ ::msgcat::mcset de "Hi" "Hallo"
+ ::msgcat::mcset de "&Hide Console" "&Konsole unsichtbar machen"
+ ::msgcat::mcset de "&Ignore" "&Ignorieren"
+ ::msgcat::mcset de "Invalid file name \"%1\$s\"." "Ungültiger Dateiname \"%1\$s\"."
+ ::msgcat::mcset de "Italic" "Kursiv"
+ ::msgcat::mcset de "Log Files" "Protokolldatei"
+ ::msgcat::mcset de "&No" "&Nein"
+ ::msgcat::mcset de "&OK"
+ ::msgcat::mcset de "OK"
+ ::msgcat::mcset de "Ok"
+ ::msgcat::mcset de "Open" "Öffnen"
+ ::msgcat::mcset de "&Open" "Ö&ffnen"
+ ::msgcat::mcset de "Open Multiple Files" "Mehrere Dateien Öffnen"
+ ::msgcat::mcset de "P&aste" "E&infügen"
+ ::msgcat::mcset de "&Quit" "&Beenden"
+ ::msgcat::mcset de "&Red" "&Rot"
+ ::msgcat::mcset de "Regular" "Standard"
+ ::msgcat::mcset de "Replace existing file?" "Existierende Datei ersetzen?"
+ ::msgcat::mcset de "&Retry" "&Wiederholen"
+ ::msgcat::mcset de "Sample" "Beispiel"
+ ::msgcat::mcset de "&Save" "&Speichern"
+ ::msgcat::mcset de "Save As" "Speichern unter"
+ ::msgcat::mcset de "Save To Log" "In Protokoll speichern"
+ ::msgcat::mcset de "Select Log File" "Protokolldatei auswählen"
+ ::msgcat::mcset de "Select a file to source" "Auszuführende Datei auswählen"
+ ::msgcat::mcset de "&Selection:" "Auswah&l:"
+ ::msgcat::mcset de "&Size:" "Schriftgrad:"
+ ::msgcat::mcset de "Show &Hidden Directories" "Zeige versteckte Dateien"
+ ::msgcat::mcset de "Show &Hidden Files and Directories" "Zeige versteckte Dateien und Verzeichnisse"
+ ::msgcat::mcset de "Skip Messages" "Weitere Nachrichten überspringen"
+ ::msgcat::mcset de "&Source..." "&Ausführen..."
+ ::msgcat::mcset de "Stri&keout" "&Durchgestrichen"
+ ::msgcat::mcset de "Tcl Scripts" "Tcl-Skripte"
+ ::msgcat::mcset de "Tcl for Windows" "Tcl für Windows"
+ ::msgcat::mcset de "Text Files" "Textdateien"
+ ::msgcat::mcset de "&Underline" "&Unterstrichen"
+ ::msgcat::mcset de "&Yes" "&Ja"
+ ::msgcat::mcset de "abort" "abbrechen"
+ ::msgcat::mcset de "blue" "blau"
+ ::msgcat::mcset de "cancel" "abbrechen"
+ ::msgcat::mcset de "extension" "Erweiterung"
+ ::msgcat::mcset de "extensions" "Erweiterungen"
+ ::msgcat::mcset de "green" "grün"
+ ::msgcat::mcset de "ignore" "ignorieren"
+ ::msgcat::mcset de "ok"
+ ::msgcat::mcset de "red" "rot"
+ ::msgcat::mcset de "retry" "wiederholen"
+ ::msgcat::mcset de "yes" "ja"
+}
+#localization of print terms by Kevin Walzer via Microsoft Translator
+namespace eval ::tk {
+ ::msgcat::mcset de "Print" "Drucken"
+ ::msgcat::mcset de "Printer" "Drucker"
+ ::msgcat::mcset de "Letter " "Letter"
+ ::msgcat::mcset de "Legal " "Legal"
+ ::msgcat::mcset de "A4" "A4"
+ ::msgcat::mcset de "Grayscale" "Graustufen"
+ ::msgcat::mcset de "RGB" "RGB"
+ ::msgcat::mcset de "Options" "Optionen"
+ ::msgcat::mcset de "Copies" "Kopien"
+ ::msgcat::mcset de "Paper" "Papier"
+ ::msgcat::mcset de "Scale" "Skalierung"
+ ::msgcat::mcset de "Orientation" "Ausrichtung"
+ ::msgcat::mcset de "Portrait" "Hochformat"
+ ::msgcat::mcset de "Landscape" "Querformat"
+ ::msgcat::mcset de "Output" "Ausgabe"
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/de.msg
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/el.msg
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/el.msg (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/el.msg 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,104 @@
+## Messages for the Greek (Hellenic - "el") language.
+## Please report any changes/suggestions to:
+## petasis at iit.demokritos.gr
+
+namespace eval ::tk {
+ ::msgcat::mcset el "&Abort" "Τερματισμός"
+ ::msgcat::mcset el "About..." "Σχετικά..."
+ ::msgcat::mcset el "All Files" "Όλα τα Αρχεία"
+ ::msgcat::mcset el "Application Error" "Λάθος Εφαρμογής"
+ ::msgcat::mcset el "&Blue" "Μπλε"
+ ::msgcat::mcset el "&Cancel" "Ακύρωση"
+ ::msgcat::mcset el \
+"Cannot change to the directory \"%1\$s\".\nPermission denied." \
+"Δεν είναι δυνατή η αλλαγή καταλόγου σε \"%1\$s\".\nΗ πρόσβαση δεν επιτρέπεται."
+ ::msgcat::mcset el "Choose Directory" "Επιλογή Καταλόγου"
+ ::msgcat::mcset el "Clear" "Καθαρισμός"
+ ::msgcat::mcset el "Color" "Χρώμα"
+ ::msgcat::mcset el "Console" "Κονσόλα"
+ ::msgcat::mcset el "Copy" "Αντιγραφή"
+ ::msgcat::mcset el "Cut" "Αποκοπή"
+ ::msgcat::mcset el "Delete" "Διαγραφή"
+ ::msgcat::mcset el "Details >>" "Λεπτομέρειες >>"
+ ::msgcat::mcset el "Directory \"%1\$s\" does not exist." \
+ "Ο κατάλογος \"%1\$s\" δεν υπάρχει."
+ ::msgcat::mcset el "&Directory:" "&Κατάλογος:"
+ ::msgcat::mcset el "Error: %1\$s" "Λάθος: %1\$s"
+ ::msgcat::mcset el "Exit" "Έξοδος"
+ ::msgcat::mcset el \
+ "File \"%1\$s\" already exists.\nDo you want to overwrite it?" \
+ "Το αρχείο \"%1\$s\" ήδη υπάρχει.\nΘέλετε να επικαλυφθεί;"
+ ::msgcat::mcset el "File \"%1\$s\" already exists.\n\n" \
+ "Το αρχείο \"%1\$s\" ήδη υπάρχει.\n\n"
+ ::msgcat::mcset el "File \"%1\$s\" does not exist." \
+ "Το αρχείο \"%1\$s\" δεν υπάρχει."
+ ::msgcat::mcset el "File &name:" "Ό&νομα αρχείου:"
+ ::msgcat::mcset el "File &names:" "Ό&νομα αρχείων:"
+ ::msgcat::mcset el "Files of &type:" "Αρχεία του &τύπου:"
+ ::msgcat::mcset el "Fi&les:" "Αρχεία:"
+ ::msgcat::mcset el "&Filter" "Φίλτρο"
+ ::msgcat::mcset el "Fil&ter:" "Φίλτρο:"
+ ::msgcat::mcset el "&Green" "Πράσινο"
+ ::msgcat::mcset el "Hi" "Γεια"
+ ::msgcat::mcset el "Hide Console" "Απόκρυψη κονσόλας"
+ ::msgcat::mcset el "&Ignore" "Αγνόηση"
+ ::msgcat::mcset el "Invalid file name \"%1\$s\"." \
+ "Άκυρο όνομα αρχείου \"%1\$s\"."
+ ::msgcat::mcset el "Log Files" "Αρχεία Καταγραφής"
+ ::msgcat::mcset el "&No" "Όχι"
+ ::msgcat::mcset el "&OK" "Εντάξει"
+ ::msgcat::mcset el "OK" "Εντάξει"
+ ::msgcat::mcset el "Ok" "Εντάξει"
+ ::msgcat::mcset el "Open" "Άνοιγμα"
+ ::msgcat::mcset el "&Open" "Άνοιγμα"
+ ::msgcat::mcset el "Open Multiple Files" \
+ "Άνοιγμα πολλαπλών αρχείων"
+ ::msgcat::mcset el "P&aste" "Επικόλληση"
+ ::msgcat::mcset el "Quit" "Έξοδος"
+ ::msgcat::mcset el "&Red" "Κόκκινο"
+ ::msgcat::mcset el "Replace existing file?" \
+ "Επικάλυψη υπάρχοντος αρχείου;"
+ ::msgcat::mcset el "&Retry" "Προσπάθησε ξανά"
+ ::msgcat::mcset el "&Save" "Αποθήκευση"
+ ::msgcat::mcset el "Save As" "Αποθήκευση σαν"
+ ::msgcat::mcset el "Save To Log" "Αποθήκευση στο αρχείο καταγραφής"
+ ::msgcat::mcset el "Select Log File" "Επιλογή αρχείου καταγραφής"
+ ::msgcat::mcset el "Select a file to source" \
+ "Επιλέξτε αρχείο για εκτέλεση"
+ ::msgcat::mcset el "&Selection:" "Επιλογή:"
+ ::msgcat::mcset el "Skip Messages" "Αποφυγήμηνυμάτων"
+ ::msgcat::mcset el "&Source..." "Εκτέλεση..."
+ ::msgcat::mcset el "Tcl Scripts" "Tcl Scripts"
+ ::msgcat::mcset el "Tcl for Windows" "Tcl για Windows"
+ ::msgcat::mcset el "Text Files" "Αρχεία Κειμένου"
+ ::msgcat::mcset el "&Yes" "Ναι"
+ ::msgcat::mcset el "abort" "τερματισμός"
+ ::msgcat::mcset el "blue" "μπλε"
+ ::msgcat::mcset el "cancel" "ακύρωση"
+ ::msgcat::mcset el "extension" "επέκταση"
+ ::msgcat::mcset el "extensions" "επεκτάσεις"
+ ::msgcat::mcset el "green" "πράσινο"
+ ::msgcat::mcset el "ignore" "αγνόηση"
+ ::msgcat::mcset el "ok" "εντάξει"
+ ::msgcat::mcset el "red" "κόκκινο"
+ ::msgcat::mcset el "retry" "προσπάθησε ξανά"
+ ::msgcat::mcset el "yes" "ναι"
+}
+#localization of print terms by Kevin Walzer via Microsoft Translator
+namespace eval ::tk {
+ ::msgcat::mcset el "Print" "Τυπώνω"
+ ::msgcat::mcset el "Printer" "Εκτυπωτής"
+ ::msgcat::mcset el "Letter " "Γράμμα"
+ ::msgcat::mcset el "Legal " "Νομικός"
+ ::msgcat::mcset el "A4" "Α4"
+ ::msgcat::mcset el "Grayscale" "Κλίμακα Του Γκρι"
+ ::msgcat::mcset el "RGB" "Rgb"
+ ::msgcat::mcset el "Options" "Επιλογές"
+ ::msgcat::mcset el "Copies" "Αντίγραφα"
+ ::msgcat::mcset el "Paper" "Χαρτί"
+ ::msgcat::mcset el "Scale" "Κλίμακα"
+ ::msgcat::mcset el "Orientation" "Προσανατολισμός"
+ ::msgcat::mcset el "Portrait" "Προσωπογραφία"
+ ::msgcat::mcset el "Landscape" "Τοπίο"
+ ::msgcat::mcset el "Output" "Έξοδος"
+}
\ No newline at end of file
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/el.msg
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/en.msg
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/en.msg (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/en.msg 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,110 @@
+namespace eval ::tk {
+ ::msgcat::mcset en "&Abort"
+ ::msgcat::mcset en "&About..."
+ ::msgcat::mcset en "All Files"
+ ::msgcat::mcset en "Application Error"
+ ::msgcat::mcset en "&Apply"
+ ::msgcat::mcset en "Bold"
+ ::msgcat::mcset en "Bold Italic"
+ ::msgcat::mcset en "&Blue"
+ ::msgcat::mcset en "Cancel"
+ ::msgcat::mcset en "&Cancel"
+ ::msgcat::mcset en "Cannot change to the directory \"%1\$s\".\nPermission denied."
+ ::msgcat::mcset en "Choose Directory"
+ ::msgcat::mcset en "Cl&ear"
+ ::msgcat::mcset en "&Clear Console"
+ ::msgcat::mcset en "Color"
+ ::msgcat::mcset en "Console"
+ ::msgcat::mcset en "&Copy"
+ ::msgcat::mcset en "Cu&t"
+ ::msgcat::mcset en "&Delete"
+ ::msgcat::mcset en "Details >>"
+ ::msgcat::mcset en "Directory \"%1\$s\" does not exist."
+ ::msgcat::mcset en "&Directory:"
+ ::msgcat::mcset en "&Edit"
+ ::msgcat::mcset en "Effects"
+ ::msgcat::mcset en "Error: %1\$s"
+ ::msgcat::mcset en "E&xit"
+ ::msgcat::mcset en "&File"
+ ::msgcat::mcset en "File \"%1\$s\" already exists.\nDo you want to overwrite it?"
+ ::msgcat::mcset en "File \"%1\$s\" already exists.\n\n"
+ ::msgcat::mcset en "File \"%1\$s\" does not exist."
+ ::msgcat::mcset en "File &name:"
+ ::msgcat::mcset en "File &names:"
+ ::msgcat::mcset en "Files of &type:"
+ ::msgcat::mcset en "Fi&les:"
+ ::msgcat::mcset en "&Filter"
+ ::msgcat::mcset en "Fil&ter:"
+ ::msgcat::mcset en "Font"
+ ::msgcat::mcset en "&Font:"
+ ::msgcat::mcset en "Font st&yle:"
+ ::msgcat::mcset en "&Green"
+ ::msgcat::mcset en "&Help"
+ ::msgcat::mcset en "Hi"
+ ::msgcat::mcset en "&Hide Console"
+ ::msgcat::mcset en "&Ignore"
+ ::msgcat::mcset en "Invalid file name \"%1\$s\"."
+ ::msgcat::mcset en "Italic"
+ ::msgcat::mcset en "Log Files"
+ ::msgcat::mcset en "&No"
+ ::msgcat::mcset en "&OK"
+ ::msgcat::mcset en "OK"
+ ::msgcat::mcset en "Ok"
+ ::msgcat::mcset en "Open"
+ ::msgcat::mcset en "&Open"
+ ::msgcat::mcset en "Open Multiple Files"
+ ::msgcat::mcset en "P&aste"
+ ::msgcat::mcset en "&Quit"
+ ::msgcat::mcset en "&Red"
+ ::msgcat::mcset en "Regular"
+ ::msgcat::mcset en "Replace existing file?"
+ ::msgcat::mcset en "&Retry"
+ ::msgcat::mcset en "Sample"
+ ::msgcat::mcset en "&Save"
+ ::msgcat::mcset en "Save As"
+ ::msgcat::mcset en "Save To Log"
+ ::msgcat::mcset en "Select Log File"
+ ::msgcat::mcset en "Select a file to source"
+ ::msgcat::mcset en "&Selection:"
+ ::msgcat::mcset en "&Size:"
+ ::msgcat::mcset en "Show &Hidden Directories"
+ ::msgcat::mcset en "Show &Hidden Files and Directories"
+ ::msgcat::mcset en "Skip Messages"
+ ::msgcat::mcset en "&Source..."
+ ::msgcat::mcset en "Stri&keout"
+ ::msgcat::mcset en "Tcl Scripts"
+ ::msgcat::mcset en "Tcl for Windows"
+ ::msgcat::mcset en "Text Files"
+ ::msgcat::mcset en "&Underline"
+ ::msgcat::mcset en "&Yes"
+ ::msgcat::mcset en "abort"
+ ::msgcat::mcset en "blue"
+ ::msgcat::mcset en "cancel"
+ ::msgcat::mcset en "extension"
+ ::msgcat::mcset en "extensions"
+ ::msgcat::mcset en "green"
+ ::msgcat::mcset en "ignore"
+ ::msgcat::mcset en "ok"
+ ::msgcat::mcset en "red"
+ ::msgcat::mcset en "retry"
+ ::msgcat::mcset en "yes"
+}
+
+#localization of print terms by Kevin Walzer via Microsoft Translator
+namespace eval ::tk {
+ ::msgcat::mcset en "Print"
+ ::msgcat::mcset en "Printer"
+ ::msgcat::mcset en "Letter "
+ ::msgcat::mcset en "Legal "
+ ::msgcat::mcset en "A4"
+ ::msgcat::mcset en "Grayscale"
+ ::msgcat::mcset en "RGB"
+ ::msgcat::mcset en "Options"
+ ::msgcat::mcset en "Copies"
+ ::msgcat::mcset en "Paper"
+ ::msgcat::mcset en "Scale"
+ ::msgcat::mcset en "Orientation"
+ ::msgcat::mcset en "Portrait"
+ ::msgcat::mcset en "Landscape"
+ ::msgcat::mcset en "Output"
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/en.msg
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/en_gb.msg
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/en_gb.msg (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/en_gb.msg 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,3 @@
+namespace eval ::tk {
+ ::msgcat::mcset en_gb Color Colour
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/en_gb.msg
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/eo.msg
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/eo.msg (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/eo.msg 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,93 @@
+namespace eval ::tk {
+ ::msgcat::mcset eo "&Abort" "&Ĉesigu"
+ ::msgcat::mcset eo "&About..." "Pri..."
+ ::msgcat::mcset eo "All Files" "Ĉiuj dosieroj"
+ ::msgcat::mcset eo "Application Error" "Aplikoeraro"
+ ::msgcat::mcset eo "&Blue" "&Blua"
+ ::msgcat::mcset eo "Cancel" "Rezignu"
+ ::msgcat::mcset eo "&Cancel" "&Rezignu"
+ ::msgcat::mcset eo "Cannot change to the directory \"%1\$s\".\nPermission denied." "Neeble ŝanĝi al dosierujo \"%1\$s\".\nVi ne rajtas tion."
+ ::msgcat::mcset eo "Choose Directory" "Elektu Dosierujon"
+ ::msgcat::mcset eo "Cl&ear" "&Vakigu"
+ ::msgcat::mcset eo "&Clear Console" "&Vakigu konzolon"
+ ::msgcat::mcset eo "Color" "Koloro"
+ ::msgcat::mcset eo "Console" "Konzolo"
+ ::msgcat::mcset eo "&Copy" "&Kopiu"
+ ::msgcat::mcset eo "Cu&t" "&Eltondu"
+ ::msgcat::mcset eo "&Delete" "&Forigu"
+ ::msgcat::mcset eo "Details >>" "Detaloj >>"
+ ::msgcat::mcset eo "Directory \"%1\$s\" does not exist." "La dosierujo \"%1\$s\" ne ekzistas."
+ ::msgcat::mcset eo "&Directory:" "&Dosierujo:"
+ ::msgcat::mcset eo "&Edit" "&Redaktu"
+ ::msgcat::mcset eo "Error: %1\$s" "Eraro: %1\$s"
+ ::msgcat::mcset eo "E&xit" "&Eliru"
+ ::msgcat::mcset eo "&File" "&Dosiero"
+ ::msgcat::mcset eo "File \"%1\$s\" already exists.\nDo you want to overwrite it?" "La dosiero \"%1\$s\" jam ekzistas.\nĈu vi volas anstataŭigi la dosieron?"
+ ::msgcat::mcset eo "File \"%1\$s\" already exists.\n\n" "La dosiero \"%1\$s\" jam ekzistas. \n\n"
+ ::msgcat::mcset eo "File \"%1\$s\" does not exist." "La dosiero \"%1\$s\" ne ekzistas."
+ ::msgcat::mcset eo "File &name:" "Dosiero&nomo:"
+ ::msgcat::mcset eo "File &names:" "Dosiero&nomoj:"
+ ::msgcat::mcset eo "Files of &type:" "Dosieroj de &Tipo:"
+ ::msgcat::mcset eo "Fi&les:" "Do&sieroj:"
+ ::msgcat::mcset eo "&Filter" "&Filtrilo"
+ ::msgcat::mcset eo "Fil&ter:" "&Filtrilo:"
+ ::msgcat::mcset eo "&Green" "&Verda"
+ ::msgcat::mcset eo "&Help" "&Helpu"
+ ::msgcat::mcset eo "Hi" "Saluton"
+ ::msgcat::mcset eo "&Hide Console" "&Kaŝu konzolon"
+ ::msgcat::mcset eo "&Ignore" "&Ignoru"
+ ::msgcat::mcset eo "Invalid file name \"%1\$s\"." "Malvalida dosieronomo \"%1\$s\"."
+ ::msgcat::mcset eo "Log Files" "Protokolaj dosieroj"
+ ::msgcat::mcset eo "&No" "&Ne"
+ ::msgcat::mcset eo "&OK" "&Bone"
+ ::msgcat::mcset eo "OK" "Bone"
+ ::msgcat::mcset eo "Ok" "Bone"
+ ::msgcat::mcset eo "Open" "Malfermu"
+ ::msgcat::mcset eo "&Open" "&Malfermu"
+ ::msgcat::mcset eo "Open Multiple Files" "Malfermu plurajn dosierojn"
+ ::msgcat::mcset eo "P&aste" "&Algluu"
+ ::msgcat::mcset eo "&Quit" "&Forlasu"
+ ::msgcat::mcset eo "&Red" "&Ruĝa"
+ ::msgcat::mcset eo "Replace existing file?" "Ĉu anstataŭigi ekzistantan dosieron?"
+ ::msgcat::mcset eo "&Retry" "&Reprovu"
+ ::msgcat::mcset eo "&Save" "&Konservu"
+ ::msgcat::mcset eo "Save As" "Konservu kiel"
+ ::msgcat::mcset eo "Save To Log" "Konservu en protokolon"
+ ::msgcat::mcset eo "Select Log File" "Elektu prokolodosieron"
+ ::msgcat::mcset eo "Select a file to source" "Elektu dosieron por interpreti"
+ ::msgcat::mcset eo "&Selection:" "&Elekto:"
+ ::msgcat::mcset eo "Skip Messages" "transsaltu mesaĝojn"
+ ::msgcat::mcset eo "&Source..." "&Fontoprogramo..."
+ ::msgcat::mcset eo "Tcl Scripts" "Tcl-skriptoj"
+ ::msgcat::mcset eo "Tcl for Windows" "Tcl por Vindozo"
+ ::msgcat::mcset eo "Text Files" "Tekstodosieroj"
+ ::msgcat::mcset eo "&Yes" "&Jes"
+ ::msgcat::mcset eo "abort" "ĉesigu"
+ ::msgcat::mcset eo "blue" "blua"
+ ::msgcat::mcset eo "cancel" "rezignu"
+ ::msgcat::mcset eo "extension" "kromprogramo"
+ ::msgcat::mcset eo "extensions" "kromprogramoj"
+ ::msgcat::mcset eo "green" "verda"
+ ::msgcat::mcset eo "ignore" "ignoru"
+ ::msgcat::mcset eo "red" "ruĝa"
+ ::msgcat::mcset eo "retry" "reprovu"
+ ::msgcat::mcset eo "yes" "jes"
+}
+#localization of print terms by Kevin Walzer via Microsoft Translator
+namespace eval ::tk {
+ ::msgcat::mcset eo "Print" "Presi"
+ ::msgcat::mcset eo "Printer" "Presilo"
+ ::msgcat::mcset eo "Letter " "Letero"
+ ::msgcat::mcset eo "Legal " "Laŭleĝa"
+ ::msgcat::mcset eo "A4" "A4"
+ ::msgcat::mcset eo "Grayscale" "Grizskalo"
+ ::msgcat::mcset eo "RGB" "RGB"
+ ::msgcat::mcset eo "Options" "Opcioj"
+ ::msgcat::mcset eo "Copies" "Kopioj"
+ ::msgcat::mcset eo "Paper" "Papero"
+ ::msgcat::mcset eo "Scale" "Skalo"
+ ::msgcat::mcset eo "Orientation" "Orientiĝo"
+ ::msgcat::mcset eo "Portrait" "Portreto"
+ ::msgcat::mcset eo "Landscape" "Pejzaĝo"
+ ::msgcat::mcset eo "Output" "Eligo"
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/eo.msg
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/es.msg
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/es.msg (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/es.msg 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,94 @@
+namespace eval ::tk {
+ ::msgcat::mcset es "&Abort" "&Abortar"
+ ::msgcat::mcset es "&About..." "&Acerca de ..."
+ ::msgcat::mcset es "All Files" "Todos los archivos"
+ ::msgcat::mcset es "Application Error" "Error de la aplicación"
+ ::msgcat::mcset es "&Blue" "&Azul"
+ ::msgcat::mcset es "Cancel" "Cancelar"
+ ::msgcat::mcset es "&Cancel" "&Cancelar"
+ ::msgcat::mcset es "Cannot change to the directory \"%1\$s\".\nPermission denied." "No es posible acceder al directorio \"%1\$s\".\nPermiso denegado."
+ ::msgcat::mcset es "Choose Directory" "Elegir directorio"
+ ::msgcat::mcset es "Cl&ear" "&Borrar"
+ ::msgcat::mcset es "&Clear Console" "&Borrar consola"
+ ::msgcat::mcset es "Color"
+ ::msgcat::mcset es "Console" "Consola"
+ ::msgcat::mcset es "&Copy" "&Copiar"
+ ::msgcat::mcset es "Cu&t" "Cor&tar"
+ ::msgcat::mcset es "&Delete" "&Borrar"
+ ::msgcat::mcset es "Details >>" "Detalles >>"
+ ::msgcat::mcset es "Directory \"%1\$s\" does not exist." "El directorio \"%1\$s\" no existe."
+ ::msgcat::mcset es "&Directory:" "&Directorio:"
+ ::msgcat::mcset es "&Edit" "&Editar"
+ ::msgcat::mcset es "Error: %1\$s"
+ ::msgcat::mcset es "E&xit" "Salir"
+ ::msgcat::mcset es "&File" "&Archivo"
+ ::msgcat::mcset es "File \"%1\$s\" already exists.\nDo you want to overwrite it?" "El archivo \"%1\$s\" ya existe.\n¿Desea sobreescribirlo?"
+ ::msgcat::mcset es "File \"%1\$s\" already exists.\n\n" "El archivo \"%1\$s\" ya existe.\n\n"
+ ::msgcat::mcset es "File \"%1\$s\" does not exist." "El archivo \"%1\$s\" no existe."
+ ::msgcat::mcset es "File &name:" "&Nombre de archivo:"
+ ::msgcat::mcset es "File &names:" "&Nombres de archivo:"
+ ::msgcat::mcset es "Files of &type:" "Archivos de &tipo:"
+ ::msgcat::mcset es "Fi&les:" "&Archivos:"
+ ::msgcat::mcset es "&Filter" "&Filtro"
+ ::msgcat::mcset es "Fil&ter:" "Fil&tro:"
+ ::msgcat::mcset es "&Green" "&Verde"
+ ::msgcat::mcset es "&Help" "&Ayuda"
+ ::msgcat::mcset es "Hi" "Hola"
+ ::msgcat::mcset es "&Hide Console" "&Esconder la consola"
+ ::msgcat::mcset es "&Ignore" "&Ignorar"
+ ::msgcat::mcset es "Invalid file name \"%1\$s\"." "Nombre de archivo inválido \"%1\$s\"."
+ ::msgcat::mcset es "Log Files" "Ficheros de traza"
+ ::msgcat::mcset es "&No"
+ ::msgcat::mcset es "&OK"
+ ::msgcat::mcset es "OK"
+ ::msgcat::mcset es "Ok"
+ ::msgcat::mcset es "Open" "Abrir"
+ ::msgcat::mcset es "&Open" "&Abrir"
+ ::msgcat::mcset es "Open Multiple Files" "Abrir múltiples archivos"
+ ::msgcat::mcset es "P&aste" "Peg&ar"
+ ::msgcat::mcset es "&Quit" "&Abandonar"
+ ::msgcat::mcset es "&Red" "&Rojo"
+ ::msgcat::mcset es "Replace existing file?" "¿Reemplazar el archivo existente?"
+ ::msgcat::mcset es "&Retry" "&Reintentar"
+ ::msgcat::mcset es "&Save" "&Guardar"
+ ::msgcat::mcset es "Save As" "Guardar como"
+ ::msgcat::mcset es "Save To Log" "Guardar al archivo de traza"
+ ::msgcat::mcset es "Select Log File" "Elegir un archivo de traza"
+ ::msgcat::mcset es "Select a file to source" "Seleccionar un archivo a evaluar"
+ ::msgcat::mcset es "&Selection:" "&Selección:"
+ ::msgcat::mcset es "Skip Messages" "Omitir los mensajes"
+ ::msgcat::mcset es "&Source..." "E&valuar..."
+ ::msgcat::mcset es "Tcl Scripts" "Scripts Tcl"
+ ::msgcat::mcset es "Tcl for Windows" "Tcl para Windows"
+ ::msgcat::mcset es "Text Files" "Archivos de texto"
+ ::msgcat::mcset es "&Yes" "&Sí"
+ ::msgcat::mcset es "abort" "abortar"
+ ::msgcat::mcset es "blue" "azul"
+ ::msgcat::mcset es "cancel" "cancelar"
+ ::msgcat::mcset es "extension" "extensión"
+ ::msgcat::mcset es "extensions" "extensiones"
+ ::msgcat::mcset es "green" "verde"
+ ::msgcat::mcset es "ignore" "ignorar"
+ ::msgcat::mcset es "ok"
+ ::msgcat::mcset es "red" "rojo"
+ ::msgcat::mcset es "retry" "reintentar"
+ ::msgcat::mcset es "yes" "sí"
+}
+#localization of print terms by Kevin Walzer via Microsoft Translator
+namespace eval ::tk {
+ ::msgcat::mcset es "Print" "Imprimir"
+ ::msgcat::mcset es "Printer" "Impresora"
+ ::msgcat::mcset es "Letter" "Carta"
+ ::msgcat::mcset es "Legal" "Legal"
+ ::msgcat::mcset es "A4" "A4"
+ ::msgcat::mcset es "Grayscale" "Escala De Grises"
+ ::msgcat::mcset es "RGB" "Color"
+ ::msgcat::mcset es "Options" "Opciones"
+ ::msgcat::mcset es "Copies" "Copias"
+ ::msgcat::mcset es "Paper" "Papel"
+ ::msgcat::mcset es "Scale" "Escala"
+ ::msgcat::mcset es "Orientation" "Orientación"
+ ::msgcat::mcset es "Portrait" "Retrato"
+ ::msgcat::mcset es "Landscape" "Paisaje"
+ ::msgcat::mcset es "Output" "Salida"
+}
\ No newline at end of file
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/es.msg
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/fi.msg
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/fi.msg (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/fi.msg 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,114 @@
+namespace eval ::tk {
+ ::msgcat::mcset fi "AaBbYyZz01" "AaBbÄäÖö01"
+ ::msgcat::mcset fi "&Abort" "&Keskeytä"
+ ::msgcat::mcset fi "&About..." "&Tietoja..."
+ ::msgcat::mcset fi "All Files" "Kaikki tiedostot"
+ ::msgcat::mcset fi "&Apply" "Kä&ytä"
+ ::msgcat::mcset fi "Application Error" "Ohjelmavirhe"
+ ::msgcat::mcset fi "&Blue" "&Sininen"
+ ::msgcat::mcset fi "Bold" "Lihavoitu"
+ ::msgcat::mcset fi "Bold Italic" "Lihavoitu, kursivoitu"
+ ::msgcat::mcset fi "Cancel" "Peruuta"
+ ::msgcat::mcset fi "&Cancel" "&Peruuta"
+ ::msgcat::mcset fi "Cannot change to the directory \"%1\$s\".\nPermission denied." "Ei voitu vaihtaa hakemistoon \"%1\$s\".\nLupa evätty."
+ ::msgcat::mcset fi "Choose Directory" "Valitse hakemisto"
+ ::msgcat::mcset fi "Cl&ear" "&Tyhjennä"
+ ::msgcat::mcset fi "&Clear Console" "&Tyhjennä konsoli"
+ ::msgcat::mcset fi "Color" "Väri"
+ ::msgcat::mcset fi "Console" "Konsoli"
+ ::msgcat::mcset fi "&Copy" "K&opioi"
+ ::msgcat::mcset fi "Cu&t" "&Leikkaa"
+ ::msgcat::mcset fi "&Decrease Font Size" "&Pienennä kirjasinkokoa"
+ ::msgcat::mcset fi "&Delete" "&Poista"
+ ::msgcat::mcset fi "Details >>" "Lisätiedot >>"
+ ::msgcat::mcset fi "Directory \"%1\$s\" does not exist." "Hakemistoa \"%1\$s\" ei ole olemassa."
+ ::msgcat::mcset fi "&Directory:" "&Hakemisto:"
+ ::msgcat::mcset fi "&Edit" "&Muokkaa"
+ ::msgcat::mcset fi "Effects" "Tehosteet"
+ ::msgcat::mcset fi "Error: %1\$s" "Virhe: %1\$s"
+ ::msgcat::mcset fi "E&xit" "&Lopeta"
+ ::msgcat::mcset fi "&File" "&Tiedosto"
+ ::msgcat::mcset fi "File \"%1\$s\" already exists.\nDo you want to overwrite it?" "Tiedosto \"%1\$s\" on jo olemassa.\nHaluatko korvata sen?"
+ ::msgcat::mcset fi "File \"%1\$s\" already exists.\n\n" "Tiedosto \"%1\$s\" on jo olemassa.\n\n"
+ ::msgcat::mcset fi "File \"%1\$s\" does not exist." "Tiedostoa \"%1\$s\" ei ole olemassa."
+ ::msgcat::mcset fi "File &name:" "Tiedosto&nimi:"
+ ::msgcat::mcset fi "File &names:" "Tiedosto&nimet:"
+ ::msgcat::mcset fi "Files of &type:" "T&yyppi:"
+ ::msgcat::mcset fi "Fi&les:" "Ti&edostot:"
+ ::msgcat::mcset fi "&Filter" "&Suodata"
+ ::msgcat::mcset fi "Fil&ter:" "Suo&data:"
+ ::msgcat::mcset fi "Fit To Screen Width" "Sovita ruudun kokoon"
+ ::msgcat::mcset fi "Font" "Kirjasin"
+ ::msgcat::mcset fi "&Font..." "Kir&jasin..."
+ ::msgcat::mcset fi "&Font:" "&Kirjasin:"
+ ::msgcat::mcset fi "Font st&yle:" "Kirjasint&yyli:"
+ ::msgcat::mcset fi "&Green" "&Vihreä"
+ ::msgcat::mcset fi "Help" "Ohje"
+ ::msgcat::mcset fi "&Help" "&Ohje"
+ ::msgcat::mcset fi "Hi" "Hei"
+ ::msgcat::mcset fi "&Hide Console" "P&iilota konsoli"
+ ::msgcat::mcset fi "Hide Fonts" "Piilota kirjasimet"
+ ::msgcat::mcset fi "&Ignore" "&Ohita"
+ ::msgcat::mcset fi "&Increase Font Size" "&Suurenna kirjasinkokoa"
+ ::msgcat::mcset fi "Invalid file name \"%1\$s\"." "Virheellinen tiedostonimi \"%1\$s\"."
+ ::msgcat::mcset fi "Italic" "Kursivoitu"
+ ::msgcat::mcset fi "Log Files" "Lokitiedostot"
+ ::msgcat::mcset fi "&No" "&Ei"
+ ::msgcat::mcset fi "&OK"
+ ::msgcat::mcset fi "OK"
+ ::msgcat::mcset fi "Ok" "OK"
+ ::msgcat::mcset fi "Open" "Avaa"
+ ::msgcat::mcset fi "&Open" "&Avaa"
+ ::msgcat::mcset fi "Open Multiple Files" "Avaa monta tiedostoa"
+ ::msgcat::mcset fi "P&aste" "L&iitä"
+ ::msgcat::mcset fi "&Quit" "&Lopeta"
+ ::msgcat::mcset fi "&Red" "&Punainen"
+ ::msgcat::mcset fi "Regular" "Tavallinen"
+ ::msgcat::mcset fi "Replace existing file?" "Korvataanko olemassaoleva tiedosto?"
+ ::msgcat::mcset fi "&Retry" "&Yritä uudelleen"
+ ::msgcat::mcset fi "Sample" "Malli"
+ ::msgcat::mcset fi "&Save" "&Tallenna"
+ ::msgcat::mcset fi "Save As" "Tallenna nimellä"
+ ::msgcat::mcset fi "Save To Log" "Tallenna lokiin"
+ ::msgcat::mcset fi "Select Log File" "Valitse lokitiedosto"
+ ::msgcat::mcset fi "Select a file to source" "Valitse lähdetiedosto"
+ ::msgcat::mcset fi "&Selection:" "&Valinta:"
+ ::msgcat::mcset fi "Show Fonts" "Näytä kirjasimet"
+ ::msgcat::mcset fi "Skip Messages" "Jätä viestit huomiotta"
+ ::msgcat::mcset fi "&Size:" "K&oko:"
+ ::msgcat::mcset fi "&Source..." "L&ähde..."
+ ::msgcat::mcset fi "Stri&keout" "&Yliviivaa"
+ ::msgcat::mcset fi "Tcl Scripts" "Tcl-skriptit"
+ ::msgcat::mcset fi "Tcl for Windows" "Tcl Windowsille"
+ ::msgcat::mcset fi "Text Files" "Tekstitiedostot"
+ ::msgcat::mcset fi "&Underline" "&Alleviivaa"
+ ::msgcat::mcset fi "Window" "Ikkuna"
+ ::msgcat::mcset fi "&Yes" "&Kyllä"
+ ::msgcat::mcset fi "abort" "keskeytä"
+ ::msgcat::mcset fi "blue" "sininen"
+ ::msgcat::mcset fi "cancel" "peruuta"
+ ::msgcat::mcset fi "extension" "lisäosa"
+ ::msgcat::mcset fi "extensions" "lisäosat"
+ ::msgcat::mcset fi "green" "vihreä"
+ ::msgcat::mcset fi "ignore" "ohita"
+ ::msgcat::mcset fi "ok"
+ ::msgcat::mcset fi "red" "punainen"
+ ::msgcat::mcset fi "retry" "yritä uudelleen"
+ ::msgcat::mcset fi "yes" "kyllä"
+
+ ::msgcat::mcset fi "Print" "Tulosta"
+ ::msgcat::mcset fi "Printer" "Tulostin"
+ ::msgcat::mcset fi "Letter " "Letter"
+ ::msgcat::mcset fi "Legal " "Legal"
+ ::msgcat::mcset fi "A4" "A4"
+ ::msgcat::mcset fi "Grayscale" "Harmaasävy"
+ ::msgcat::mcset fi "RGB" "RGB"
+ ::msgcat::mcset fi "Options" "Asetukset"
+ ::msgcat::mcset fi "Copies" "Tulosteita"
+ ::msgcat::mcset fi "Paper" "Paperikoko"
+ ::msgcat::mcset fi "Scale" "Skaalaus"
+ ::msgcat::mcset fi "Orientation" "Suunta"
+ ::msgcat::mcset fi "Portrait" "Pysty"
+ ::msgcat::mcset fi "Landscape" "Vaaka"
+ ::msgcat::mcset fi "Output" "Tulos"
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/fi.msg
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/fr.msg
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/fr.msg (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/fr.msg 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,90 @@
+namespace eval ::tk {
+ ::msgcat::mcset fr "&Abort" "&Annuler"
+ ::msgcat::mcset fr "About..." "À propos..."
+ ::msgcat::mcset fr "All Files" "Tous les fichiers"
+ ::msgcat::mcset fr "Application Error" "Erreur d'application"
+ ::msgcat::mcset fr "&Blue" "&Bleu"
+ ::msgcat::mcset fr "Cancel" "Annuler"
+ ::msgcat::mcset fr "&Cancel" "&Annuler"
+ ::msgcat::mcset fr "Cannot change to the directory \"%1\$s\".\nPermission denied." "Impossible d'accéder au répertoire \"%1\$s\".\nPermission refusée."
+ ::msgcat::mcset fr "Choose Directory" "Choisir répertoire"
+ ::msgcat::mcset fr "Cl&ear" "Effacer"
+ ::msgcat::mcset fr "Color" "Couleur"
+ ::msgcat::mcset fr "Console"
+ ::msgcat::mcset fr "Copy" "Copier"
+ ::msgcat::mcset fr "Cu&t" "Couper"
+ ::msgcat::mcset fr "Delete" "Effacer"
+ ::msgcat::mcset fr "Details >>" "Détails >>"
+ ::msgcat::mcset fr "Directory \"%1\$s\" does not exist." "Le répertoire \"%1\$s\" n'existe pas."
+ ::msgcat::mcset fr "&Directory:" "&Répertoire:"
+ ::msgcat::mcset fr "Error: %1\$s" "Erreur: %1\$s"
+ ::msgcat::mcset fr "E&xit" "Quitter"
+ ::msgcat::mcset fr "File \"%1\$s\" already exists.\nDo you want to overwrite it?" "Le fichier \"%1\$s\" existe déjà.\nVoulez-vous l'écraser?"
+ ::msgcat::mcset fr "File \"%1\$s\" already exists.\n\n" "Le fichier \"%1\$s\" existe déjà.\n\n"
+ ::msgcat::mcset fr "File \"%1\$s\" does not exist." "Le fichier \"%1\$s\" n'existe pas."
+ ::msgcat::mcset fr "File &name:" "&Nom de fichier:"
+ ::msgcat::mcset fr "File &names:" "&Noms de fichiers:"
+ ::msgcat::mcset fr "Files of &type:" "&Type de fichiers:"
+ ::msgcat::mcset fr "Fi&les:" "Fich&iers:"
+ ::msgcat::mcset fr "&Filter" "&Filtre"
+ ::msgcat::mcset fr "Fil&ter:" "Fil&tre:"
+ ::msgcat::mcset fr "&Green" "&Vert"
+ ::msgcat::mcset fr "Hi" "Salut"
+ ::msgcat::mcset fr "&Hide Console" "Cacher la Console"
+ ::msgcat::mcset fr "&Ignore" "&Ignorer"
+ ::msgcat::mcset fr "Invalid file name \"%1\$s\"." "Nom de fichier invalide \"%1\$s\"."
+ ::msgcat::mcset fr "Log Files" "Fichiers de trace"
+ ::msgcat::mcset fr "&No" "&Non"
+ ::msgcat::mcset fr "&OK"
+ ::msgcat::mcset fr "OK"
+ ::msgcat::mcset fr "Ok"
+ ::msgcat::mcset fr "Open" "Ouvrir"
+ ::msgcat::mcset fr "&Open" "&Ouvrir"
+ ::msgcat::mcset fr "Open Multiple Files" "Ouvrir plusieurs fichiers"
+ ::msgcat::mcset fr "P&aste" "Coller"
+ ::msgcat::mcset fr "&Quit" "&Quitter"
+ ::msgcat::mcset fr "&Red" "&Rouge"
+ ::msgcat::mcset fr "Replace existing file?" "Remplacer le fichier existant?"
+ ::msgcat::mcset fr "&Retry" "&Ré-essayer"
+ ::msgcat::mcset fr "&Save" "&Sauvegarder"
+ ::msgcat::mcset fr "Save As" "Sauvegarder sous"
+ ::msgcat::mcset fr "Save To Log" "Sauvegarde au fichier de trace"
+ ::msgcat::mcset fr "Select Log File" "Choisir un fichier de trace"
+ ::msgcat::mcset fr "Select a file to source" "Choisir un fichier à évaluer"
+ ::msgcat::mcset fr "&Selection:" "&Sélection:"
+ ::msgcat::mcset fr "Skip Messages" "Omettre les messages"
+ ::msgcat::mcset fr "&Source..." "Évaluer..."
+ ::msgcat::mcset fr "Tcl Scripts" "Scripts Tcl"
+ ::msgcat::mcset fr "Tcl for Windows" "Tcl pour Windows"
+ ::msgcat::mcset fr "Text Files" "Fichiers texte"
+ ::msgcat::mcset fr "&Yes" "&Oui"
+ ::msgcat::mcset fr "abort" "abandonner"
+ ::msgcat::mcset fr "blue" "bleu"
+ ::msgcat::mcset fr "cancel" "annuler"
+ ::msgcat::mcset fr "extension"
+ ::msgcat::mcset fr "extensions"
+ ::msgcat::mcset fr "green" "vert"
+ ::msgcat::mcset fr "ignore" "ignorer"
+ ::msgcat::mcset fr "ok"
+ ::msgcat::mcset fr "red" "rouge"
+ ::msgcat::mcset fr "retry" "réessayer"
+ ::msgcat::mcset fr "yes" "oui"
+}
+#localization of print terms by Kevin Walzer via Microsoft Translator
+namespace eval ::tk {
+ ::msgcat::mcset fr "Print" "Imprimer"
+ ::msgcat::mcset fr "Printer" "Imprimante"
+ ::msgcat::mcset fr "Letter " "Lettre"
+ ::msgcat::mcset fr "Legal " "Légal"
+ ::msgcat::mcset fr "A4" "A4"
+ ::msgcat::mcset fr "Grayscale" "Niveaux de Gris"
+ ::msgcat::mcset fr "RGB" "RVB"
+ ::msgcat::mcset fr "Options" "Options"
+ ::msgcat::mcset fr "Copies" "Nombre d'exemplaires"
+ ::msgcat::mcset fr "Paper" "Papier"
+ ::msgcat::mcset fr "Scale" "Échelle"
+ ::msgcat::mcset fr "Orientation" "Orientation"
+ ::msgcat::mcset fr "Portrait" "Portrait"
+ ::msgcat::mcset fr "Landscape" "Paysage"
+ ::msgcat::mcset fr "Output" "Sortie"
+}
\ No newline at end of file
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/fr.msg
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/hu.msg
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/hu.msg (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/hu.msg 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,96 @@
+namespace eval ::tk {
+ ::msgcat::mcset hu "&Abort" "&Megszakítás"
+ ::msgcat::mcset hu "&About..." "Névjegy..."
+ ::msgcat::mcset hu "All Files" "Minden fájl"
+ ::msgcat::mcset hu "Application Error" "Alkalmazás hiba"
+ ::msgcat::mcset hu "&Blue" "&Kék"
+ ::msgcat::mcset hu "Cancel" "Mégsem"
+ ::msgcat::mcset hu "&Cancel" "Még&sem"
+ ::msgcat::mcset hu "Cannot change to the directory \"%1\$s\".\nPermission denied." "A könyvtárváltás nem sikerült: \"%1\$s\".\nHozzáférés megtagadva."
+ ::msgcat::mcset hu "Choose Directory" "Könyvtár kiválasztása"
+ ::msgcat::mcset hu "Cl&ear" "Törlés"
+ ::msgcat::mcset hu "&Clear Console" "&Törlés Konzol"
+ ::msgcat::mcset hu "Color" "Szín"
+ ::msgcat::mcset hu "Console" "Konzol"
+ ::msgcat::mcset hu "&Copy" "&Másolás"
+ ::msgcat::mcset hu "Cu&t" "&Kivágás"
+ ::msgcat::mcset hu "&Delete" "&Törlés"
+ ::msgcat::mcset hu "Details >>" "Részletek >>"
+ ::msgcat::mcset hu "Directory \"%1\$s\" does not exist." "\"%1\$s\" könyvtár nem létezik."
+ ::msgcat::mcset hu "&Directory:" "&Könyvtár:"
+ #::msgcat::mcset hu "&Edit"
+ ::msgcat::mcset hu "Error: %1\$s" "Hiba: %1\$s"
+ ::msgcat::mcset hu "E&xit" "Kilépés"
+ ::msgcat::mcset hu "&File" "&Fájl"
+ ::msgcat::mcset hu "File \"%1\$s\" already exists.\nDo you want to overwrite it?" "\"%1\$s\" fájl már létezik.\nFelülírjam?"
+ ::msgcat::mcset hu "File \"%1\$s\" already exists.\n\n" "\"%1\$s\" fájl már létezik.\n\n"
+ ::msgcat::mcset hu "File \"%1\$s\" does not exist." "\"%1\$s\" fájl nem létezik."
+ ::msgcat::mcset hu "File &name:" "Fájl &neve:"
+ ::msgcat::mcset hu "File &names:" "Fájlok &nevei:"
+ ::msgcat::mcset hu "Files of &type:" "Fájlok &típusa:"
+ ::msgcat::mcset hu "Fi&les:" "Fáj&lok:"
+ ::msgcat::mcset hu "&Filter" "&Szűrő"
+ ::msgcat::mcset hu "Fil&ter:" "S&zűrő:"
+ ::msgcat::mcset hu "&Green" "&Zöld"
+ #::msgcat::mcset hu "&Help"
+ ::msgcat::mcset hu "Hi" "Üdv"
+ ::msgcat::mcset hu "&Hide Console" "Konzol &elrejtése"
+ ::msgcat::mcset hu "&Ignore" "K&ihagyás"
+ ::msgcat::mcset hu "Invalid file name \"%1\$s\"." "Érvénytelen fájlnév: \"%1\$s\"."
+ ::msgcat::mcset hu "Log Files" "Log fájlok"
+ ::msgcat::mcset hu "&No" "&Nem"
+ ::msgcat::mcset hu "&OK"
+ ::msgcat::mcset hu "OK"
+ ::msgcat::mcset hu "Ok"
+ ::msgcat::mcset hu "Open" "Megnyitás"
+ ::msgcat::mcset hu "&Open" "&Megnyitás"
+ ::msgcat::mcset hu "Open Multiple Files" "Több fájl megnyitása"
+ ::msgcat::mcset hu "P&aste" "&Beillesztés"
+ ::msgcat::mcset hu "&Quit" "&Kilépés"
+ ::msgcat::mcset hu "&Red" "&Vörös"
+ ::msgcat::mcset hu "Replace existing file?" "Meglévő fájl cseréje?"
+ ::msgcat::mcset hu "&Retry" "Új&ra"
+ ::msgcat::mcset hu "&Save" "&Mentés"
+ ::msgcat::mcset hu "Save As" "Mentés másként"
+ ::msgcat::mcset hu "Save To Log" "Mentés log fájlba"
+ ::msgcat::mcset hu "Select Log File" "Log fájl kiválasztása"
+ ::msgcat::mcset hu "Select a file to source" "Forrásfájl kiválasztása"
+ ::msgcat::mcset hu "&Selection:" "&Kijelölés:"
+ ::msgcat::mcset hu "Show &Hidden Directories" "&Rejtett könyvtárak megjelenítése"
+ ::msgcat::mcset hu "Show &Hidden Files and Directories" "&Rejtett fájlok és könyvtárak megjelenítése"
+ ::msgcat::mcset hu "Skip Messages" "Üzenetek kihagyása"
+ ::msgcat::mcset hu "&Source..." "&Forrás..."
+ ::msgcat::mcset hu "Tcl Scripts" "Tcl scriptek"
+ ::msgcat::mcset hu "Tcl for Windows" "Tcl Windows-hoz"
+ ::msgcat::mcset hu "Text Files" "Szövegfájlok"
+ ::msgcat::mcset hu "&Yes" "&Igen"
+ ::msgcat::mcset hu "abort" "megszakítás"
+ ::msgcat::mcset hu "blue" "kék"
+ ::msgcat::mcset hu "cancel" "mégsem"
+ ::msgcat::mcset hu "extension" "kiterjesztés"
+ ::msgcat::mcset hu "extensions" "kiterjesztések"
+ ::msgcat::mcset hu "green" "zöld"
+ ::msgcat::mcset hu "ignore" "ignorer"
+ ::msgcat::mcset hu "ok"
+ ::msgcat::mcset hu "red" "vörös"
+ ::msgcat::mcset hu "retry" "újra"
+ ::msgcat::mcset hu "yes" "igen"
+}
+#localization of print terms by Kevin Walzer via Microsoft Translator
+namespace eval ::tk {
+ ::msgcat::mcset hu "Print" "Nyomtat"
+ ::msgcat::mcset hu "Printer" "Nyomtató"
+ ::msgcat::mcset hu "Letter " "Levél"
+ ::msgcat::mcset hu "Legal " "Törvényes"
+ ::msgcat::mcset hu "A4" "A4"
+ ::msgcat::mcset hu "Grayscale" "Szürkeárnyalatos"
+ ::msgcat::mcset hu "RGB" "Rgb"
+ ::msgcat::mcset hu "Options" "Beállítások"
+ ::msgcat::mcset hu "Copies" "Másolatok"
+ ::msgcat::mcset hu "Paper" "Papír"
+ ::msgcat::mcset hu "Scale" "Hangsor"
+ ::msgcat::mcset hu "Orientation" "Tájékozódás"
+ ::msgcat::mcset hu "Portrait" "Portré"
+ ::msgcat::mcset hu "Landscape" "Táj"
+ ::msgcat::mcset hu "Output" "Hozam"
+}
\ No newline at end of file
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/hu.msg
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/it.msg
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/it.msg (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/it.msg 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,91 @@
+namespace eval ::tk {
+ ::msgcat::mcset it "&Abort" "&Interrompi"
+ ::msgcat::mcset it "&About..." "Informazioni..."
+ ::msgcat::mcset it "All Files" "Tutti i file"
+ ::msgcat::mcset it "Application Error" "Errore dell' applicazione"
+ ::msgcat::mcset it "&Blue" "&Blu"
+ ::msgcat::mcset it "Cancel" "Annulla"
+ ::msgcat::mcset it "&Cancel" "&Annulla"
+ ::msgcat::mcset it "Cannot change to the directory \"%1\$s\".\nPermission denied." "Impossibile accedere alla directory \"%1\$s\".\nPermesso negato."
+ ::msgcat::mcset it "Choose Directory" "Scegli una directory"
+ ::msgcat::mcset it "Cl&ear" "Azzera"
+ ::msgcat::mcset it "&Clear Console" "Azzera Console"
+ ::msgcat::mcset it "Color" "Colore"
+ ::msgcat::mcset it "Console"
+ ::msgcat::mcset it "&Copy" "Copia"
+ ::msgcat::mcset it "Cu&t" "Taglia"
+ ::msgcat::mcset it "Delete" "Cancella"
+ ::msgcat::mcset it "Details >>" "Dettagli >>"
+ ::msgcat::mcset it "Directory \"%1\$s\" does not exist." "La directory \"%1\$s\" non esiste."
+ ::msgcat::mcset it "&Directory:"
+ ::msgcat::mcset it "Error: %1\$s" "Errore: %1\$s"
+ ::msgcat::mcset it "E&xit" "Esci"
+ ::msgcat::mcset it "File \"%1\$s\" already exists.\nDo you want to overwrite it?" "Il file \"%1\$s\" esiste già.\nVuoi sovrascriverlo?"
+ ::msgcat::mcset it "File \"%1\$s\" already exists.\n\n" "Il file \"%1\$s\" esiste già.\n\n"
+ ::msgcat::mcset it "File \"%1\$s\" does not exist." "Il file \"%1\$s\" non esiste."
+ ::msgcat::mcset it "File &name:" "&Nome del file:"
+ ::msgcat::mcset it "File &names:" "&Nomi dei file:"
+ ::msgcat::mcset it "Files of &type:" "File di &tipo:"
+ ::msgcat::mcset it "Fi&les:" "Fi&le:"
+ ::msgcat::mcset it "&Filter" "&Filtro"
+ ::msgcat::mcset it "Fil&ter:" "Fil&tro:"
+ ::msgcat::mcset it "&Green" "&Verde"
+ ::msgcat::mcset it "Hi" "Salve"
+ ::msgcat::mcset it "&Hide Console" "Nascondi la console"
+ ::msgcat::mcset it "&Ignore" "&Ignora"
+ ::msgcat::mcset it "Invalid file name \"%1\$s\"." "Nome di file non valido \"%1\$s\"."
+ ::msgcat::mcset it "Log Files" "File di log"
+ ::msgcat::mcset it "&No"
+ ::msgcat::mcset it "&OK"
+ ::msgcat::mcset it "OK"
+ ::msgcat::mcset it "Ok"
+ ::msgcat::mcset it "Open" "Apri"
+ ::msgcat::mcset it "&Open" "A&pri"
+ ::msgcat::mcset it "Open Multiple Files" "Apri file multipli"
+ ::msgcat::mcset it "P&aste" "Incolla"
+ ::msgcat::mcset it "&Quit" "Esci"
+ ::msgcat::mcset it "&Red" "&Rosso"
+ ::msgcat::mcset it "Replace existing file?" "Sostituisci il file esistente?"
+ ::msgcat::mcset it "&Retry" "&Riprova"
+ ::msgcat::mcset it "&Save" "&Salva"
+ ::msgcat::mcset it "Save As" "Salva come"
+ ::msgcat::mcset it "Save To Log" "Salva il log"
+ ::msgcat::mcset it "Select Log File" "Scegli un file di log"
+ ::msgcat::mcset it "Select a file to source" "Scegli un file da eseguire"
+ ::msgcat::mcset it "&Selection:" "&Selezione:"
+ ::msgcat::mcset it "Skip Messages" "Salta i messaggi"
+ ::msgcat::mcset it "Source..." "Esegui..."
+ ::msgcat::mcset it "Tcl Scripts" "Script Tcl"
+ ::msgcat::mcset it "Tcl for Windows" "Tcl per Windows"
+ ::msgcat::mcset it "Text Files" "File di testo"
+ ::msgcat::mcset it "&Yes" "&Sì"
+ ::msgcat::mcset it "abort" "interrompi"
+ ::msgcat::mcset it "blue" "blu"
+ ::msgcat::mcset it "cancel" "annulla"
+ ::msgcat::mcset it "extension" "estensione"
+ ::msgcat::mcset it "extensions" "estensioni"
+ ::msgcat::mcset it "green" "verde"
+ ::msgcat::mcset it "ignore" "ignora"
+ ::msgcat::mcset it "ok"
+ ::msgcat::mcset it "red" "rosso"
+ ::msgcat::mcset it "retry" "riprova"
+ ::msgcat::mcset it "yes" "sì"
+}
+#localization of print terms by Kevin Walzer via Microsoft Translator
+namespace eval ::tk {
+ ::msgcat::mcset it "Print" "Stampare"
+ ::msgcat::mcset it "Printer" "Stampante"
+ ::msgcat::mcset it "Letter " "Lettera"
+ ::msgcat::mcset it "Legal " "Legale"
+ ::msgcat::mcset it "A4" "A4"
+ ::msgcat::mcset it "Grayscale" "Scala Di Grigi"
+ ::msgcat::mcset it "RGB" "Rgb"
+ ::msgcat::mcset it "Options" "Opzioni"
+ ::msgcat::mcset it "Copies" "Copie"
+ ::msgcat::mcset it "Paper" "Carta"
+ ::msgcat::mcset it "Scale" "Scala"
+ ::msgcat::mcset it "Orientation" "Orientamento"
+ ::msgcat::mcset it "Portrait" "Ritratto"
+ ::msgcat::mcset it "Landscape" "Paesaggio"
+ ::msgcat::mcset it "Output" "Prodotto"
+}
\ No newline at end of file
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/it.msg
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/nl.msg
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/nl.msg (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/nl.msg 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,109 @@
+namespace eval ::tk {
+ ::msgcat::mcset nl "&Abort" "&Afbreken"
+ ::msgcat::mcset nl "&About..." "Over..."
+ ::msgcat::mcset nl "All Files" "Alle Bestanden"
+ ::msgcat::mcset nl "Application Error" "Toepassingsfout"
+ ::msgcat::mcset nl "&Apply" "Toepassen"
+ ::msgcat::mcset nl "Bold" "Vet"
+ ::msgcat::mcset nl "Bold Italic" "Vet Cursief"
+ ::msgcat::mcset nl "&Blue" "&Blauw"
+ ::msgcat::mcset nl "Cancel" "Annuleren"
+ ::msgcat::mcset nl "&Cancel" "&Annuleren"
+ ::msgcat::mcset nl "Cannot change to the directory \"%1\$s\".\nPermission denied." "Kan niet naar map \"%1\$s\" gaan.\nU heeft hiervoor geen toestemming."
+ ::msgcat::mcset nl "Choose Directory" "Kies map"
+ ::msgcat::mcset nl "Cl&ear" "Wissen"
+ ::msgcat::mcset nl "&Clear Console" "&Wis Console"
+ ::msgcat::mcset nl "Color" "Kleur"
+ ::msgcat::mcset nl "Console"
+ ::msgcat::mcset nl "&Copy" "Kopiëren"
+ ::msgcat::mcset nl "Cu&t" "Knippen"
+ ::msgcat::mcset nl "&Delete" "Wissen"
+ ::msgcat::mcset nl "Details >>"
+ ::msgcat::mcset nl "Directory \"%1\$s\" does not exist." "Map \"%1\$s\" bestaat niet."
+ ::msgcat::mcset nl "&Directory:" "&Map:"
+ ::msgcat::mcset nl "&Edit" "Bewerken"
+ ::msgcat::mcset nl "Effects" "Effecten"
+ ::msgcat::mcset nl "Error: %1\$s" "Fout: %1\$s"
+ ::msgcat::mcset nl "E&xit" "Beëindigen"
+ ::msgcat::mcset nl "&File" "Bestand"
+ ::msgcat::mcset nl "File \"%1\$s\" already exists.\nDo you want to overwrite it?" "Bestand \"%1\$s\" bestaat al.\nWilt u het overschrijven?"
+ ::msgcat::mcset nl "File \"%1\$s\" already exists.\n\n" "Bestand \"%1\$s\" bestaat al.\n\n"
+ ::msgcat::mcset nl "File \"%1\$s\" does not exist." "Bestand \"%1\$s\" bestaat niet."
+ ::msgcat::mcset nl "File &name:" "Bestands&naam:"
+ ::msgcat::mcset nl "File &names:" "Bestands&namen:"
+ ::msgcat::mcset nl "Files of &type:" "Bestanden van het &type:"
+ ::msgcat::mcset nl "Fi&les:" "&Bestanden:"
+ ::msgcat::mcset nl "&Filter"
+ ::msgcat::mcset nl "Fil&ter:"
+ ::msgcat::mcset nl "Font"
+ ::msgcat::mcset nl "&Font:"
+ ::msgcat::mcset nl "Font st&yle:" "Font stijl:"
+ ::msgcat::mcset nl "&Green" "&Groen"
+ ::msgcat::mcset nl "&Help"
+ ::msgcat::mcset nl "Hi" "Hé"
+ ::msgcat::mcset nl "&Hide Console" "Verberg Console"
+ ::msgcat::mcset nl "&Ignore" "&Negeren"
+ ::msgcat::mcset nl "Invalid file name \"%1\$s\"." "Ongeldige bestandsnaam \"%1\$s\"."
+ ::msgcat::mcset nl "Italic" "Cursief"
+ ::msgcat::mcset nl "Log Files" "Log Bestanden"
+ ::msgcat::mcset nl "&No" "&Nee"
+ ::msgcat::mcset nl "&OK"
+ ::msgcat::mcset nl "OK"
+ ::msgcat::mcset nl "Ok"
+ ::msgcat::mcset nl "Open" "Openen"
+ ::msgcat::mcset nl "&Open" "&Openen"
+ ::msgcat::mcset nl "Open Multiple Files" "Open meerdere bestanden"
+ ::msgcat::mcset nl "P&aste" "Pl&akken"
+ ::msgcat::mcset nl "&Quit" "Stoppen"
+ ::msgcat::mcset nl "&Red" "&Rood"
+ ::msgcat::mcset nl "Regular" "Standaard"
+ ::msgcat::mcset nl "Replace existing file?" "Vervang bestaand bestand?"
+ ::msgcat::mcset nl "&Retry" "&Herhalen"
+ ::msgcat::mcset nl "Sample"
+ ::msgcat::mcset nl "&Save" "Op&slaan"
+ ::msgcat::mcset nl "Save As" "Opslaan als"
+ ::msgcat::mcset nl "Save To Log" "Opslaan naar Log"
+ ::msgcat::mcset nl "Select Log File" "Selecteer Log bestand"
+ ::msgcat::mcset nl "Select a file to source" "Selecteer bronbestand"
+ ::msgcat::mcset nl "&Selection:" "&Selectie:"
+ ::msgcat::mcset nl "&Size:" "Grootte"
+ ::msgcat::mcset nl "Show &Hidden Directories" "Laat verborgen mappen zien"
+ ::msgcat::mcset nl "Show &Hidden Files and Directories" "Laat verborgen bestanden mappen zien"
+ ::msgcat::mcset nl "Skip Messages" "Berichten overslaan"
+ ::msgcat::mcset nl "&Source..." "Bron..."
+ ::msgcat::mcset nl "Stri&keout"
+ ::msgcat::mcset nl "Tcl Scripts"
+ ::msgcat::mcset nl "Tcl for Windows" "Tcl voor Windows"
+ ::msgcat::mcset nl "Text Files" "Tekstbestanden"
+ ::msgcat::mcset nl "&Underline" "Onderstreept"
+ ::msgcat::mcset nl "&Yes" "&Ja"
+ ::msgcat::mcset nl "abort" "afbreken"
+ ::msgcat::mcset nl "blue" "blauw"
+ ::msgcat::mcset nl "cancel" "annuleren"
+ ::msgcat::mcset nl "extension"
+ ::msgcat::mcset nl "extensions"
+ ::msgcat::mcset nl "green" "groen"
+ ::msgcat::mcset nl "ignore" "negeren"
+ ::msgcat::mcset nl "ok"
+ ::msgcat::mcset nl "red" "rood"
+ ::msgcat::mcset nl "retry" "opnieuw"
+ ::msgcat::mcset nl "yes" "ja"
+}
+#localization of print terms by Kevin Walzer via Microsoft Translator
+namespace eval ::tk {
+ ::msgcat::mcset nl "Print" "Afdrukken"
+ ::msgcat::mcset nl "Printer" "Printer"
+ ::msgcat::mcset nl "Letter " "Brief"
+ ::msgcat::mcset nl "Legal " "Legaal"
+ ::msgcat::mcset nl "A4" "A4"
+ ::msgcat::mcset nl "Grayscale" "Grijswaarden"
+ ::msgcat::mcset nl "RGB" "Rgb"
+ ::msgcat::mcset nl "Options" "Opties"
+ ::msgcat::mcset nl "Copies" "Kopieën"
+ ::msgcat::mcset nl "Paper" "Papier"
+ ::msgcat::mcset nl "Scale" "Schub"
+ ::msgcat::mcset nl "Orientation" "Oriëntatie"
+ ::msgcat::mcset nl "Portrait" "Portret"
+ ::msgcat::mcset nl "Landscape" "Landschap"
+ ::msgcat::mcset nl "Output" "Uitvoer"
+}
\ No newline at end of file
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/nl.msg
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/pl.msg
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/pl.msg (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/pl.msg 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,109 @@
+namespace eval ::tk {
+ ::msgcat::mcset pl "&Abort" "&Przerwij"
+ ::msgcat::mcset pl "&About..." "O programie..."
+ ::msgcat::mcset pl "All Files" "Wszystkie pliki"
+ ::msgcat::mcset pl "Application Error" "Błąd w programie"
+ ::msgcat::mcset pl "&Apply" "Zastosuj"
+ ::msgcat::mcset pl "Bold" "Pogrubienie"
+ ::msgcat::mcset pl "Bold Italic" "Pogrubiona kursywa"
+ ::msgcat::mcset pl "&Blue" "&Niebieski"
+ ::msgcat::mcset pl "Cancel" "Anuluj"
+ ::msgcat::mcset pl "&Cancel" "&Anuluj"
+ ::msgcat::mcset pl "Cannot change to the directory \"%1\$s\".\nPermission denied." "Nie można otworzyć katalogu \"%1\$s\".\nOdmowa dostępu."
+ ::msgcat::mcset pl "Choose Directory" "Wybierz katalog"
+ ::msgcat::mcset pl "Cl&ear" "&Wyczyść"
+ ::msgcat::mcset pl "&Clear Console" "&Wyczyść konsolę"
+ ::msgcat::mcset pl "Color" "Kolor"
+ ::msgcat::mcset pl "Console" "Konsola"
+ ::msgcat::mcset pl "&Copy" "&Kopiuj"
+ ::msgcat::mcset pl "Cu&t" "&Wytnij"
+ ::msgcat::mcset pl "&Delete" "&Usuń"
+ ::msgcat::mcset pl "Details >>" "Szczegóły >>"
+ ::msgcat::mcset pl "Directory \"%1\$s\" does not exist." "Katalog \"%1\$s\" nie istnieje."
+ ::msgcat::mcset pl "&Directory:" "&Katalog:"
+ ::msgcat::mcset pl "&Edit" "&Edytuj"
+ ::msgcat::mcset pl "Effects" "Efekty"
+ ::msgcat::mcset pl "Error: %1\$s" "Błąd: %1\$s"
+ ::msgcat::mcset pl "E&xit" "&Wyjdź"
+ ::msgcat::mcset pl "&File" "&Plik"
+ ::msgcat::mcset pl "File \"%1\$s\" already exists.\nDo you want to overwrite it?" "Plik \"%1\$s\" już istnieje.\nCzy chcesz go nadpisać?"
+ ::msgcat::mcset pl "File \"%1\$s\" already exists.\n\n" "Plik \"%1\$s\" już istnieje.\n\n"
+ ::msgcat::mcset pl "File \"%1\$s\" does not exist." "Plik \"%1\$s\" nie istnieje."
+ ::msgcat::mcset pl "File &name:" "Nazwa &pliku:"
+ ::msgcat::mcset pl "File &names:" "Nazwy &plików:"
+ ::msgcat::mcset pl "Files of &type:" "Pliki &typu:"
+ ::msgcat::mcset pl "Fi&les:" "Pli&ki:"
+ ::msgcat::mcset pl "&Filter" "&Filtr"
+ ::msgcat::mcset pl "Fil&ter:" "&Filtr:"
+ ::msgcat::mcset pl "Font" "Czcionka"
+ ::msgcat::mcset pl "&Font:" "Czcio&nka:"
+ ::msgcat::mcset pl "Font st&yle:" "&Styl czcionki:"
+ ::msgcat::mcset pl "&Green" "&Zielony"
+ ::msgcat::mcset pl "&Help" "&Pomoc"
+ ::msgcat::mcset pl "Hi" "Witaj"
+ ::msgcat::mcset pl "&Hide Console" "&Ukryj konsolę"
+ ::msgcat::mcset pl "&Ignore" "&Ignoruj"
+ ::msgcat::mcset pl "Invalid file name \"%1\$s\"." "Niewłaściwa nazwa pliku \"%1\$s\"."
+ ::msgcat::mcset pl "Italic" "Kursywa"
+ ::msgcat::mcset pl "Log Files" "Pliki dziennika"
+ ::msgcat::mcset pl "&No" "&Nie"
+ ::msgcat::mcset pl "&OK"
+ ::msgcat::mcset pl "OK"
+ ::msgcat::mcset pl "Ok"
+ ::msgcat::mcset pl "Open" "Otwórz"
+ ::msgcat::mcset pl "&Open" "&Otwórz"
+ ::msgcat::mcset pl "Open Multiple Files" "Otwórz wiele plików"
+ ::msgcat::mcset pl "P&aste" "&Wklej"
+ ::msgcat::mcset pl "&Quit" "&Zakończ"
+ ::msgcat::mcset pl "&Red" "&Czerwony"
+ ::msgcat::mcset pl "Regular" "Regularne"
+ ::msgcat::mcset pl "Replace existing file?" "Czy zastąpić istniejący plik?"
+ ::msgcat::mcset pl "&Retry" "&Ponów"
+ ::msgcat::mcset pl "Sample" "Przykład"
+ ::msgcat::mcset pl "&Save" "&Zapisz"
+ ::msgcat::mcset pl "Save As" "Zapisz jako"
+ ::msgcat::mcset pl "Save To Log" "Wpisz do dziennika"
+ ::msgcat::mcset pl "Select Log File" "Wybierz plik dziennika"
+ ::msgcat::mcset pl "Select a file to source" "Wybierz plik do wykonania"
+ ::msgcat::mcset pl "&Selection:" "&Wybór:"
+ ::msgcat::mcset pl "&Size:" "&Rozmiar:"
+ ::msgcat::mcset pl "Show &Hidden Directories" "Pokaż &ukryte katalogi"
+ ::msgcat::mcset pl "Show &Hidden Files and Directories" "Pokaż &ukryte pliki i katalogi"
+ ::msgcat::mcset pl "Skip Messages" "Pomiń pozostałe komunikaty"
+ ::msgcat::mcset pl "&Source..." "&Kod źródłowy..."
+ ::msgcat::mcset pl "Stri&keout" "&Przekreślenie"
+ ::msgcat::mcset pl "Tcl Scripts" "Skrypty Tcl"
+ ::msgcat::mcset pl "Tcl for Windows" "Tcl dla Windows"
+ ::msgcat::mcset pl "Text Files" "Pliki tekstowe"
+ ::msgcat::mcset pl "&Underline" "Po&dkreślenie"
+ ::msgcat::mcset pl "&Yes" "&Tak"
+ ::msgcat::mcset pl "abort" "przerwij"
+ ::msgcat::mcset pl "blue" "niebieski"
+ ::msgcat::mcset pl "cancel" "anuluj"
+ ::msgcat::mcset pl "extension" "rozszerzenie"
+ ::msgcat::mcset pl "extensions" "rozszerzenia"
+ ::msgcat::mcset pl "green" "zielony"
+ ::msgcat::mcset pl "ignore" "ignoruj"
+ ::msgcat::mcset pl "ok"
+ ::msgcat::mcset pl "red" "czerwony"
+ ::msgcat::mcset pl "retry" "ponów"
+ ::msgcat::mcset pl "yes" "tak"
+}
+#localization of print terms by Kevin Walzer via Microsoft Translator
+namespace eval ::tk {
+ ::msgcat::mcset pl "Print" "Drukować"
+ ::msgcat::mcset pl "Printer" "Drukarka"
+ ::msgcat::mcset pl "Letter " "Litera"
+ ::msgcat::mcset pl "Legal " "Legalny"
+ ::msgcat::mcset pl "A4" "A4"
+ ::msgcat::mcset pl "Grayscale" "Skala Szarości"
+ ::msgcat::mcset pl "RGB" "Rgb"
+ ::msgcat::mcset pl "Options" "Opcje"
+ ::msgcat::mcset pl "Copies" "Kopie"
+ ::msgcat::mcset pl "Paper" "Papier"
+ ::msgcat::mcset pl "Scale" "Skala"
+ ::msgcat::mcset pl "Orientation" "Orientacja"
+ ::msgcat::mcset pl "Portrait" "Portret"
+ ::msgcat::mcset pl "Landscape" "Krajobraz"
+ ::msgcat::mcset pl "Output" "Produkt Wyjściowy"
+}
\ No newline at end of file
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/pl.msg
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/pt.msg
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/pt.msg (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/pt.msg 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,92 @@
+namespace eval ::tk {
+ ::msgcat::mcset pt "&Abort" "&Abortar"
+ ::msgcat::mcset pt "About..." "Sobre ..."
+ ::msgcat::mcset pt "All Files" "Todos os arquivos"
+ ::msgcat::mcset pt "Application Error" "Erro de aplicação"
+ ::msgcat::mcset pt "&Blue" "&Azul"
+ ::msgcat::mcset pt "Cancel" "Cancelar"
+ ::msgcat::mcset pt "&Cancel" "&Cancelar"
+ ::msgcat::mcset pt "Cannot change to the directory \"%1\$s\".\nPermission denied." "Não foi possível mudar para o diretório \"%1\$s\".\nPermissão negada."
+ ::msgcat::mcset pt "Choose Directory" "Escolha um diretório"
+ ::msgcat::mcset pt "Cl&ear" "Apagar"
+ ::msgcat::mcset pt "&Clear Console" "Apagar Console"
+ ::msgcat::mcset pt "Color" "Cor"
+ ::msgcat::mcset pt "Console"
+ ::msgcat::mcset pt "&Copy" "Copiar"
+ ::msgcat::mcset pt "Cu&t" "Recortar"
+ ::msgcat::mcset pt "&Delete" "Excluir"
+ ::msgcat::mcset pt "Details >>" "Detalhes >>"
+ ::msgcat::mcset pt "Directory \"%1\$s\" does not exist." "O diretório \"%1\$s\" não existe."
+ ::msgcat::mcset pt "&Directory:" "&Diretório:"
+ ::msgcat::mcset pt "Error: %1\$s" "Erro: %1\$s"
+ ::msgcat::mcset pt "E&xit" "Sair"
+ ::msgcat::mcset pt "&File" "Arquivo"
+ ::msgcat::mcset pt "File \"%1\$s\" already exists.\nDo you want to overwrite it?" "O arquivo \"%1\$s\" já existe.\nDeseja sobrescreve-lo?"
+ ::msgcat::mcset pt "File \"%1\$s\" already exists.\n\n" "O arquivo \"%1\$s\" já existe.\n\n"
+ ::msgcat::mcset pt "File \"%1\$s\" does not exist." "Arquivo \"%1\$s\" não existe."
+ ::msgcat::mcset pt "File &name:" "&Nome do arquivo:"
+ ::msgcat::mcset pt "File &names:" "&Nomes dos arquivos:"
+ ::msgcat::mcset pt "Files of &type:" "Arquivos do &tipo:"
+ ::msgcat::mcset pt "Fi&les:" "&Arquivos:"
+ ::msgcat::mcset pt "&Filter" "&Filtro"
+ ::msgcat::mcset pt "Fil&ter:" "Fil&tro:"
+ ::msgcat::mcset pt "&Green" "&Verde"
+ ::msgcat::mcset pt "Hi" "Oi"
+ ::msgcat::mcset pt "&Hide Console" "Ocultar console"
+ ::msgcat::mcset pt "&Ignore" "&Ignorar"
+ ::msgcat::mcset pt "Invalid file name \"%1\$s\"." "O nome do arquivo é inválido \"%1\$s\"."
+ ::msgcat::mcset pt "Log Files" "Arquivos de log"
+ ::msgcat::mcset pt "&No" "&Não"
+ ::msgcat::mcset pt "&OK"
+ ::msgcat::mcset pt "OK"
+ ::msgcat::mcset pt "Ok"
+ ::msgcat::mcset pt "Open" "Abrir"
+ ::msgcat::mcset pt "&Open" "&Abrir"
+ ::msgcat::mcset pt "Open Multiple Files" "Abrir múltiplos arquivos"
+ ::msgcat::mcset pt "P&aste" "Col&ar"
+ ::msgcat::mcset pt "Quit" "Encerrar"
+ ::msgcat::mcset pt "&Red" "&Vermelho"
+ ::msgcat::mcset pt "Replace existing file?" "Substituir arquivo existente?"
+ ::msgcat::mcset pt "&Retry" "Tenta&r novamente"
+ ::msgcat::mcset pt "&Save" "&Salvar"
+ ::msgcat::mcset pt "Save As" "Salvar como"
+ ::msgcat::mcset pt "Save To Log" "Salvar arquivo de log"
+ ::msgcat::mcset pt "Select Log File" "Selecionar arquivo de log"
+ ::msgcat::mcset pt "Select a file to source" "Selecione um arquivo como fonte"
+ ::msgcat::mcset pt "&Selection:" "&Seleção:"
+ ::msgcat::mcset pt "Skip Messages" "Omitir as mensagens"
+ ::msgcat::mcset pt "&Source..." "&Fonte..."
+ ::msgcat::mcset pt "Tcl Scripts" "Scripts Tcl"
+ ::msgcat::mcset pt "Tcl for Windows" "Tcl para Windows"
+ ::msgcat::mcset pt "Text Files" "Arquivos de texto"
+ ::msgcat::mcset pt "&Yes" "&Sim"
+ ::msgcat::mcset pt "abort" "abortar"
+ ::msgcat::mcset pt "blue" "azul"
+ ::msgcat::mcset pt "cancel" "cancelar"
+ ::msgcat::mcset pt "extension" "extensão"
+ ::msgcat::mcset pt "extensions" "extensões"
+ ::msgcat::mcset pt "green" "verde"
+ ::msgcat::mcset pt "ignore" "ignorar"
+ ::msgcat::mcset pt "ok"
+ ::msgcat::mcset pt "red" "vermelho"
+ ::msgcat::mcset pt "retry" "tentar novamente"
+ ::msgcat::mcset pt "yes" "sim"
+}
+#localization of print terms by Kevin Walzer via Microsoft Translator
+namespace eval ::tk {
+ ::msgcat::mcset pt "Print" "Imprimir"
+ ::msgcat::mcset pt "Printer" "Impressora"
+ ::msgcat::mcset pt "Letter " "Letra"
+ ::msgcat::mcset pt "Legal " "Legal"
+ ::msgcat::mcset pt "A4" "A4"
+ ::msgcat::mcset pt "Grayscale" "Escala De Cinza"
+ ::msgcat::mcset pt "RGB" "Rgb"
+ ::msgcat::mcset pt "Options" "Opções"
+ ::msgcat::mcset pt "Copies" "Exemplares"
+ ::msgcat::mcset pt "Paper" "Papel"
+ ::msgcat::mcset pt "Scale" "Escala"
+ ::msgcat::mcset pt "Orientation" "Orientação"
+ ::msgcat::mcset pt "Portrait" "Retrato"
+ ::msgcat::mcset pt "Landscape" "Paisagem"
+ ::msgcat::mcset pt "Output" "Saída"
+}
\ No newline at end of file
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/pt.msg
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/ru.msg
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/ru.msg (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/ru.msg 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,112 @@
+namespace eval ::tk {
+ ::msgcat::mcset ru "&Abort" "&Отменить"
+ ::msgcat::mcset ru "&About..." "Про..."
+ ::msgcat::mcset ru "All Files" "Все файлы"
+ ::msgcat::mcset ru "Application Error" "Ошибка в программе"
+ ::msgcat::mcset ru "&Apply" "&Применить"
+ ::msgcat::mcset ru "Bold" "Bold"
+ ::msgcat::mcset ru "Bold Italic" "Bold Italic"
+ ::msgcat::mcset ru "&Blue" " &Голубой"
+ ::msgcat::mcset ru "Cancel" "Отмена"
+ ::msgcat::mcset ru "&Cancel" "От&мена"
+ ::msgcat::mcset ru "Cannot change to the directory \"%1\$s\".\nPermission denied." \
+ "Не могу перейти в каталог \"%1\$s\".\nНедостаточно прав доступа"
+ ::msgcat::mcset ru "Choose Directory" "Выберите каталог"
+ ::msgcat::mcset ru "Cl&ear" "Очистить"
+ ::msgcat::mcset ru "&Clear Console" "&Clear Console"
+ ::msgcat::mcset ru "Color" "Цвет"
+ ::msgcat::mcset ru "Console" "Консоль"
+ ::msgcat::mcset ru "&Copy" "Копировать"
+ ::msgcat::mcset ru "Cu&t" "Вырезать"
+ ::msgcat::mcset ru "&Delete" "Удалить"
+ ::msgcat::mcset ru "Details >>" "Подробнее >>"
+ ::msgcat::mcset ru "Directory \"%1\$s\" does not exist." "Каталога \"%1\$s\" не существует."
+ ::msgcat::mcset ru "&Directory:" "&Каталог:"
+ ::msgcat::mcset ru "&Edit" "&Edit"
+ ::msgcat::mcset ru "Effects" "Эффекты"
+ ::msgcat::mcset ru "Error: %1\$s" "Ошибка: %1\$s"
+ ::msgcat::mcset ru "E&xit" "Выход"
+ ::msgcat::mcset ru "&File" "&File"
+ ::msgcat::mcset ru "File \"%1\$s\" already exists.\nDo you want to overwrite it?" \
+ "Файл \"%1\$s\" уже существует.\nЗаменить его?"
+ ::msgcat::mcset ru "File \"%1\$s\" already exists.\n\n" "Файл \"%1\$s\" уже существует.\n\n"
+ ::msgcat::mcset ru "File \"%1\$s\" does not exist." "Файл \"%1\$s\" не найден."
+ ::msgcat::mcset ru "File &name:" "&Имя файла:"
+ ::msgcat::mcset ru "File &names:" "&Имена файлов:"
+ ::msgcat::mcset ru "Files of &type:" "&Тип файлов:"
+ ::msgcat::mcset ru "Fi&les:" "Фай&лы:"
+ ::msgcat::mcset ru "&Filter" "&Фильтр"
+ ::msgcat::mcset ru "Fil&ter:" "Филь&тр:"
+ ::msgcat::mcset ru "Font" "Шрифт"
+ ::msgcat::mcset ru "&Font:" "&Шрифт"
+ ::msgcat::mcset ru "Font st&yle:" "&Стиль шрифта:"
+ ::msgcat::mcset ru "&Green" " &Зеленый"
+ ::msgcat::mcset ru "&Help" "&Help"
+ ::msgcat::mcset ru "Hi" "Привет"
+ ::msgcat::mcset ru "&Hide Console" "Спрятать консоль"
+ ::msgcat::mcset ru "&Ignore" "&Игнорировать"
+ ::msgcat::mcset ru "Invalid file name \"%1\$s\"." "Неверное имя файла \"%1\$s\"."
+ ::msgcat::mcset ru "Italic" "Italic"
+ ::msgcat::mcset ru "Log Files" "Файлы журнала"
+ ::msgcat::mcset ru "&No" "&Нет"
+ ::msgcat::mcset ru "&OK" "&ОК"
+ ::msgcat::mcset ru "OK" "ОК"
+ ::msgcat::mcset ru "Ok" "Да"
+ ::msgcat::mcset ru "Open" "Открыть"
+ ::msgcat::mcset ru "&Open" "&Открыть"
+ ::msgcat::mcset ru "Open Multiple Files" "Открыть несколько файлов"
+ ::msgcat::mcset ru "P&aste" "Вставить"
+ ::msgcat::mcset ru "&Quit" "Выход"
+ ::msgcat::mcset ru "&Red" " &Красный"
+ ::msgcat::mcset ru "Replace existing file?" "Заменить существующий файл?"
+ ::msgcat::mcset ru "Regular" "Regular"
+ ::msgcat::mcset ru "&Retry" "&Повторить"
+ ::msgcat::mcset ru "Sample" "Пример"
+ ::msgcat::mcset ru "&Save" "&Сохранить"
+ ::msgcat::mcset ru "Save As" "Сохранить как"
+ ::msgcat::mcset ru "Save To Log" "Сохранить в журнал"
+ ::msgcat::mcset ru "Select Log File" "Выбрать журнал"
+ ::msgcat::mcset ru "Select a file to source" "Выберите файл для интерпретации"
+ ::msgcat::mcset ru "&Selection:"
+ ::msgcat::mcset ru "&Size:" "&Размер:"
+ ::msgcat::mcset ru "Show &Hidden Directories" "Show &Hidden Directories"
+ ::msgcat::mcset ru "Show &Hidden Files and Directories" "Show &Hidden Files and Directories"
+ ::msgcat::mcset ru "Skip Messages" "Пропустить сообщения"
+ ::msgcat::mcset ru "&Source..." "Интерпретировать файл..."
+ ::msgcat::mcset ru "Stri&keout" "П&еречёркнутый"
+ ::msgcat::mcset ru "Tcl Scripts" "Программа на языке TCL"
+ ::msgcat::mcset ru "Tcl for Windows" "TCL для Windows"
+ ::msgcat::mcset ru "Text Files" "Текстовые файлы"
+ ::msgcat::mcset ru "&Underline" "По&дчеркнутый"
+ ::msgcat::mcset ru "&Yes" "&Да"
+ ::msgcat::mcset ru "abort" "отмена"
+ ::msgcat::mcset ru "blue" " голубой"
+ ::msgcat::mcset ru "cancel" "отмена"
+ ::msgcat::mcset ru "extension" "расширение"
+ ::msgcat::mcset ru "extensions" "расширения"
+ ::msgcat::mcset ru "green" " зеленый"
+ ::msgcat::mcset ru "ignore" "пропустить"
+ ::msgcat::mcset ru "ok" "ок"
+ ::msgcat::mcset ru "red" " красный"
+ ::msgcat::mcset ru "retry" "повторить"
+ ::msgcat::mcset ru "yes" "да"
+}
+
+#localization of print terms by Kevin Walzer via Microsoft Translator
+namespace eval ::tk {
+ ::msgcat::mcset ru "Print" "Печатать"
+ ::msgcat::mcset ru "Printer" "Принтер"
+ ::msgcat::mcset ru "Letter " "Письмо"
+ ::msgcat::mcset ru "Legal " "Законный"
+ ::msgcat::mcset ru "A4" "A4"
+ ::msgcat::mcset ru "Grayscale" "Серый Масштаб"
+ ::msgcat::mcset ru "RGB" "Ргб"
+ ::msgcat::mcset ru "Options" "Параметры"
+ ::msgcat::mcset ru "Copies" "Копии"
+ ::msgcat::mcset ru "Paper" "Бумага"
+ ::msgcat::mcset ru "Scale" "Шкала"
+ ::msgcat::mcset ru "Orientation" "Ориентация"
+ ::msgcat::mcset ru "Portrait" "Портрет"
+ ::msgcat::mcset ru "Landscape" "Ландшафт"
+ ::msgcat::mcset ru "Output" "Выпуск"
+}
\ No newline at end of file
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/ru.msg
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/sv.msg
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/sv.msg (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/sv.msg 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,94 @@
+namespace eval ::tk {
+ ::msgcat::mcset sv "&Abort" "&Avsluta"
+ ::msgcat::mcset sv "&About..." "&Om..."
+ ::msgcat::mcset sv "All Files" "Samtliga filer"
+ ::msgcat::mcset sv "Application Error" "Programfel"
+ ::msgcat::mcset sv "&Blue" "&Blå"
+ ::msgcat::mcset sv "Cancel" "Avbryt"
+ ::msgcat::mcset sv "&Cancel" "&Avbryt"
+ ::msgcat::mcset sv "Cannot change to the directory \"%1\$s\".\nPermission denied." "Kan ej nå mappen \"%1\$s\".\nSaknar rättigheter."
+ ::msgcat::mcset sv "Choose Directory" "Välj mapp"
+ ::msgcat::mcset sv "Cl&ear" "&Radera"
+ ::msgcat::mcset sv "&Clear Console" "&Radera konsollen"
+ ::msgcat::mcset sv "Color" "Färg"
+ ::msgcat::mcset sv "Console" "Konsoll"
+ ::msgcat::mcset sv "&Copy" "&Kopiera"
+ ::msgcat::mcset sv "Cu&t" "Klipp u&t"
+ ::msgcat::mcset sv "&Delete" "&Radera"
+ ::msgcat::mcset sv "Details >>" "Detaljer >>"
+ ::msgcat::mcset sv "Directory \"%1\$s\" does not exist." "Mappen \"%1\$s\" finns ej."
+ ::msgcat::mcset sv "&Directory:" "&Mapp:"
+ ::msgcat::mcset sv "&Edit" "R&edigera"
+ ::msgcat::mcset sv "Error: %1\$s" "Fel: %1\$s"
+ ::msgcat::mcset sv "E&xit" "&Avsluta"
+ ::msgcat::mcset sv "&File" "&Fil"
+ ::msgcat::mcset sv "File \"%1\$s\" already exists.\nDo you want to overwrite it?" "Filen \"%1\$s\" finns redan.\nVill du skriva över den?"
+ ::msgcat::mcset sv "File \"%1\$s\" already exists.\n\n" "Filen \"%1\$s\" finns redan.\n\n"
+ ::msgcat::mcset sv "File \"%1\$s\" does not exist." "Filen \"%1\$s\" finns ej."
+ ::msgcat::mcset sv "File &name:" "Fil&namn:"
+ ::msgcat::mcset sv "File &names:" "Fil&namn:"
+ ::msgcat::mcset sv "Files of &type:" "Filer av &typ:"
+ ::msgcat::mcset sv "Fi&les:" "Fi&ler:"
+ ::msgcat::mcset sv "&Filter"
+ ::msgcat::mcset sv "Fil&ter:"
+ ::msgcat::mcset sv "&Green" "&Grön"
+ ::msgcat::mcset sv "&Help" "&Hjälp"
+ ::msgcat::mcset sv "Hi" "Hej"
+ ::msgcat::mcset sv "&Hide Console" "&Göm konsollen"
+ ::msgcat::mcset sv "&Ignore" "&Ignorera"
+ ::msgcat::mcset sv "Invalid file name \"%1\$s\"." "Ogiltigt filnamn \"%1\$s\"."
+ ::msgcat::mcset sv "Log Files" "Loggfiler"
+ ::msgcat::mcset sv "&No" "&Nej"
+ ::msgcat::mcset sv "&OK"
+ ::msgcat::mcset sv "OK"
+ ::msgcat::mcset sv "Ok"
+ ::msgcat::mcset sv "Open" "Öppna"
+ ::msgcat::mcset sv "&Open" "&Öppna"
+ ::msgcat::mcset sv "Open Multiple Files" "Öppna flera filer"
+ ::msgcat::mcset sv "P&aste" "&Klistra in"
+ ::msgcat::mcset sv "&Quit" "&Avsluta"
+ ::msgcat::mcset sv "&Red" "&Röd"
+ ::msgcat::mcset sv "Replace existing file?" "Ersätt existerande fil?"
+ ::msgcat::mcset sv "&Retry" "&Försök igen"
+ ::msgcat::mcset sv "&Save" "&Spara"
+ ::msgcat::mcset sv "Save As" "Spara som"
+ ::msgcat::mcset sv "Save To Log" "Spara till logg"
+ ::msgcat::mcset sv "Select Log File" "Välj loggfil"
+ ::msgcat::mcset sv "Select a file to source" "Välj källfil"
+ ::msgcat::mcset sv "&Selection:" "&Val:"
+ ::msgcat::mcset sv "Skip Messages" "Hoppa över meddelanden"
+ ::msgcat::mcset sv "&Source..." "&Källa..."
+ ::msgcat::mcset sv "Tcl Scripts" "Tcl skript"
+ ::msgcat::mcset sv "Tcl for Windows" "Tcl för Windows"
+ ::msgcat::mcset sv "Text Files" "Textfiler"
+ ::msgcat::mcset sv "&Yes" "&Ja"
+ ::msgcat::mcset sv "abort" "avbryt"
+ ::msgcat::mcset sv "blue" "blå"
+ ::msgcat::mcset sv "cancel" "avbryt"
+ ::msgcat::mcset sv "extension" "utvidgning"
+ ::msgcat::mcset sv "extensions" "utvidgningar"
+ ::msgcat::mcset sv "green" "grön"
+ ::msgcat::mcset sv "ignore" "ignorera"
+ ::msgcat::mcset sv "ok"
+ ::msgcat::mcset sv "red" "röd"
+ ::msgcat::mcset sv "retry" "försök igen"
+ ::msgcat::mcset sv "yes" "ja"
+}
+#localization of print terms by Kevin Walzer via Microsoft Translator
+namespace eval ::tk {
+ ::msgcat::mcset sv "Print" "Trycka"
+ ::msgcat::mcset sv "Printer" "Skrivare"
+ ::msgcat::mcset sv "Letter " "Brev"
+ ::msgcat::mcset sv "Legal " "Laglig"
+ ::msgcat::mcset sv "A4" "A4 (På 199"
+ ::msgcat::mcset sv "Grayscale" "Gråskala"
+ ::msgcat::mcset sv "RGB" "Rgb"
+ ::msgcat::mcset sv "Options" "Alternativ"
+ ::msgcat::mcset sv "Copies" "Kopior"
+ ::msgcat::mcset sv "Paper" "Papper"
+ ::msgcat::mcset sv "Scale" "Skala"
+ ::msgcat::mcset sv "Orientation" "Orientering"
+ ::msgcat::mcset sv "Portrait" "Porträtt"
+ ::msgcat::mcset sv "Landscape" "Landskap"
+ ::msgcat::mcset sv "Output" "Utdata"
+}
\ No newline at end of file
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/sv.msg
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/zh_cn.msg
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/zh_cn.msg (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/zh_cn.msg 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,110 @@
+namespace eval ::tk {
+ ::msgcat::mcset zh_cn "&Abort" "&中止"
+ ::msgcat::mcset zh_cn "&About..." "&关于……"
+ ::msgcat::mcset zh_cn "All Files" "所有文件"
+ ::msgcat::mcset zh_cn "Application Error" "应用程序错误"
+ ::msgcat::mcset zh_cn "&Apply" "&添加"
+ ::msgcat::mcset zh_cn "Bold" "粗体"
+ ::msgcat::mcset zh_cn "Bold Italic" "加粗斜体"
+ ::msgcat::mcset zh_cn "&Blue" "&蓝色"
+ ::msgcat::mcset zh_cn "Cancel" "取消"
+ ::msgcat::mcset zh_cn "&Cancel" "&取消"
+ ::msgcat::mcset zh_cn "Cannot change to the directory \"%1\$s\".\nPermission denied." "无法更改目录 \"%1\$s\"。\n访问被拒绝。"
+ ::msgcat::mcset zh_cn "Choose Directory" "选择文件夹"
+ ::msgcat::mcset zh_cn "Cl&ear" "清&除"
+ ::msgcat::mcset zh_cn "&Clear Console" "&清除终端"
+ ::msgcat::mcset zh_cn "Color" "颜色"
+ ::msgcat::mcset zh_cn "Console" "终端"
+ ::msgcat::mcset zh_cn "&Copy" "&复制"
+ ::msgcat::mcset zh_cn "Cu&t" "剪&切"
+ ::msgcat::mcset zh_cn "&Delete" "&删除"
+ ::msgcat::mcset zh_cn "Details >>" "详细信息 >>"
+ ::msgcat::mcset zh_cn "Directory \"%1\$s\" does not exist." "目录 \"%1\$s\" 不存在。"
+ ::msgcat::mcset zh_cn "&Directory:" "&目录："
+ ::msgcat::mcset zh_cn "&Edit" "&编辑"
+ ::msgcat::mcset zh_cn "Effects" "效果"
+ ::msgcat::mcset zh_cn "Error: %1\$s" "错误： %1\$s"
+ ::msgcat::mcset zh_cn "E&xit" "退&出"
+ ::msgcat::mcset zh_cn "&File" "&文件"
+ ::msgcat::mcset zh_cn "File \"%1\$s\" already exists.\nDo you want to overwrite it?" "文件 \"%1\$s\" 已经存在。\n您想要覆盖它吗？"
+ ::msgcat::mcset zh_cn "File \"%1\$s\" already exists.\n\n" "文件 \"%1\$s\" 已经存在。\n\n"
+ ::msgcat::mcset zh_cn "File \"%1\$s\" does not exist." "文件 \"%1\$s\" 不存在。"
+ ::msgcat::mcset zh_cn "File &name:" "文件&名："
+ ::msgcat::mcset zh_cn "File &names:" "文件&名："
+ ::msgcat::mcset zh_cn "Files of &type:" "文件&类型："
+ ::msgcat::mcset zh_cn "Fi&les:" "文&件："
+ ::msgcat::mcset zh_cn "&Filter" "&过滤"
+ ::msgcat::mcset zh_cn "Fil&ter:" "过&滤："
+ ::msgcat::mcset zh_cn "Font" "字体"
+ ::msgcat::mcset zh_cn "&Font:" "&字体："
+ ::msgcat::mcset zh_cn "Font st&yle:" "字体&样式："
+ ::msgcat::mcset zh_cn "&Green" "&绿色"
+ ::msgcat::mcset zh_cn "&Help" "&帮助"
+ ::msgcat::mcset zh_cn "Hi" "你好"
+ ::msgcat::mcset zh_cn "&Hide Console" "&隐藏终端"
+ ::msgcat::mcset zh_cn "&Ignore" "&忽略"
+ ::msgcat::mcset zh_cn "Invalid file name \"%1\$s\"." "无效的文件名 \"%1\$s\"。"
+ ::msgcat::mcset zh_cn "Italic" "斜体"
+ ::msgcat::mcset zh_cn "Log Files" "日志文件"
+ ::msgcat::mcset zh_cn "&No" "&否"
+ ::msgcat::mcset zh_cn "&OK" "&确定"
+ ::msgcat::mcset zh_cn "OK" "确定"
+ ::msgcat::mcset zh_cn "Ok" "确定"
+ ::msgcat::mcset zh_cn "Open" "打开"
+ ::msgcat::mcset zh_cn "&Open" "&打开"
+ ::msgcat::mcset zh_cn "Open Multiple Files" "打开多个文件"
+ ::msgcat::mcset zh_cn "P&aste" "粘&贴"
+ ::msgcat::mcset zh_cn "&Quit" "&退出"
+ ::msgcat::mcset zh_cn "&Red" "红色"
+ ::msgcat::mcset zh_cn "Regular" "规则"
+ ::msgcat::mcset zh_cn "Replace existing file?" "替换已有文件？"
+ ::msgcat::mcset zh_cn "&Retry" "&重试"
+ ::msgcat::mcset zh_cn "Sample" "样式"
+ ::msgcat::mcset zh_cn "&Save" "&保存"
+ ::msgcat::mcset zh_cn "Save As" "另存为"
+ ::msgcat::mcset zh_cn "Save To Log" "保存到日志"
+ ::msgcat::mcset zh_cn "Select Log File" "选择日志文件"
+ ::msgcat::mcset zh_cn "Select a file to source" "选择一个源文件"
+ ::msgcat::mcset zh_cn "&Selection:" "&选择："
+ ::msgcat::mcset zh_cn "&Size:" "&大小："
+ ::msgcat::mcset zh_cn "Show &Hidden Directories" "显示&隐藏目录"
+ ::msgcat::mcset zh_cn "Show &Hidden Files and Directories" "显示&隐藏文件和目录"
+ ::msgcat::mcset zh_cn "Skip Messages" "跳过信息"
+ ::msgcat::mcset zh_cn "&Source..." "&来源……"
+ ::msgcat::mcset zh_cn "Stri&keout" "删&除线"
+ ::msgcat::mcset zh_cn "Tcl Scripts" "Tcl脚本"
+ ::msgcat::mcset zh_cn "Tcl for Windows" "适用于Windows的Tcl"
+ ::msgcat::mcset zh_cn "Text Files" "文本文档"
+ ::msgcat::mcset zh_cn "&Underline" "&下划线"
+ ::msgcat::mcset zh_cn "&Yes" "&确定"
+ ::msgcat::mcset zh_cn "abort" "中止"
+ ::msgcat::mcset zh_cn "blue" "蓝色"
+ ::msgcat::mcset zh_cn "cancel" "取消"
+ ::msgcat::mcset zh_cn "extension" "拓展"
+ ::msgcat::mcset zh_cn "extensions" "拓展"
+ ::msgcat::mcset zh_cn "green" "绿色"
+ ::msgcat::mcset zh_cn "ignore" "忽略"
+ ::msgcat::mcset zh_cn "ok" "确定"
+ ::msgcat::mcset zh_cn "red" "红色"
+ ::msgcat::mcset zh_cn "retry" "重试"
+ ::msgcat::mcset zh_cn "yes" "确认"
+}
+
+#Kevin Walzer通过微软翻译对打印内容进行本地化 localization of print terms by Kevin Walzer via Microsoft Translator
+namespace eval ::tk {
+ ::msgcat::mcset zh_cn "Print" "输出"
+ ::msgcat::mcset zh_cn "Printer" "输出器"
+ ::msgcat::mcset zh_cn "Letter " "信 "
+ ::msgcat::mcset zh_cn "Legal " "合法的 "
+ ::msgcat::mcset zh_cn "A4" "A4"
+ ::msgcat::mcset zh_cn "Grayscale" "灰度"
+ ::msgcat::mcset zh_cn "RGB" "RGB"
+ ::msgcat::mcset zh_cn "Options" "设置"
+ ::msgcat::mcset zh_cn "Copies" "复制"
+ ::msgcat::mcset zh_cn "Paper" "纸"
+ ::msgcat::mcset zh_cn "Scale" "规模"
+ ::msgcat::mcset zh_cn "Orientation" "方向"
+ ::msgcat::mcset zh_cn "Portrait" "竖向"
+ ::msgcat::mcset zh_cn "Landscape" "横向"
+ ::msgcat::mcset zh_cn "Output" "输出"
+}
\ No newline at end of file
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/msgs/zh_cn.msg
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/optMenu.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/optMenu.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/optMenu.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,43 @@
+# optMenu.tcl --
+#
+# This file defines the procedure tk_optionMenu, which creates
+# an option button and its associated menu.
+#
+# Copyright © 1994 The Regents of the University of California.
+# Copyright © 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 -highlightthickness 1 -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
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/optMenu.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/palette.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/palette.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/palette.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,283 @@
+# palette.tcl --
+#
+# This file contains procedures that change the color palette used
+# by Tk.
+#
+# Copyright © 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} {
+ if {[winfo depth .] == 1} {
+ # Just return on monochrome displays, otherwise errors will occur
+ return
+ }
+
+ # 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)]} {
+ return -code error -errorcode {TK SET_PALETTE BACKGROUND} \
+ "must specify a background color"
+ }
+ set bg [winfo rgb . $new(background)]
+ if {![info exists new(foreground)]} {
+ # Note that the range of each value in the triple returned by
+ # [winfo rgb] is 0-65535, and your eyes are more sensitive to
+ # green than to red, and more to red than to blue.
+ foreach {r g b} $bg {break}
+ if {$r+1.5*$g+0.5*$b > 100000} {
+ set new(foreground) black
+ } else {
+ set new(foreground) white
+ }
+ }
+ lassign [winfo rgb . $new(foreground)] fg_r fg_g fg_b
+ lassign $bg bg_r bg_g bg_b
+ set darkerBg [format #%02x%02x%02x [expr {(9*$bg_r)/2560}] \
+ [expr {(9*$bg_g)/2560}] [expr {(9*$bg_b)/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*$bg_r + $fg_r)/1024}] \
+ [expr {(3*$bg_g + $fg_g)/1024}] \
+ [expr {(3*$bg_b + $fg_b)/1024}]]
+ }
+ if {![info exists new(highlightBackground)]} {
+ set new(highlightBackground) $new(background)
+ }
+ # 'buttonBackground' is the background color of the buttons in
+ # the spinbox widget.
+ if {![info exists new(buttonBackground)]} {
+ set new(buttonBackground) $new(background)
+ }
+ # 'selectColor' is the background of check & radio buttons.
+ if {![info exists new(selectColor)]} {
+ foreach {r g b} $bg {break}
+ if {$r+1.5*$g+0.5*$b > 100000} {
+ set new(selectColor) white
+ } else {
+ set new(selectColor) black
+ }
+ }
+ 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} color $bg {
+ set light($i) [expr {$color/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
+ }
+
+ # 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 labelframe
+ listbox menubutton menu message radiobutton scale scrollbar
+ spinbox 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, ::tk::RecolorTree 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 [tk::RecolorTree . new]
+
+ 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 variable ::tk::Palette, for use the
+ # next time we change the options.
+
+ array set ::tk::Palette [array get new]
+
+ if {[tk windowingsystem] ne "x11" || [ttk::style theme use] ne "default"} {
+ return
+ }
+
+ # Update the 'default' ttk theme with the new palette,
+ # and then set 'default' as the current ttk theme,
+ # in order to apply the new palette to the ttk widgets.
+
+ foreach option [array names new] {
+ if {[info exists ttk::theme::default::colorOptionLookup($option)]} {
+ foreach colorName $ttk::theme::default::colorOptionLookup($option) {
+ set ttk::theme::default::colors($colorName) $new($option)
+ }
+ }
+ }
+ ttk::theme::default::reconfigureDefaultTheme
+ ttk::setTheme default
+
+ return
+}
+
+# ::tk::RecolorTree --
+# 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.
+# Return Value:
+# A list of commands which can be run to update
+# the defaults database when exec'ed.
+
+proc ::tk::RecolorTree {w colors} {
+ upvar $colors c
+ set result {}
+ set prototype .___tk_set_palette.[string tolower [winfo class $w]]
+ if {![winfo exists $prototype]} {
+ unset prototype
+ }
+ foreach dbOption [array names c] {
+ set option -[string tolower $dbOption]
+ set class [string replace $dbOption 0 0 [string toupper \
+ [string index $dbOption 0]]]
+ # Make sure this option is valid for this window.
+ if {![catch {$w configure $option} value]} {
+ # Update the option for this window.
+ $w configure $option $c($dbOption)
+ # Retrieve a default value for this option. First check
+ # the option database. If it is not in the database use
+ # the value for the temporary prototype widget.
+ set defaultcolor [option get $w $dbOption $class]
+ if {$defaultcolor eq "" || \
+ ([info exists prototype] && \
+ [$prototype cget $option] ne "$defaultcolor")} {
+ set defaultcolor [lindex $value 3]
+ }
+ if {$defaultcolor ne ""} {
+ set defaultcolor [winfo rgb . $defaultcolor]
+ }
+ # If the color requested for this option differs from
+ # the default, append a command to update the default.
+ set requestcolor [lindex $value 4]
+ if {$requestcolor ne ""} {
+ set requestcolor [winfo rgb . $requestcolor]
+ }
+ if {![string match $defaultcolor $requestcolor]} {
+ append result ";\noption add [list \
+ *[winfo class $w].$dbOption $c($dbOption) 60]"
+ }
+ }
+ }
+ foreach child [winfo children $w] {
+ append result ";\n[::tk::RecolorTree $child c]"
+ }
+ return $result
+}
+
+# ::tk::Darken --
+# 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.
+# percent - Integer telling how much to brighten or darken as a
+# percent: 50 means darken by 50%, 110 means brighten
+# by 10%.
+
+proc ::tk::Darken {color percent} {
+ if {$percent < 0} {
+ return #000000
+ } elseif {$percent > 200} {
+ return #ffffff
+ } elseif {$percent <= 100} {
+ lassign [winfo rgb . $color] r g b
+ set r [expr {($r/256)*$percent/100}]
+ set g [expr {($g/256)*$percent/100}]
+ set b [expr {($b/256)*$percent/100}]
+ } elseif {$percent > 100} {
+ lassign [winfo rgb . $color] r g b
+ set r [expr {255 - ((65535-$r)/256)*(200-$percent)/100}]
+ set g [expr {255 - ((65535-$g)/256)*(200-$percent)/100}]
+ set b [expr {255 - ((65535-$b)/256)*(200-$percent)/100}]
+ }
+ return [format #%02x%02x%02x $r $g $b]
+}
+
+# ::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 \
+ selectBackground #e6ceb1 selectForeground black \
+ troughColor #cdb79e
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/palette.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/panedwindow.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/panedwindow.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/panedwindow.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,194 @@
+# panedwindow.tcl --
+#
+# This file defines the default bindings for Tk panedwindow widgets and
+# provides procedures that help in implementing those bindings.
+
+bind Panedwindow <Button-1> { ::tk::panedwindow::MarkSash %W %x %y 1 }
+bind Panedwindow <Button-2> { ::tk::panedwindow::MarkSash %W %x %y 0 }
+
+bind Panedwindow <B1-Motion> { ::tk::panedwindow::DragSash %W %x %y 1 }
+bind Panedwindow <B2-Motion> { ::tk::panedwindow::DragSash %W %x %y 0 }
+
+bind Panedwindow <ButtonRelease-1> {::tk::panedwindow::ReleaseSash %W 1}
+bind Panedwindow <ButtonRelease-2> {::tk::panedwindow::ReleaseSash %W 0}
+
+bind Panedwindow <Motion> { ::tk::panedwindow::Motion %W %x %y }
+
+bind Panedwindow <Leave> { ::tk::panedwindow::Leave %W }
+
+# Initialize namespace
+namespace eval ::tk::panedwindow {}
+
+# ::tk::panedwindow::MarkSash --
+#
+# Handle marking the correct sash for possible dragging
+#
+# Arguments:
+# w the widget
+# x widget local x coord
+# y widget local y coord
+# proxy whether this should be a proxy sash
+# Results:
+# None
+#
+proc ::tk::panedwindow::MarkSash {w x y proxy} {
+ variable ::tk::Priv
+ if {[$w cget -opaqueresize]} {
+ set proxy 0
+ }
+ set what [$w identify $x $y]
+ if { [llength $what] == 2 } {
+ lassign $what index which
+ if {!$::tk_strictMotif || $which eq "handle"} {
+ if {!$proxy} {
+ $w sash mark $index $x $y
+ }
+ set Priv(sash) $index
+ lassign [$w sash coord $index] sx sy
+ set Priv(dx) [expr {$sx-$x}]
+ set Priv(dy) [expr {$sy-$y}]
+ # Do this to init the proxy location
+ DragSash $w $x $y $proxy
+ }
+ }
+}
+
+# ::tk::panedwindow::DragSash --
+#
+# Handle dragging of the correct sash
+#
+# Arguments:
+# w the widget
+# x widget local x coord
+# y widget local y coord
+# proxy whether this should be a proxy sash
+# Results:
+# Moves sash
+#
+proc ::tk::panedwindow::DragSash {w x y proxy} {
+ variable ::tk::Priv
+ if {[$w cget -opaqueresize]} {
+ set proxy 0
+ }
+ if {[info exists Priv(sash)]} {
+ if {$proxy} {
+ $w proxy place [expr {$x+$Priv(dx)}] [expr {$y+$Priv(dy)}]
+ } else {
+ $w sash place $Priv(sash) \
+ [expr {$x+$Priv(dx)}] [expr {$y+$Priv(dy)}]
+ }
+ }
+}
+
+# ::tk::panedwindow::ReleaseSash --
+#
+# Handle releasing of the sash
+#
+# Arguments:
+# w the widget
+# proxy whether this should be a proxy sash
+# Results:
+# Returns ...
+#
+proc ::tk::panedwindow::ReleaseSash {w proxy} {
+ variable ::tk::Priv
+ if {[$w cget -opaqueresize]} {
+ set proxy 0
+ }
+ if {[info exists Priv(sash)]} {
+ if {$proxy} {
+ lassign [$w proxy coord] x y
+ $w sash place $Priv(sash) $x $y
+ $w proxy forget
+ }
+ unset Priv(sash) Priv(dx) Priv(dy)
+ }
+}
+
+# ::tk::panedwindow::Motion --
+#
+# Handle motion on the widget. This is used to change the cursor
+# when the user moves over the sash area.
+#
+# Arguments:
+# w the widget
+# x widget local x coord
+# y widget local y coord
+# Results:
+# May change the cursor. Sets up a timer to verify that we are still
+# over the widget.
+#
+proc ::tk::panedwindow::Motion {w x y} {
+ variable ::tk::Priv
+ set id [$w identify $x $y]
+ if {([llength $id] == 2) && \
+ (!$::tk_strictMotif || [lindex $id 1] eq "handle")} {
+ if {![info exists Priv($w,panecursor)]} {
+ set Priv($w,panecursor) [$w cget -cursor]
+ if {[$w cget -sashcursor] ne ""} {
+ $w configure -cursor [$w cget -sashcursor]
+ } elseif {[$w cget -orient] eq "horizontal"} {
+ $w configure -cursor sb_h_double_arrow
+ } else {
+ $w configure -cursor sb_v_double_arrow
+ }
+ if {[info exists Priv($w,pwAfterId)]} {
+ after cancel $Priv($w,pwAfterId)
+ }
+ set Priv($w,pwAfterId) [after 150 \
+ [list ::tk::panedwindow::Cursor $w]]
+ }
+ return
+ }
+ if {[info exists Priv($w,panecursor)]} {
+ $w configure -cursor $Priv($w,panecursor)
+ unset Priv($w,panecursor)
+ }
+}
+
+# ::tk::panedwindow::Cursor --
+#
+# Handles returning the normal cursor when we are no longer over the
+# sash area. This needs to be done this way, because the panedwindow
+# won't see Leave events when the mouse moves from the sash to a
+# paned child, although the child does receive an Enter event.
+#
+# Arguments:
+# w the widget
+# Results:
+# May restore the default cursor, or schedule a timer to do it.
+#
+proc ::tk::panedwindow::Cursor {w} {
+ variable ::tk::Priv
+ # Make sure to check window existence in case it is destroyed.
+ if {[info exists Priv($w,panecursor)] && [winfo exists $w]} {
+ if {[winfo containing [winfo pointerx $w] [winfo pointery $w]] eq $w} {
+ set Priv($w,pwAfterId) [after 150 \
+ [list ::tk::panedwindow::Cursor $w]]
+ } else {
+ $w configure -cursor $Priv($w,panecursor)
+ unset Priv($w,panecursor)
+ if {[info exists Priv($w,pwAfterId)]} {
+ after cancel $Priv($w,pwAfterId)
+ unset Priv($w,pwAfterId)
+ }
+ }
+ }
+}
+
+# ::tk::panedwindow::Leave --
+#
+# Return to default cursor when leaving the pw widget.
+#
+# Arguments:
+# w the widget
+# Results:
+# Restores the default cursor
+#
+proc ::tk::panedwindow::Leave {w} {
+ variable ::tk::Priv
+ if {[info exists Priv($w,panecursor)]} {
+ $w configure -cursor $Priv($w,panecursor)
+ unset Priv($w,panecursor)
+ }
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/panedwindow.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/pkgIndex.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/pkgIndex.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/pkgIndex.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,16 @@
+if {![package vsatisfies [package provide Tcl] 8.7-]} return
+if {($::tcl_platform(platform) eq "unix") && ([info exists ::env(DISPLAY)]
+ || ([info exists ::argv] && ("-display" in $::argv)))} {
+ if {[package vsatisfies [package provide Tcl] 9.0]} {
+ package ifneeded tk 9.0.1 [list load [file normalize [file join $dir .. .. bin libtcl9tk9.0.dll]]]
+ } else {
+ package ifneeded tk 9.0.1 [list load [file normalize [file join $dir .. .. bin libtk9.0.dll]]]
+ }
+} else {
+ if {[package vsatisfies [package provide Tcl] 9.0]} {
+ package ifneeded tk 9.0.1 [list load [file normalize [file join $dir .. .. bin tcl9tk90.dll]]]
+ } else {
+ package ifneeded tk 9.0.1 [list load [file normalize [file join $dir .. .. bin tk90.dll]]]
+ }
+}
+package ifneeded Tk 9.0.1 [list package require -exact tk 9.0.1]
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/pkgIndex.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/print.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/print.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/print.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,1343 @@
+# print.tcl --
+
+# This file defines the 'tk print' command for printing of the canvas
+# widget and text on X11, Windows, and macOS. It implements an abstraction
+# layer that presents a consistent API across the three platforms.
+
+# Copyright © 2009 Michael I. Schwartz.
+# Copyright © 2021 Kevin Walzer/WordTech Communications LLC.
+# Copyright © 2021 Harald Oehlmann, Elmicron GmbH
+# Copyright © 2022 Emiliano Gavilan
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+namespace eval ::tk::print {
+ namespace import -force ::tk::msgcat::*
+
+ # makeTempFile:
+ # Create a temporary file and populate its contents
+ # Arguments:
+ # filename - base of the name of the file to create
+ # contents - what to put in the file; defaults to empty
+ # Returns:
+ # Full filename for created file
+ #
+ proc makeTempFile {filename {contents ""}} {
+ set dumpfile [file join /tmp rawprint.txt]
+ set tmpfile [file join /tmp $filename]
+ set f [open $dumpfile w]
+ try {
+ puts -nonewline $f $contents
+ } finally {
+ close $f
+ if {[file extension $filename] == ".ps"} {
+ #don't apply formatting to PostScript
+ file rename -force $dumpfile $tmpfile
+ } else {
+ #Make text fixed width for improved printed output
+ exec fmt -w 75 $dumpfile > $tmpfile
+ }
+ return $tmpfile
+ }
+ }
+
+ if {[tk windowingsystem] eq "win32"} {
+ variable printer_name
+ variable copies
+ variable dpi_x
+ variable dpi_y
+ variable paper_width
+ variable paper_height
+ variable margin_left
+ variable margin_top
+ variable printargs
+ array set printargs {}
+
+ # Multiple utility procedures for printing text based on the
+ # C printer primitives.
+
+ # _set_dc:
+ # Select printer and set device context and other parameters
+ # for print job.
+ #
+ proc _set_dc {} {
+ variable printargs
+ variable printer_name
+ variable paper_width
+ variable paper_height
+ variable dpi_x
+ variable dpi_y
+ variable copies
+
+ #First, we select the printer.
+ _selectprinter
+
+ #Next, set values. Some are taken from the printer,
+ #some are sane defaults.
+
+ if {[info exists printer_name] && $printer_name ne ""} {
+ set printargs(hDC) $printer_name
+ set printargs(pw) $paper_width
+ set printargs(pl) $paper_height
+ set printargs(lm) 1000
+ set printargs(tm) 1000
+ set printargs(rm) 1000
+ set printargs(bm) 1000
+ set printargs(resx) $dpi_x
+ set printargs(resy) $dpi_y
+ set printargs(copies) $copies
+ set printargs(resolution) [list $dpi_x $dpi_y]
+ }
+ }
+
+ # _print_data
+ # This function prints multiple-page files, using a line-oriented
+ # function, taking advantage of knowing the character widths.
+ # Arguments:
+ # data - Text data for printing
+ # breaklines - If non-zero, keep newlines in the string as
+ # newlines in the output.
+ # font - Font for printing
+ proc _print_data {data {breaklines 1} {font ""}} {
+ variable printargs
+ variable printer_name
+
+ _set_dc
+
+ if {![info exists printer_name]} {
+ return
+ }
+
+ if {$font eq ""} {
+ _gdi characters $printargs(hDC) -array printcharwid
+ } else {
+ _gdi characters $printargs(hDC) -font $font -array printcharwid
+ }
+ set pagewid [expr {($printargs(pw) - $printargs(rm) ) / 1000 * $printargs(resx)}]
+ set pagehgt [expr {($printargs(pl) - $printargs(bm) ) / 1000 * $printargs(resy)}]
+ set totallen [string length $data]
+ set curlen 0
+ set curhgt [expr {$printargs(tm) * $printargs(resy) / 1000}]
+
+ _opendoc
+ _openpage
+
+ while {$curlen < $totallen} {
+ set linestring [string range $data $curlen end]
+ if {$breaklines} {
+ set endind [string first "\n" $linestring]
+ if {$endind >= 0} {
+ set linestring [string range $linestring 0 $endind]
+ # handle blank lines....
+ if {$linestring eq ""} {
+ set linestring " "
+ }
+ }
+ }
+
+ set result [_print_page_nextline $linestring \
+ printcharwid printargs $curhgt $font]
+ incr curlen [lindex $result 0]
+ incr curhgt [lindex $result 1]
+ if {$curhgt + [lindex $result 1] > $pagehgt} {
+ _closepage
+ _openpage
+ set curhgt [expr {$printargs(tm) * $printargs(resy) / 1000}]
+ }
+ }
+
+ _closepage
+ _closedoc
+ }
+
+ # _print_file
+ # This function prints multiple-page files
+ # It will either break lines or just let them run over the
+ # margins (and thus truncate).
+ # The font argument is JUST the font name, not any additional
+ # arguments.
+ # Arguments:
+ # filename - File to open for printing
+ # breaklines - 1 to break lines as done on input, 0 to ignore newlines
+ # font - Optional arguments to supply to the text command
+ proc _print_file {filename {breaklines 1} {font ""}} {
+ set fn [open $filename r]
+ set data [read $fn]
+ close $fn
+ _print_data $data $breaklines $font
+ }
+
+ # _print_page_nextline
+ # Returns the pair "chars y"
+ # where chars is the number of characters printed on the line
+ # and y is the height of the line printed
+ # Arguments:
+ # string - Data to print
+ # pdata - Array of values for printer characteristics
+ # cdata - Array of values for character widths
+ # y - Y value to begin printing at
+ # font - if non-empty specifies a font to draw the line in
+ proc _print_page_nextline {string carray parray y font} {
+ upvar #0 $carray charwidths
+ upvar #0 $parray printargs
+
+ variable printargs
+
+ set endindex 0
+ set totwidth 0
+ set maxwidth [expr {
+ (($printargs(pw) - $printargs(rm)) / 1000) * $printargs(resx)
+ }]
+ set maxstring [string length $string]
+ set lm [expr {$printargs(lm) * $printargs(resx) / 1000}]
+
+ for {set i 0} {($i < $maxstring) && ($totwidth < $maxwidth)} {incr i} {
+ incr totwidth $charwidths([string index $string $i])
+ # set width($i) $totwidth
+ }
+
+ set endindex $i
+ set startindex $endindex
+
+ if {$i < $maxstring} {
+ # In this case, the whole data string is not used up, and we
+ # wish to break on a word. Since we have all the partial
+ # widths calculated, this should be easy.
+
+ set endindex [expr {[string wordstart $string $endindex] - 1}]
+ set startindex [expr {$endindex + 1}]
+
+ # If the line is just too long (no word breaks), print as much
+ # as you can....
+ if {$endindex <= 1} {
+ set endindex $i
+ set startindex $i
+ }
+ }
+
+ set txt [string trim [string range $string 0 $endindex] "\r\n"]
+ if {$font ne ""} {
+ set result [_gdi text $printargs(hDC) $lm $y \
+ -anchor nw -justify left \
+ -text $txt -font $font]
+ } else {
+ set result [_gdi text $printargs(hDC) $lm $y \
+ -anchor nw -justify left -text $txt]
+ }
+ return "$startindex $result"
+ }
+
+ # These procedures read in the canvas widget, and write all of
+ # its contents out to the Windows printer.
+
+ variable option
+ variable vtgPrint
+
+ proc _init_print_canvas {} {
+ variable option
+ variable vtgPrint
+ variable printargs
+
+ set vtgPrint(printer.bg) white
+ }
+
+ proc _is_win {} {
+ variable printargs
+
+ return [info exist tk_patchLevel]
+ }
+
+ # _print_widget
+ # Main procedure for printing a widget. Currently supports
+ # canvas widgets. Handles opening and closing of printer.
+ # Arguments:
+ # wid - The widget to be printed.
+ # printer - Flag whether to use the default printer.
+ # name - App name to pass to printer.
+
+ proc _print_widget {wid {printer default} {name "Tk Print Output"}} {
+ variable printargs
+ variable printer_name
+
+ _set_dc
+
+ if {![info exists printer_name]} {
+ return
+ }
+
+ _opendoc
+ _openpage
+
+ # Here is where any scaling/gdi mapping should take place
+ # For now, scale so the dimensions of the window are sized to the
+ # width of the page. Scale evenly.
+
+ # For normal windows, this may be fine--but for a canvas, one
+ # wants the canvas dimensions, and not the WINDOW dimensions.
+ if {[winfo class $wid] eq "Canvas"} {
+ set sc [$wid cget -scrollregion]
+ # if there is no scrollregion, use width and height.
+ if {$sc eq ""} {
+ set window_x [$wid cget -width]
+ set window_y [$wid cget -height]
+ } else {
+ set window_x [lindex $sc 2]
+ set window_y [lindex $sc 3]
+ }
+ } else {
+ set window_x [winfo width $wid]
+ set window_y [winfo height $wid]
+ }
+
+ set printer_x [expr {
+ ( $printargs(pw) - $printargs(lm) - $printargs(rm) ) *
+ $printargs(resx) / 1000.0
+ }]
+ set printer_y [expr {
+ ( $printargs(pl) - $printargs(tm) - $printargs(bm) ) *
+ $printargs(resy) / 1000.0
+ }]
+ set factor_x [expr {$window_x / $printer_x}]
+ set factor_y [expr {$window_y / $printer_y}]
+
+ if {$factor_x < $factor_y} {
+ set lo $window_y
+ set ph $printer_y
+ } else {
+ set lo $window_x
+ set ph $printer_x
+ }
+
+ _gdi map $printargs(hDC) -logical $lo -physical $ph \
+ -offset $printargs(resolution)
+
+ # Handling of canvas widgets.
+ switch [winfo class $wid] {
+ Canvas {
+ _print_canvas $printargs(hDC) $wid
+ }
+ default {
+ puts "Can't print items of type [winfo class $wid]. No handler registered"
+ }
+ }
+
+ # End printing process.
+ _closepage
+ _closedoc
+ }
+
+ # _print_canvas
+ # Main procedure for writing canvas widget items to printer.
+ # Arguments:
+ # hdc - The printer handle.
+ # cw - The canvas widget.
+ proc _print_canvas {hdc cw} {
+ variable vtgPrint
+ variable printargs
+
+ # Get information about page being printed to
+ # print_canvas.CalcSizing $cw
+ set vtgPrint(canvas.bg) [string tolower [$cw cget -background]]
+
+ # Re-write each widget from cw to printer
+ foreach id [$cw find all] {
+ set type [$cw type $id]
+ if {[info commands _print_canvas.$type] eq "_print_canvas.$type"} {
+ _print_canvas.[$cw type $id] $printargs(hDC) $cw $id
+ } else {
+ puts "Omitting canvas item of type $type since there is no handler registered for it"
+ }
+ }
+ }
+
+ # These procedures support the various canvas item types, reading the
+ # information about the item on the real canvas and then writing a
+ # similar item to the printer.
+
+ # _print_canvas.line
+ # Description:
+ # Prints a line item.
+ # Arguments:
+ # hdc - The printer handle.
+ # cw - The canvas widget.
+ # id - The id of the canvas item.
+ proc _print_canvas.line {hdc cw id} {
+ variable vtgPrint
+ variable printargs
+
+ set color [_print_canvas.TransColor [$cw itemcget $id -fill]]
+ if {[string match $vtgPrint(printer.bg) $color]} {
+ return
+ }
+
+ set coords [$cw coords $id]
+ set wdth [$cw itemcget $id -width]
+ set arrow [$cw itemcget $id -arrow]
+ set arwshp [$cw itemcget $id -arrowshape]
+ set dash [$cw itemcget $id -dash]
+ set smooth [$cw itemcget $id -smooth]
+ set splinesteps [$cw itemcget $id -splinesteps]
+
+ set cmdargs {}
+
+ if {$wdth > 1} {
+ lappend cmdargs -width $wdth
+ }
+ if {$dash ne ""} {
+ lappend cmdargs -dash $dash
+ }
+ if {$smooth ne ""} {
+ lappend cmdargs -smooth $smooth
+ }
+ if {$splinesteps ne ""} {
+ lappend cmdargs -splinesteps $splinesteps
+ }
+
+ set result [_gdi line $hdc {*}$coords \
+ -fill $color -arrow $arrow -arrowshape $arwshp \
+ {*}$cmdargs]
+ if {$result ne ""} {
+ puts $result
+ }
+ }
+
+ # _print_canvas.arc
+ # Prints a arc item.
+ # Args:
+ # hdc - The printer handle.
+ # cw - The canvas widget.
+ # id - The id of the canvas item.
+ proc _print_canvas.arc {hdc cw id} {
+ variable vtgPrint
+ variable printargs
+
+ set color [_print_canvas.TransColor [$cw itemcget $id -outline]]
+ if {[string match $vtgPrint(printer.bg) $color]} {
+ return
+ }
+ set coords [$cw coords $id]
+ set wdth [$cw itemcget $id -width]
+ set style [$cw itemcget $id -style]
+ set start [$cw itemcget $id -start]
+ set extent [$cw itemcget $id -extent]
+ set fill [$cw itemcget $id -fill]
+
+ set cmdargs {}
+ if {$wdth > 1} {
+ lappend cmdargs -width $wdth
+ }
+ if {$fill ne ""} {
+ lappend cmdargs -fill $fill
+ }
+
+ _gdi arc $hdc {*}$coords \
+ -outline $color -style $style -start $start -extent $extent \
+ {*}$cmdargs
+ }
+
+ # _print_canvas.polygon
+ # Prints a polygon item.
+ # Arguments:
+ # hdc - The printer handle.
+ # cw - The canvas widget.
+ # id - The id of the canvas item.
+ proc _print_canvas.polygon {hdc cw id} {
+ variable vtgPrint
+ variable printargs
+
+ set fcolor [_print_canvas.TransColor [$cw itemcget $id -fill]]
+ if {$fcolor eq ""} {
+ set fcolor $vtgPrint(printer.bg)
+ }
+ set ocolor [_print_canvas.TransColor [$cw itemcget $id -outline]]
+ if {$ocolor eq ""} {
+ set ocolor $vtgPrint(printer.bg)
+ }
+ set coords [$cw coords $id]
+ set wdth [$cw itemcget $id -width]
+ set smooth [$cw itemcget $id -smooth]
+ set splinesteps [$cw itemcget $id -splinesteps]
+
+ set cmdargs {}
+ if {$smooth ne ""} {
+ lappend cmdargs -smooth $smooth
+ }
+ if {$splinesteps ne ""} {
+ lappend cmdargs -splinesteps $splinesteps
+ }
+
+ _gdi polygon $hdc {*}$coords \
+ -width $wdth -fill $fcolor -outline $ocolor {*}$cmdargs
+ }
+
+ # _print_canvas.oval
+ # Prints an oval item.
+ # Arguments:
+ # hdc - The printer handle.
+ # cw - The canvas widget.
+ # id - The id of the canvas item.
+ proc _print_canvas.oval {hdc cw id} {
+ variable vtgPrint
+
+ set fcolor [_print_canvas.TransColor [$cw itemcget $id -fill]]
+ if {$fcolor eq ""} {
+ set fcolor $vtgPrint(printer.bg)
+ }
+ set ocolor [_print_canvas.TransColor [$cw itemcget $id -outline]]
+ if {$ocolor eq ""} {
+ set ocolor $vtgPrint(printer.bg)
+ }
+ set coords [$cw coords $id]
+ set wdth [$cw itemcget $id -width]
+
+ _gdi oval $hdc {*}$coords \
+ -width $wdth -fill $fcolor -outline $ocolor
+ }
+
+ # _print_canvas.rectangle
+ # Prints a rectangle item.
+ # Arguments:
+ # hdc - The printer handle.
+ # cw - The canvas widget.
+ # id - The id of the canvas item.
+ proc _print_canvas.rectangle {hdc cw id} {
+ variable vtgPrint
+
+ set fcolor [_print_canvas.TransColor [$cw itemcget $id -fill]]
+ if {$fcolor eq ""} {
+ set fcolor $vtgPrint(printer.bg)
+ }
+ set ocolor [_print_canvas.TransColor [$cw itemcget $id -outline]]
+ if {$ocolor eq ""} {
+ set ocolor $vtgPrint(printer.bg)
+ }
+ set coords [$cw coords $id]
+ set wdth [$cw itemcget $id -width]
+
+ _gdi rectangle $hdc {*}$coords \
+ -width $wdth -fill $fcolor -outline $ocolor
+ }
+
+ # _print_canvas.text
+ # Prints a text item.
+ # Arguments:
+ # hdc - The printer handle.
+ # cw - The canvas widget.
+ # id - The id of the canvas item.
+ proc _print_canvas.text {hdc cw id} {
+ variable vtgPrint
+ variable printargs
+
+ set color [_print_canvas.TransColor [$cw itemcget $id -fill]]
+ # if {"white" eq [string tolower $color]} {return}
+ # set color black
+ set txt [$cw itemcget $id -text]
+ if {$txt eq ""} {
+ return
+ }
+ set coords [$cw coords $id]
+ set anchr [$cw itemcget $id -anchor]
+
+ set bbox [$cw bbox $id]
+ set wdth [expr {[lindex $bbox 2] - [lindex $bbox 0]}]
+
+ set just [$cw itemcget $id -justify]
+
+ # Get the real canvas font info and create a compatible font,
+ # suitable for printer name extraction.
+ set font [font create {*}[font actual [$cw itemcget $id -font]]]
+
+ # Just get the name and family, or some of the _gdi commands will
+ # fail.
+ set font [list [font configure $font -family] \
+ -[font configure $font -size]]
+
+ _gdi text $hdc {*}$coords \
+ -fill $color -text $txt -font $font \
+ -anchor $anchr -width $wdth -justify $just
+ }
+
+ # _print_canvas.image
+ # Prints an image item.
+ # Arguments:
+ # hdc - The printer handle.
+ # cw - The canvas widget.
+ # id - The id of the canvas item.
+ proc _print_canvas.image {hdc cw id} {
+ # First, we have to get the image name.
+ set imagename [$cw itemcget $id -image]
+
+ # Now we get the size.
+ set wid [image width $imagename]
+ set hgt [image height $imagename]
+
+ # Next, we get the location and anchor
+ set anchor [$cw itemcget $id -anchor]
+ set coords [$cw coords $id]
+
+ _gdi photo $hdc -destination $coords -photo $imagename
+ }
+
+ # _print_canvas.bitmap
+ # Prints a bitmap item.
+ # Arguments:
+ # hdc - The printer handle.
+ # cw - The canvas widget.
+ # id - The id of the canvas item.
+ proc _print_canvas.bitmap {hdc cw id} {
+ variable option
+ variable vtgPrint
+
+ # First, we have to get the bitmap name.
+ set imagename [$cw itemcget $id -image]
+
+ # Now we get the size.
+ set wid [image width $imagename]
+ set hgt [image height $imagename]
+
+ #Next, we get the location and anchor.
+ set anchor [$cw itemcget $id -anchor]
+ set coords [$cw coords $id]
+
+ # Since the GDI commands don't yet support images and bitmaps,
+ # and since this represents a rendered bitmap, we CAN use
+ # copybits IF we create a new temporary toplevel to hold the beast.
+ # If this is too ugly, change the option!
+
+ if {[info exist option(use_copybits)]} {
+ set firstcase $option(use_copybits)
+ } else {
+ set firstcase 0
+ }
+ if {$firstcase > 0} {
+ set tl [toplevel .tmptop[expr {int( rand() * 65535 )}] \
+ -height $hgt -width $wid \
+ -background $vtgPrint(canvas.bg)]
+ canvas $tl.canvas -width $wid -height $hgt
+ $tl.canvas create image 0 0 -image $imagename -anchor nw
+ pack $tl.canvas -side left -expand false -fill none
+ tkwait visibility $tl.canvas
+ update
+ set srccoords [list 0 0 [expr {$wid - 1}] [expr {$hgt - 1}]]
+ set dstcoords [list [lindex $coords 0] [lindex $coords 1] [expr {$wid - 1}] [expr {$hgt - 1}]]
+ _gdi copybits $hdc -window $tl -client \
+ -source $srccoords -destination $dstcoords
+ destroy $tl
+ } else {
+ _gdi bitmap $hdc {*}$coords \
+ -anchor $anchor -bitmap $imagename
+ }
+ }
+
+ # These procedures transform attribute setting from the real
+ # canvas to the appropriate setting for printing to paper.
+
+ # _print_canvas.TransColor
+ # Does the actual transformation of colors from the
+ # canvas widget to paper.
+ # Arguments:
+ # color - The color value to be transformed.
+ proc _print_canvas.TransColor {color} {
+ variable vtgPrint
+ variable printargs
+
+ switch [string toupper $color] {
+ $vtgPrint(canvas.bg) {return $vtgPrint(printer.bg)}
+ }
+ return $color
+ }
+
+ # Initialize all the variables once.
+ _init_print_canvas
+ }
+ #end win32 procedures
+}
+
+# Begin X11 procedures. They depends on Cups being installed.
+# X11 procedures abstracts print management with a "cups" ensemble command
+
+# cups defaultprinter returns the default printer
+# cups getprinters returns a dictionary of printers along
+# with printer info
+# cups print $printer $data ?$options?
+# print the data (binary) on a given printer
+# with the provided (supported) options:
+# -colormode -copies -format -margins
+# -media -nup -orientation
+# -prettyprint -title -tzoom
+
+# Some output configuration that on other platforms is managed through
+# the printer driver/dialog is configured through the canvas postscript command.
+if {[tk windowingsystem] eq "x11"} {
+ if {[info commands ::tk::print::cups] eq ""} {
+ namespace eval ::tk::print::cups {
+ # Pure Tcl cups ensemble command implementation
+ variable pcache
+ }
+
+ proc ::tk::print::cups::defaultprinter {} {
+ set default {}
+ regexp {: ([^[:space:]]+)$} [exec lpstat -d] _ default
+ return $default
+ }
+
+ proc ::tk::print::cups::getprinters {} {
+ variable pcache
+ # Test for existence of lpstat command to obtain the list of
+ # printers.
+ # Return an error if not found.
+ set res {}
+ try {
+ set printers [lsort -unique [split [exec lpstat -e] \n]]
+ foreach printer $printers {
+ set options [Parseoptions [exec lpoptions -p $printer]]
+ dict set res $printer $options
+ }
+ } trap {POSIX ENOENT} {e o} {
+ # no such command in PATH
+ set cmd [lindex [dict get $o -errorstack ] 1 2]
+ return -code error "Unable to obtain the list of printers.\
+ Command \"$cmd\" not found.\
+ Please install the CUPS package for your system."
+ } trap {CHILDSTATUS} {} {
+ # command returns a non-0 exit status. Wrong print system?
+ set cmd [lindex [dict get $o -errorstack ] 1 2]
+ return -code error "Command \"$cmd\" return with errors"
+ }
+ return [set pcache $res]
+ }
+
+ # Parseoptions
+ # Parse lpoptions -d output. It has three forms
+ # option-key
+ # option-key=option-value
+ # option-key='option value with spaces'
+ # Arguments:
+ # data - data to process.
+ #
+ proc ::tk::print::cups::Parseoptions {data} {
+ set res {}
+ set re {[^ =]+|[^ ]+='[^']+'|[^ ]+=[^ ']+}
+ foreach tok [regexp -inline -all $re $data] {
+ lassign [split $tok "="] k v
+ dict set res $k [string trim $v "'"]
+ }
+ return $res
+ }
+
+ proc ::tk::print::cups::print {printer data args} {
+ variable pcache
+ if {$printer ni [dict keys $pcache]} {
+ return -code error "unknown printer or class \"$printer\""
+ }
+ set title "Tk print job"
+ set options {
+ -colormode -copies -format -margins -media -nup -orientation
+ -prettyprint -title -tzoom
+ }
+ while {[llength $args]} {
+ set opt [tcl::prefix match $options [lpop args 0]]
+ switch $opt {
+ -colormode {
+ set opts {auto monochrome color}
+ set val [tcl::prefix match $opts [lpop args 0]]
+ lappend printargs -o print-color-mode=$val
+ }
+ -copies {
+ set val [lpop args 0]
+ if {![string is integer -strict $val] ||
+ $val < 0 || $val > 100
+ } {
+ # save paper !!
+ return -code error "copies must be an integer\
+ between 0 and 100"
+ }
+ lappend printargs -o copies=$val
+ }
+ -format {
+ set opts {auto pdf postscript text}
+ set val [tcl::prefix match $opts [lpop args 0]]
+ # lpr uses auto always
+ }
+ -margins {
+ set val [lpop args 0]
+ if {[llength $val] != 4 ||
+ ![string is integer -strict [lindex $val 0]] ||
+ ![string is integer -strict [lindex $val 1]] ||
+ ![string is integer -strict [lindex $val 2]] ||
+ ![string is integer -strict [lindex $val 3]]
+ } {
+ return -code error "margins must be a list of 4\
+ integers: top left bottom right"
+ }
+ lappend printargs -o page-top=[lindex $val 0]
+ lappend printargs -o page-left=[lindex $val 1]
+ lappend printargs -o page-bottom=[lindex $val 2]
+ lappend printargs -o page-right=[lindex $val 3]
+ }
+ -media {
+ set opts {a4 legal letter}
+ set val [tcl::prefix match $opts [lpop args 0]]
+ lappend printargs -o media=$val
+ }
+ -nup {
+ set val [lpop args 0]
+ if {$val ni {1 2 4 6 9 16}} {
+ return -code error "number-up must be 1, 2, 4, 6, 9 or\
+ 16"
+ }
+ lappend printargs -o number-up=$val
+ }
+ -orientation {
+ set opts {portrait landscape}
+ set val [tcl::prefix match $opts [lpop args 0]]
+ if {$val eq "landscape"}
+ lappend printargs -o landscape=true
+ }
+ -prettyprint {
+ lappend printargs -o prettyprint=true
+ # prettyprint mess with these default values if set
+ # so we force them.
+ # these will be overriden if set after this point
+ if {[lsearch $printargs {cpi=*}] == -1} {
+ lappend printargs -o cpi=10.0
+ lappend printargs -o lpi=6.0
+ }
+ }
+ -title {
+ set title [lpop args 0]
+ }
+ -tzoom {
+ set val [lpop args 0]
+ if {![string is double -strict $val] ||
+ $val < 0.5 || $val > 2.0
+ } {
+ return -code error "text zoom must be a number between\
+ 0.5 and 2.0"
+ }
+ # CUPS text filter defaults to lpi=6 and cpi=10
+ lappend printargs -o cpi=[expr {10.0 / $val}]
+ lappend printargs -o lpi=[expr {6.0 / $val}]
+ }
+ default {
+ # shouldn't happen
+ }
+ }
+ }
+ # build our options
+ lappend printargs -T $title
+ lappend printargs -P $printer
+ # open temp file
+ set fd [file tempfile fname tk_print]
+ chan configure $fd -translation binary
+ chan puts $fd $data
+ chan close $fd
+ # add -r to automatically delete temp files
+ exec lpr {*}$printargs -r $fname &
+ }
+
+ namespace eval ::tk::print::cups {
+ namespace export defaultprinter getprinters print
+ namespace ensemble create
+ }
+ };# ::tk::print::cups
+
+ namespace eval ::tk::print {
+
+ variable mcmap
+ set mcmap(media) [dict create \
+ [mc "Letter"] letter \
+ [mc "Legal"] legal \
+ [mc "A4"] a4]
+ set mcmap(orient) [dict create \
+ [mc "Portrait"] portrait \
+ [mc "Landscape"] landscape]
+ set mcmap(color) [dict create \
+ [mc "RGB"] color \
+ [mc "Grayscale"] gray]
+
+ # available print options
+ variable optlist
+ set optlist(printer) {}
+ set optlist(media) [dict keys $mcmap(media)]
+ set optlist(orient) [dict keys $mcmap(orient)]
+ set optlist(color) [dict keys $mcmap(color)]
+ set optlist(number-up) {1 2 4 6 9 16}
+
+ # selected options
+ variable option
+ set option(printer) {}
+ # Initialize with sane defaults.
+ set option(copies) 1
+ set option(media) [mc "A4"]
+ # Canvas options
+ set option(orient) [mc "Portrait"]
+ set option(color) [mc "RGB"]
+ set option(czoom) 100
+ # Text options.
+ # See libcupsfilter's cfFilterTextToPDF() and cups-filters's texttopdf
+ # known options:
+ # prettyprint, wrap, columns, lpi, cpi
+ set option(number-up) 1
+ set option(tzoom) 100; # we derive lpi and cpi from this value
+ set option(pprint) 0 ; # pretty print
+ set option(margin-top) 20 ; # ~ 7mm (~ 1/4")
+ set option(margin-left) 20 ; # ~ 7mm (~ 1/4")
+ set option(margin-right) 20 ; # ~ 7mm (~ 1/4")
+ set option(margin-bottom) 20 ; # ~ 7mm (~ 1/4")
+
+ # array to collect printer information
+ variable pinfo
+ array set pinfo {}
+
+ # a map for printer state -> human readable message
+ variable statemap
+ dict set statemap 3 [mc "Idle"]
+ dict set statemap 4 [mc "Printing"]
+ dict set statemap 5 [mc "Printer stopped"]
+ }
+
+ # ttk version of [tk_optionMenu]
+ # var should be a full qualified varname
+ proc ::tk::print::ttk_optionMenu {w var args} {
+ ttk::menubutton $w -textvariable $var -menu $w.menu
+ menu $w.menu
+ foreach option $args {
+ $w.menu add command \
+ -label $option \
+ -command [list set $var $option]
+ }
+ # return the same value as tk_optionMenu
+ return $w.menu
+ }
+
+ # _setprintenv
+ # Set the print environtment - list of printers, state and options.
+ # Arguments:
+ # none.
+ #
+ proc ::tk::print::_setprintenv {} {
+ variable option
+ variable optlist
+ variable pinfo
+
+ set optlist(printer) {}
+ dict for {printer options} [cups getprinters] {
+ lappend optlist(printer) $printer
+ set pinfo($printer) $options
+ }
+
+ # It's an error to not have any printer configured
+ if {[llength $optlist(printer)] == 0} {
+ return -code error "No installed printers found.\
+ Please check or update your CUPS installation."
+ }
+
+ # If no printer is selected, check for the default one
+ # If none found, use the first one from the list
+ if {$option(printer) eq ""} {
+ set option(printer) [cups defaultprinter]
+ if {$option(printer) eq ""} {
+ set option(printer) [lindex $optlist(printer) 0]
+ }
+ }
+ }
+
+ # _print
+ # Main printer dialog.
+ # Select printer, set options, and fire print command.
+ # Arguments:
+ # w - widget with contents to print.
+ #
+ proc ::tk::print::_print {w} {
+ variable optlist
+ variable option
+ variable pinfo
+ variable statemap
+
+ # default values for dialog widgets
+ option add *Printdialog*TLabel.anchor e
+ option add *Printdialog*TMenubutton.Menu.tearOff 0
+ option add *Printdialog*TMenubutton.width 12
+ option add *Printdialog*TSpinbox.width 12
+ # this is tempting to add, but it's better to leave it to
+ # user's taste.
+ # option add *Printdialog*Menu.background snow
+
+ set class [winfo class $w]
+ if {$class ni {Text Canvas}} {
+ return -code error "printing windows of class \"$class\"\
+ is not supported"
+ }
+ # Should this be called with every invocaton?
+ # Yes. It allows dynamic discovery of newly added printers
+ # whithout having to restart the app
+ _setprintenv
+
+ set p ._print
+ destroy $p
+
+ # Copy the current values to a dialog's temporary variable.
+ # This allow us to cancel the dialog discarding any changes
+ # made to the options
+ namespace eval dlg {variable option}
+ array set dlg::option [array get option]
+ set var [namespace which -variable dlg::option]
+
+ # The toplevel of our dialog
+ toplevel $p -class Printdialog
+ place [ttk::frame $p.background] -x 0 -y 0 -relwidth 1.0 -relheight 1.0
+ wm title $p [mc "Print"]
+ wm resizable $p 0 0
+ wm attributes $p -type dialog
+ wm transient $p [winfo toplevel $w]
+
+ # The printer to use
+ set pf [ttk::frame $p.printerf]
+ pack $pf -side top -fill x -expand no -padx 9p -pady 9p
+
+ ttk::label $pf.printerl -text "[mc "Printer"]"
+ set tv [ttk::treeview $pf.prlist -height 5 \
+ -columns {printer location state} \
+ -show headings \
+ -selectmode browse]
+ $tv configure \
+ -yscrollcommand [namespace code [list _scroll $pf.sy]] \
+ -xscrollcommand [namespace code [list _scroll $pf.sx]]
+ ttk::scrollbar $pf.sy -command [list $tv yview]
+ ttk::scrollbar $pf.sx -command [list $tv xview] -orient horizontal
+ $tv heading printer -text [mc "Printer"]
+ $tv heading location -text [mc "Location"]
+ $tv heading state -text [mc "State"]
+ $tv column printer -width 200 -stretch 0
+ $tv column location -width 100 -stretch 0
+ $tv column state -width 250 -stretch 0
+
+ foreach printer $optlist(printer) {
+ set location [dict getdef $pinfo($printer) printer-location ""]
+ set nstate [dict getdef $pinfo($printer) printer-state 0]
+ set state [dict getdef $statemap $nstate ""]
+ switch -- $nstate {
+ 3 - 4 {
+ set accepting [dict getdef $pinfo($printer) \
+ printer-is-accepting-jobs ""]
+ if {$accepting ne ""} {
+ append state ". " [mc "Printer is accepting jobs"]
+ }
+ }
+ 5 {
+ set reason [dict getdef $pinfo($printer) \
+ printer-state-reasons ""]
+ if {$reason ne ""} {
+ append state ". (" $reason ")"
+ }
+ }
+ }
+ set id [$tv insert {} end \
+ -values [list $printer $location $state]]
+ if {$option(printer) eq $printer} {
+ $tv selection set $id
+ }
+ }
+
+ grid $pf.printerl -sticky w
+ grid $pf.prlist $pf.sy -sticky news
+ grid $pf.sx -sticky ew
+ grid remove $pf.sy $pf.sx
+ bind $tv <<TreeviewSelect>> [namespace code {_onselect %W}]
+
+ # Start of printing options
+ set of [ttk::labelframe $p.optionsframe -text [mc "Options"]]
+ pack $of -fill x -padx 9p -pady {0 9p} -ipadx 2p -ipady 2p
+
+ # COPIES
+ ttk::label $of.copiesl -text "[mc "Copies"] :"
+ ttk::spinbox $of.copies -textvariable ${var}(copies) \
+ -from 1 -to 1000
+ grid $of.copiesl $of.copies -sticky ew -padx 2p -pady 2p
+ $of.copies state readonly
+
+ # PAPER SIZE
+ ttk::label $of.medial -text "[mc "Paper"] :"
+ ttk_optionMenu $of.media ${var}(media) {*}$optlist(media)
+ grid $of.medial $of.media -sticky ew -padx 2p -pady 2p
+
+ if {$class eq "Canvas"} {
+ # additional options for Canvas output
+ # SCALE
+ ttk::label $of.percentl -text "[mc "Scale"] :"
+ ttk::spinbox $of.percent -textvariable ${var}(czoom) \
+ -from 5 -to 500 -increment 5
+ grid $of.percentl $of.percent -sticky ew -padx 2p -pady 2p
+ $of.percent state readonly
+
+ # ORIENT
+ ttk::label $of.orientl -text "[mc "Orientation"] :"
+ ttk_optionMenu $of.orient ${var}(orient) {*}$optlist(orient)
+ grid $of.orientl $of.orient -sticky ew -padx 2p -pady 2p
+
+ # COLOR
+ ttk::label $of.colorl -text "[mc "Output"] :"
+ ttk_optionMenu $of.color ${var}(color) {*}$optlist(color)
+ grid $of.colorl $of.color -sticky ew -padx 2p -pady 2p
+ } elseif {$class eq "Text"} {
+ # additional options for Text output
+ # NUMBER-UP
+ ttk::label $of.nupl -text "[mc "Pages per sheet"] :"
+ ttk_optionMenu $of.nup ${var}(number-up) {*}$optlist(number-up)
+ grid $of.nupl $of.nup -sticky ew -padx 2p -pady 2p
+
+ # TEXT SCALE
+ ttk::label $of.tzooml -text "[mc "Text scale"] :"
+ ttk::spinbox $of.tzoom -textvariable ${var}(tzoom) \
+ -from 50 -to 200 -increment 5
+ grid $of.tzooml $of.tzoom -sticky ew -padx 2p -pady 2p
+ $of.tzoom state readonly
+
+ # PRETTY PRINT (banner on top)
+ ttk::checkbutton $of.pprint -onvalue 1 -offvalue 0 \
+ -text [mc "Pretty print"] \
+ -variable ${var}(pprint)
+ grid $of.pprint - -sticky ew -padx 2p -pady 2p
+ }
+
+ # The buttons frame.
+ set bf [ttk::frame $p.buttonf]
+ pack $bf -fill x -expand no -side bottom -padx 9p -pady {0 9p}
+
+ ttk::button $bf.print -text [mc "Print"] \
+ -command [namespace code [list _runprint $w $class $p]]
+ ttk::button $bf.cancel -text [mc "Cancel"] \
+ -command [list destroy $p]
+ pack $bf.print -side right
+ pack $bf.cancel -side right -padx {0 4.5p}
+
+ # cleanup binding
+ bind $bf <Destroy> [namespace code [list _cleanup $p]]
+
+ # Center the window as a dialog.
+ ::tk::PlaceWindow $p
+ }
+
+ # _onselect
+ # Updates the selected printer when treeview selection changes.
+ # Arguments:
+ # tv - treeview pathname.
+ #
+ proc ::tk::print::_onselect {tv} {
+ variable dlg::option
+ set id [$tv selection]
+ if {$id eq ""} {
+ # is this even possible?
+ set option(printer) ""
+ } else {
+ set option(printer) [$tv set $id printer]
+ }
+ }
+
+ # _scroll
+ # Implements autoscroll for the printers view
+ #
+ proc ::tk::print::_scroll {sbar from to} {
+ if {$from == 0.0 && $to == 1.0} {
+ grid remove $sbar
+ } else {
+ grid $sbar
+ $sbar set $from $to
+ }
+ }
+
+ # _cleanup
+ # Perform cleanup when the dialog is destroyed.
+ # Arguments:
+ # p - print dialog pathname (not used).
+ #
+ proc ::tk::print::_cleanup {p} {
+ namespace delete dlg
+ }
+
+ # _runprint -
+ # Execute the print command--print the file.
+ # Arguments:
+ # w - widget with contents to print.
+ # class - class of the widget to print (Canvas or Text).
+ # p - print dialog pathname.
+ #
+ proc ::tk::print::_runprint {w class p} {
+ variable option
+ variable mcmap
+
+ # copy the values back from the dialog
+ array set option [array get dlg::option]
+
+ # get (back) name of media from the translated one
+ set media [dict get $mcmap(media) $option(media)]
+ set printargs {}
+ lappend printargs -title "[tk appname]: Tk window $w"
+ lappend printargs -copies $option(copies)
+ lappend printargs -media $media
+
+ if {$class eq "Canvas"} {
+ set colormode [dict get $mcmap(color) $option(color)]
+ set rotate 0
+ if {[dict get $mcmap(orient) $option(orient)] eq "landscape"} {
+ set rotate 1
+ }
+ # Scale based on size of widget, not size of paper.
+ # TODO: is this correct??
+ set printwidth [expr {
+ $option(czoom) / 100.0 * [winfo width $w]
+ }]
+ set data [encoding convertto iso8859-1 [$w postscript \
+ -colormode $colormode -rotate $rotate -pagewidth $printwidth]]
+ } elseif {$class eq "Text"} {
+ set tzoom [expr {$option(tzoom) / 100.0}]
+ if {$option(tzoom) != 100} {
+ lappend printargs -tzoom $tzoom
+ }
+ if {$option(pprint)} {
+ lappend printargs -prettyprint
+ }
+ if {$option(number-up) != 1} {
+ lappend printargs -nup $option(number-up)
+ }
+ # these are hardcoded. Should we allow the user to control
+ # margins?
+ lappend printargs -margins [list \
+ $option(margin-top) $option(margin-left) \
+ $option(margin-bottom) $option(margin-right) ]
+ # get the data in shape. Cupsfilter's text filter wraps lines
+ # at character level, not words, so we do it by ourselves.
+ # compute usable page width in inches
+ set pw [dict get {a4 8.27 legal 8.5 letter 8.5} $media]
+ set pw [expr {
+ $pw - ($option(margin-left) + $option(margin-right)) / 72.0
+ }]
+ # set the wrap length at 98% of computed page width in chars
+ # the 9.8 constant is the product 10.0 (default cpi) * 0.95
+ set wl [expr {int( 9.8 * $pw / $tzoom )}]
+ set data [encoding convertto utf-8 [_wrapLines [$w get 1.0 end] $wl]]
+ }
+
+ # launch the job in the background
+ after idle [namespace code \
+ [list cups print $option(printer) $data {*}$printargs]]
+ destroy $p
+ }
+
+ # _wrapLines -
+ # wrap long lines into lines of at most length wl at word boundaries
+ # Arguments:
+ # str - string to be wrapped
+ # wl - wrap length
+ #
+ proc ::tk::print::_wrapLines {str wl} {
+ # This is a really simple algorithm: it breaks a line on space or tab
+ # character, collapsing them only at the breaking point.
+ # Leading space is left as-is.
+ # For a full fledged line breaking algorithm see
+ # Unicode® Standard Annex #14 "Unicode Line Breaking Algorithm"
+ set res {}
+ incr wl -1
+ set re [format {((?:^|[^[:blank:]]).{0,%d})(?:[[:blank:]]|$)} $wl]
+ foreach line [split $str \n] {
+ lappend res {*}[lmap {_ l} [regexp -all -inline -- $re $line] {
+ set l
+ }]
+ }
+ return [join $res \n]
+ }
+}
+#end X11 procedures
+
+namespace eval ::tk::print {
+ #begin macOS Aqua procedures
+ if {[tk windowingsystem] eq "aqua"} {
+ # makePDF -
+ # Convert a file to PDF
+ # Arguments:
+ # inFilename - file containing the data to convert; format is
+ # autodetected.
+ # outFilename - base for filename to write to; conventionally should
+ # have .pdf as suffix
+ # Returns:
+ # The full pathname of the generated PDF.
+ #
+ proc makePDF {inFilename outFilename} {
+ set out [::tk::print::makeTempFile $outFilename]
+ try {
+ exec /usr/sbin/cupsfilter $inFilename > $out
+ } trap NONE {msg} {
+ # cupsfilter produces a lot of debugging output, which we
+ # don't want.
+ regsub -all -line {^(?:DEBUG|INFO):.*$} $msg "" msg
+ set msg [string trimleft [regsub -all {\n+} $msg "\n"] "\n"]
+ if {$msg ne ""} {
+ # Lines should be prefixed with WARN or ERROR now
+ puts $msg
+ }
+ }
+ return $out
+ }
+ }
+ #end macOS Aqua procedures
+
+ namespace export canvas text
+ namespace ensemble create
+}
+
+# tk print --
+# This procedure prints the canvas and text widgets using platform-
+# native API's.
+# Arguments:
+# w: Widget to print.
+proc ::tk::print {w} {
+ switch [winfo class $w],[tk windowingsystem] {
+ "Canvas,win32" {
+ tailcall ::tk::print::_print_widget $w 0 "Tk Print Output"
+ }
+ "Canvas,x11" {
+ tailcall ::tk::print::_print $w
+ }
+ "Canvas,aqua" {
+ ::tk::print::_printcanvas $w
+ set printfile /tmp/tk_canvas.pdf
+ ::tk::print::_print $printfile
+ }
+ "Text,win32" {
+ tailcall ::tk::print::_print_data [$w get 1.0 end] 1 {Arial 12}
+ }
+ "Text,x11" {
+ tailcall ::tk::print::_print $w
+ }
+ "Text,aqua" {
+ set txtfile [::tk::print::makeTempFile tk_text.txt [$w get 1.0 end]]
+ try {
+ set printfile [::tk::print::makePDF $txtfile [file join /tmp tk_text.pdf]]
+ ::tk::print::_print $printfile
+ } finally {
+ file delete $txtfile
+ }
+ }
+
+ default {
+ return -code error -errorcode {TK PRINT CLASS_UNSUPPORTED} \
+ "widgets of class [winfo class $w] are not supported on\
+ this platform"
+ }
+ }
+}
+
+#Add this command to the tk command ensemble: tk print
+#Thanks to Christian Gollwitzer for the guidance here
+namespace ensemble configure tk -map \
+ [dict merge [namespace ensemble configure tk -map] \
+ {print ::tk::print}]
+
+return
+
+# Local Variables:
+# mode: tcl
+# fill-column: 78
+# End:
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/print.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/safetk.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/safetk.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/safetk.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,262 @@
+# safetk.tcl --
+#
+# Support procs to use Tk in safe interpreters.
+#
+# Copyright © 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 now ok to let untrusted code being executed
+# between the creation of the interp and the actual loading
+# of Tk in that interp because the C side Tk_Init will
+# now look up the parent interp and ask its safe::TkInit
+# for the actual parameters to use for it's initialization (if allowed),
+# not relying on the child state.
+#
+
+# We use opt (optional arguments parsing)
+package require opt 0.4.1;
+
+namespace eval ::safe {
+
+ # counter for safe toplevels
+ variable tkSafeId 0
+}
+
+#
+# tkInterpInit : prepare the child interpreter for tk loading
+# most of the real job is done by loadTk
+# returns the child name (tkInterpInit does)
+#
+proc ::safe::tkInterpInit {child argv} {
+ global env tk_library
+
+ # We have to make sure that the tk_library variable is normalized.
+ set tk_library [file normalize $tk_library]
+
+ # Clear Tk's access for that interp (path).
+ allowTk $child $argv
+
+ # Ensure tk_library and subdirs (eg, ttk) are on the access path
+ ::interp eval $child [list set tk_library [::safe::interpAddToAccessPath $child $tk_library]]
+ foreach subdir [::safe::AddSubDirs [list $tk_library]] {
+ ::safe::interpAddToAccessPath $child $subdir
+ }
+ return $child
+}
+
+
+# tkInterpLoadTk:
+# Do additional configuration as needed (calling tkInterpInit)
+# and actually load Tk into the child.
+#
+# Either contained in the specified windowId (-use) or
+# creating a decorated toplevel for it.
+
+# empty definition for auto_mkIndex
+proc ::safe::loadTk {} {}
+
+::tcl::OptProc ::safe::loadTk {
+ {child -interp "name of the child interpreter"}
+ {-use -windowId {} "window Id to use (new toplevel otherwise)"}
+ {-display -displayName {} "display name to use (current one otherwise)"}
+} {
+ set displayGiven [::tcl::OptProcArgGiven "-display"]
+ if {!$displayGiven} {
+ # Try to get the current display from "."
+ # (which might not exist if the parent is tk-less)
+ if {[catch {set display [winfo screen .]}]} {
+ if {[info exists ::env(DISPLAY)]} {
+ set display $::env(DISPLAY)
+ } else {
+ Log $child "no winfo screen . nor env(DISPLAY)" WARNING
+ set display ":0.0"
+ }
+ }
+ }
+
+ # Get state for access to the cleanupHook.
+ namespace upvar ::safe S$child state
+
+ if {![::tcl::OptProcArgGiven "-use"]} {
+ # create a decorated toplevel
+ lassign [tkTopLevel $child $display] w use
+
+ # set our delete hook (child arg is added by interpDelete)
+ # to clean up both window related code and tkInit(child)
+ set state(cleanupHook) [list tkDelete {} $w]
+ } else {
+ # set our delete hook (child arg is added by interpDelete)
+ # to clean up tkInit(child)
+ set state(cleanupHook) [list disallowTk]
+
+ # Let's be nice and also accept tk window names instead of ids
+ if {[string match ".*" $use]} {
+ set windowName $use
+ set use [winfo id $windowName]
+ set nDisplay [winfo screen $windowName]
+ } else {
+ # Check for a better -display value
+ # (works only for multi screens on single host, but not
+ # cross hosts, for that a tk window name would be better
+ # but embeding is also usefull for non tk names)
+ if {![catch {winfo pathname $use} name]} {
+ set nDisplay [winfo screen $name]
+ } else {
+ # Can't have a better one
+ set nDisplay $display
+ }
+ }
+ if {$nDisplay ne $display} {
+ if {$displayGiven} {
+ return -code error -errorcode {TK DISPLAY SAFE} \
+ "conflicting -display $display and -use $use -> $nDisplay"
+ } else {
+ set display $nDisplay
+ }
+ }
+ }
+
+ # Prepares the child for tk with those parameters
+ tkInterpInit $child [list "-use" $use "-display" $display]
+
+ load {} Tk $child
+
+ return $child
+}
+
+proc ::safe::TkInit {interpPath} {
+ variable tkInit
+ if {[info exists tkInit($interpPath)]} {
+ set value $tkInit($interpPath)
+ Log $interpPath "TkInit called, returning \"$value\"" NOTICE
+ return $value
+ } else {
+ Log $interpPath "TkInit called for interp with clearance:\
+ preventing Tk init" ERROR
+ return -code error -errorcode {TK SAFE PERMISSION} "not allowed"
+ }
+}
+
+# safe::allowTk --
+#
+# Set tkInit(interpPath) to allow Tk to be initialized in
+# safe::TkInit.
+#
+# Arguments:
+# interpPath child interpreter handle
+# argv arguments passed to safe::TkInterpInit
+#
+# Results:
+# none.
+
+proc ::safe::allowTk {interpPath argv} {
+ variable tkInit
+ set tkInit($interpPath) $argv
+ return
+}
+
+
+# safe::disallowTk --
+#
+# Unset tkInit(interpPath) to disallow Tk from getting initialized
+# in safe::TkInit.
+#
+# Arguments:
+# interpPath child interpreter handle
+#
+# Results:
+# none.
+
+proc ::safe::disallowTk {interpPath} {
+ variable tkInit
+ # This can already be deleted by the DeleteHook of the interp
+ if {[info exists tkInit($interpPath)]} {
+ unset tkInit($interpPath)
+ }
+ return
+}
+
+
+# safe::tkDelete --
+#
+# Clean up the window associated with the interp being deleted.
+#
+# Arguments:
+# interpPath child interpreter handle
+#
+# Results:
+# none.
+
+proc ::safe::tkDelete {W window child} {
+
+ # we are going to be called for each widget... skip untill it's
+ # top level
+
+ Log $child "Called tkDelete $W $window" NOTICE
+ if {[::interp exists $child]} {
+ if {[catch {::safe::interpDelete $child} msg]} {
+ Log $child "Deletion error : $msg"
+ }
+ }
+ if {[winfo exists $window]} {
+ Log $child "Destroy toplevel $window" NOTICE
+ destroy $window
+ }
+
+ # clean up tkInit(child)
+ disallowTk $child
+ return
+}
+
+proc ::safe::tkTopLevel {child display} {
+ variable tkSafeId
+ incr tkSafeId
+ set w ".safe$tkSafeId"
+ if {[catch {toplevel $w -screen $display -class SafeTk} msg]} {
+ return -code error -errorcode {TK TOPLEVEL SAFE} \
+ "Unable to create toplevel for \"$child\" ($msg)"
+ }
+ Log $child "New toplevel $w" NOTICE
+
+ set msg "Untrusted Tcl applet ($child)"
+ wm title $w $msg
+
+ # Control frame (we must create a style for it)
+ ttk::style layout TWarningFrame {WarningFrame.border -sticky nswe}
+ ttk::style configure TWarningFrame -background red
+
+ set wc $w.fc
+ ttk::frame $wc -relief ridge -borderwidth 4 -style TWarningFrame
+
+ # We will destroy the interp when the window is destroyed
+ bindtags $wc [concat Safe$wc [bindtags $wc]]
+ bind Safe$wc <Destroy> [list ::safe::tkDelete %W $w $child]
+
+ ttk::label $wc.l -text $msg -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
+ ttk::frame $wc.fb -borderwidth 0
+ ttk::button $wc.fb.b -text "Delete" \
+ -command [list ::safe::tkDelete $w $w $child]
+ 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 -ipady 1.5p
+ 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]
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/safetk.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/scale.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/scale.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/scale.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,299 @@
+# scale.tcl --
+#
+# This file defines the default bindings for Tk scale widgets and provides
+# procedures that help in implementing the bindings.
+#
+# Copyright © 1994 The Regents of the University of California.
+# Copyright © 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 <Enter> {
+ if {$tk_strictMotif} {
+ set tk::Priv(activeBg) [%W cget -activebackground]
+ %W configure -activebackground [%W cget -background]
+ }
+ tk::ScaleActivate %W %x %y
+}
+bind Scale <Motion> {
+ tk::ScaleActivate %W %x %y
+}
+bind Scale <Leave> {
+ if {$tk_strictMotif} {
+ %W configure -activebackground $tk::Priv(activeBg)
+ }
+ if {[%W cget -state] eq "active"} {
+ %W configure -state normal
+ }
+}
+bind Scale <Button-1> {
+ tk::ScaleButtonDown %W %x %y
+}
+bind Scale <B1-Motion> {
+ tk::ScaleDrag %W %x %y
+}
+bind Scale <B1-Leave> { }
+bind Scale <B1-Enter> { }
+bind Scale <ButtonRelease-1> {
+ tk::CancelRepeat
+ tk::ScaleEndDrag %W
+ tk::ScaleActivate %W %x %y
+}
+bind Scale <Button-2> {
+ tk::ScaleButton2Down %W %x %y
+}
+bind Scale <B2-Motion> {
+ tk::ScaleDrag %W %x %y
+}
+bind Scale <B2-Leave> { }
+bind Scale <B2-Enter> { }
+bind Scale <ButtonRelease-2> {
+ tk::CancelRepeat
+ tk::ScaleEndDrag %W
+ tk::ScaleActivate %W %x %y
+}
+bind Scale <Control-Button-1> {
+ tk::ScaleControlPress %W %x %y
+}
+bind Scale <<PrevLine>> {
+ tk::ScaleIncrement %W up little noRepeat
+}
+bind Scale <<NextLine>> {
+ tk::ScaleIncrement %W down little noRepeat
+}
+bind Scale <<PrevChar>> {
+ tk::ScaleIncrement %W up little noRepeat
+}
+bind Scale <<NextChar>> {
+ tk::ScaleIncrement %W down little noRepeat
+}
+bind Scale <<PrevPara>> {
+ tk::ScaleIncrement %W up big noRepeat
+}
+bind Scale <<NextPara>> {
+ tk::ScaleIncrement %W down big noRepeat
+}
+bind Scale <<PrevWord>> {
+ tk::ScaleIncrement %W up big noRepeat
+}
+bind Scale <<NextWord>> {
+ tk::ScaleIncrement %W down big noRepeat
+}
+bind Scale <<LineStart>> {
+ %W set [%W cget -from]
+}
+bind Scale <<LineEnd>> {
+ %W set [%W cget -to]
+}
+
+# ::tk::ScaleActivate --
+# 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 ::tk::ScaleActivate {w x y} {
+ if {[$w cget -state] eq "disabled"} {
+ return
+ }
+ if {[$w identify $x $y] eq "slider"} {
+ set state active
+ } else {
+ set state normal
+ }
+ if {[$w cget -state] ne $state} {
+ $w configure -state $state
+ }
+}
+
+# ::tk::ScaleButtonDown --
+# 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 ::tk::ScaleButtonDown {w x y} {
+ variable ::tk::Priv
+ set Priv(dragging) 0
+ set el [$w identify $x $y]
+
+ # save the relief
+ set Priv($w,relief) [$w cget -sliderrelief]
+
+ if {$el eq "trough1"} {
+ ScaleIncrement $w up little initial
+ } elseif {$el eq "trough2"} {
+ ScaleIncrement $w down little initial
+ } elseif {$el eq "slider"} {
+ set Priv(dragging) 1
+ set Priv(initValue) [$w get]
+ set coords [$w coords]
+ set Priv(deltaX) [expr {$x - [lindex $coords 0]}]
+ set Priv(deltaY) [expr {$y - [lindex $coords 1]}]
+ switch -exact -- $Priv($w,relief) {
+ "raised" { $w configure -sliderrelief sunken }
+ "ridge" { $w configure -sliderrelief groove }
+ }
+ }
+}
+
+# ::tk::ScaleDrag --
+# 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 ::tk::ScaleDrag {w x y} {
+ variable ::tk::Priv
+ if {!$Priv(dragging)} {
+ return
+ }
+ $w set [$w get [expr {$x-$Priv(deltaX)}] [expr {$y-$Priv(deltaY)}]]
+}
+
+# ::tk::ScaleEndDrag --
+# 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 ::tk::ScaleEndDrag {w} {
+ variable ::tk::Priv
+ set Priv(dragging) 0
+ if {[info exists Priv($w,relief)]} {
+ $w configure -sliderrelief $Priv($w,relief)
+ unset Priv($w,relief)
+ }
+}
+
+# ::tk::ScaleIncrement --
+# 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 ::tk::ScaleIncrement {w dir big repeat} {
+ variable ::tk::Priv
+
+ if {![winfo exists $w]} return
+
+ # give the cancel callback a chance to be serviced if the execution time of
+ # the -command script lasts longer than -repeatdelay
+ set clockms [clock milliseconds]
+ if {$repeat eq "again" &&
+ [expr {$clockms - $Priv(clockms)}] > [expr {[$w cget -repeatinterval] * 1.1}]} {
+ set Priv(clockms) $clockms
+ set Priv(afterId) [after [$w cget -repeatinterval] \
+ [list tk::ScaleIncrement $w $dir $big again]]
+ return
+ }
+
+ if {$big eq "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 eq "up")} {
+ if {$inc > 0} {
+ set inc [expr {-$inc}]
+ }
+ } else {
+ if {$inc < 0} {
+ set inc [expr {-$inc}]
+ }
+ }
+ # this will run the -command script (if any) during the redrawing
+ # of the scale at idle time
+ $w set [expr {[$w get] + $inc}]
+
+ if {$repeat eq "again"} {
+ set Priv(clockms) $clockms
+ set Priv(afterId) [after [$w cget -repeatinterval] \
+ [list tk::ScaleIncrement $w $dir $big again]]
+ } elseif {$repeat eq "initial"} {
+ set delay [$w cget -repeatdelay]
+ if {$delay > 0} {
+ set Priv(clockms) $clockms
+ set Priv(afterId) [after $delay \
+ [list tk::ScaleIncrement $w $dir $big again]]
+ }
+ }
+}
+
+# ::tk::ScaleControlPress --
+# 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 ::tk::ScaleControlPress {w x y} {
+ set el [$w identify $x $y]
+ if {$el eq "trough1"} {
+ $w set [$w cget -from]
+ } elseif {$el eq "trough2"} {
+ $w set [$w cget -to]
+ }
+}
+
+# ::tk::ScaleButton2Down
+# 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 ::tk::ScaleButton2Down {w x y} {
+ variable ::tk::Priv
+
+ if {[$w cget -state] eq "disabled"} {
+ return
+ }
+
+ $w configure -state active
+ $w set [$w get $x $y]
+ set Priv(dragging) 1
+ set Priv(initValue) [$w get]
+ set Priv($w,relief) [$w cget -sliderrelief]
+ set coords "$x $y"
+ set Priv(deltaX) 0
+ set Priv(deltaY) 0
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/scale.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/scaling.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/scaling.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/scaling.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,232 @@
+# scaling.tcl --
+#
+# Contains scaling-related utility procedures.
+#
+# Copyright © 2022 Csaba Nemethi <csaba.nemethi at t-online.de>
+
+# ::tk::ScalingPct --
+#
+# Returns the display's "scaling percentage" (the display resolution expressed
+# as a percentage of 96dpi), rounded to the nearest multiple of 25 that is at
+# least 100.
+#
+# On X11 systems (but not on SDL systems that claim to be X11), the first call
+# of the command also sets [tk scaling] and ::tk::fontScalingFactor to values
+# extracted from the X11 configuration.
+#
+# The command is called during Tk initialization, from icons.tcl, when the
+# latter is sourced by tk.tcl.
+
+proc ::tk::ScalingPct {} {
+ set pct [expr {[tk scaling] * 75}]
+
+ variable doneScalingInitX11
+ if {![info exists doneScalingInitX11]} {
+ set pct [::tk::ScalingInitX11 $pct]
+ set doneScalingInitX11 1
+ }
+
+ #
+ # Save the value of pct rounded to the nearest multiple
+ # of 25 that is at least 100, in the variable scalingPct.
+ # See "man n tk_scalingPct" for use of ::tk::scalingPct.
+ #
+ variable scalingPct
+ for {set scalingPct 100} {1} {incr scalingPct 25} {
+ if {$pct < $scalingPct + 12.5} {
+ break
+ }
+ }
+
+ return $scalingPct
+}
+
+proc ::tk::ScalingInitX11 {pct} {
+ set onX11 [expr {[tk windowingsystem] eq "x11"}]
+ set usingSDL [expr {[info exists ::tk::sdltk] && $::tk::sdltk}]
+
+ if {$onX11 && !$usingSDL} {
+ set origPct $pct
+
+ #
+ # Try to get the window scaling factor (1 or 2), partly
+ # based on https://wiki.archlinux.org/title/HiDPI
+ #
+ set winScalingFactor 1
+ variable fontScalingFactor 1 ;# needed in the file ttk/fonts
+ if {[catch {exec ps -e | grep xfce4-session}] == 0} { ;# Xfce
+ if {[catch {exec xfconf-query -c xsettings \
+ -p /Gdk/WindowScalingFactor} result] == 0} {
+ set winScalingFactor $result
+ if {$winScalingFactor >= 2} {
+ set fontScalingFactor 2
+ }
+ }
+
+ #
+ # The DPI value can be set in the "Fonts" tab of the "Appearance"
+ # dialog or (on Linux Lite 5+) via the "HiDPI Settings" dialog.
+ #
+ } elseif {[catch {exec ps -e | grep mate-session}] == 0} { ;# MATE
+ if {[catch {exec gsettings get org.mate.interface \
+ window-scaling-factor} result] == 0} {
+ if {$result == 0} { ;# means: "Auto-detect"
+ #
+ # Try to get winScalingFactor from the cursor size
+ #
+ if {[catch {exec xrdb -query | grep Xcursor.size} result]
+ == 0 &&
+ [catch {exec gsettings get org.mate.peripherals-mouse \
+ cursor-size} defCursorSize] == 0} {
+ set cursorSize [lindex $result 1]
+ set winScalingFactor \
+ [expr {($cursorSize + $defCursorSize - 1) /
+ $defCursorSize}]
+ }
+ } else {
+ set winScalingFactor $result
+ }
+ }
+
+ #
+ # The DPI value can be set via the "Font Rendering Details"
+ # dialog, which can be opened using the "Details..." button
+ # in the "Fonts" tab of the "Appearance Preferences" dialog.
+ #
+ } elseif {[catch {exec ps -e | grep gnome-session}] == 0 &&
+ [catch {exec gsettings get \
+ org.gnome.settings-daemon.plugins.xsettings overrides} \
+ result] == 0 &&
+ [set idx \
+ [string first "'Gdk/WindowScalingFactor'" $result]] >= 0} {
+ scan [string range $result $idx end] "%*s <%d>" winScalingFactor
+ }
+
+ #
+ # Get the scaling percentage
+ #
+ if {$winScalingFactor >= 2} {
+ set pct 200
+ } elseif {[catch {exec xrdb -query | grep Xft.dpi} result] == 0} {
+ #
+ # Derive the value of pct from that of the font DPI
+ #
+ set dpi [lindex $result 1]
+ set pct [expr {100.0 * $dpi / 96}]
+ } elseif {[catch {exec ps -e | grep gnome-session}] == 0 &&
+ ![info exists ::env(WAYLAND_DISPLAY)] &&
+ [catch {exec xrandr | grep " connected"} result] == 0 &&
+ [catch {open $::env(HOME)/.config/monitors.xml} chan] == 0} {
+ #
+ # Update pct by scanning the file ~/.config/monitors.xml
+ #
+ ScanMonitorsFile $result $chan pct
+ }
+
+ if {($pct != 100) && ($pct != $origPct) && (![interp issafe])} {
+ #
+ # Set Tk's scaling factor according to $pct
+ #
+ tk scaling [expr {$pct / 75.0}]
+ }
+ }
+ return $pct
+}
+
+# ::tk::ScaleNum --
+#
+# Scales an integer according to the display's current scaling percentage.
+#
+# Arguments:
+# num - An integer.
+
+proc ::tk::ScaleNum num {
+ return [expr {round($num * [tk scaling] * 0.75)}]
+}
+
+# ::tk::FontScalingFactor --
+#
+# Accessor command for variable ::tk::fontScalingFactor.
+
+proc ::tk::FontScalingFactor {} {
+ variable fontScalingFactor
+ if {[info exists fontScalingFactor]} {
+ return $fontScalingFactor
+ } else {
+ return 1
+ }
+}
+
+# ::tk::ScanMonitorsFile --
+#
+# Updates the scaling percentage by scanning the file ~/.config/monitors.xml.
+#
+# Arguments:
+# xrandrResult - The output of 'xrandr | grep " connected"'.
+# chan - Returned from 'open ~/.config/monitors.xml'.
+# pctName - The name of a variable containing the scaling percentage.
+
+proc ::tk::ScanMonitorsFile {xrandrResult chan pctName} {
+ upvar $pctName pct
+
+ #
+ # Get the list of connected outputs reported by xrandr
+ #
+ set outputList {}
+ foreach line [split $xrandrResult "\n"] {
+ set idx [string first " " $line]
+ set output [string range $line 0 [incr idx -1]]
+ lappend outputList $output
+ }
+ set outputList [lsort $outputList]
+
+ #
+ # Get the content of the file ~/.config/monitors.xml
+ #
+ set str [read $chan]
+ close $chan
+
+ #
+ # Run over the file's "configuration" sections
+ #
+ set idx 0
+ while {[set idx2 [string first "<configuration>" $str $idx]] >= 0} {
+ set idx2 [string first ">" $str $idx2]
+ set idx [string first "</configuration>" $str $idx2]
+ set config [string range $str [incr idx2] [incr idx -1]]
+
+ #
+ # Get the list of connectors within this configuration
+ #
+ set connectorList {}
+ foreach {dummy connector} [regexp -all -inline \
+ {<connector>([^<]+)</connector>} $config] {
+ lappend connectorList $connector
+ }
+ set connectorList [lsort $connectorList]
+
+ #
+ # If $outputList and $connectorList are identical then set the
+ # variable pct to 100, 200, 300, 400, or 500, depending on the
+ # max. scaling within this configuration, and exit the loop
+ #
+ if {$outputList eq $connectorList} {
+ set maxScaling 1.0
+ foreach {dummy scaling} [regexp -all -inline \
+ {<scale>([^<]+)</scale>} $config] {
+ if {$scaling > $maxScaling} {
+ set maxScaling $scaling
+ }
+ }
+
+ foreach n {4 3 2 1 0} {
+ if {$maxScaling > $n} {
+ set pct [expr {($n + 1) * 100}]
+ break
+ }
+ }
+
+ break
+ }
+ }
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/scaling.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/scrlbar.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/scrlbar.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/scrlbar.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,500 @@
+# scrlbar.tcl --
+#
+# This file defines the default bindings for Tk scrollbar widgets.
+# It also provides procedures that help in implementing the bindings.
+#
+# Copyright © 1994 The Regents of the University of California.
+# Copyright © 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 {[tk windowingsystem] eq "x11" || [tk windowingsystem] eq "aqua"} {
+
+bind Scrollbar <Enter> {
+ if {$tk_strictMotif} {
+ set tk::Priv(activeBg) [%W cget -activebackground]
+ %W configure -activebackground [%W cget -background]
+ }
+ %W activate [%W identify %x %y]
+}
+bind Scrollbar <Motion> {
+ %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 <Leave> {
+ if {$tk_strictMotif && [info exists tk::Priv(activeBg)]} {
+ %W configure -activebackground $tk::Priv(activeBg)
+ }
+ %W activate {}
+}
+bind Scrollbar <Button-1> {
+ tk::ScrollButtonDown %W %x %y
+}
+bind Scrollbar <B1-Motion> {
+ tk::ScrollDrag %W %x %y
+}
+bind Scrollbar <B1-B2-Motion> {
+ tk::ScrollDrag %W %x %y
+}
+bind Scrollbar <ButtonRelease-1> {
+ tk::ScrollButtonUp %W %x %y
+}
+bind Scrollbar <B1-Leave> {
+ # Prevents <Leave> binding from being invoked.
+}
+bind Scrollbar <B1-Enter> {
+ # Prevents <Enter> binding from being invoked.
+}
+bind Scrollbar <Button-2> {
+ tk::ScrollButton2Down %W %x %y
+}
+bind Scrollbar <B1-Button-2> {
+ # Do nothing, since button 1 is already down.
+}
+bind Scrollbar <B2-Button-1> {
+ # Do nothing, since button 2 is already down.
+}
+bind Scrollbar <B2-Motion> {
+ tk::ScrollDrag %W %x %y
+}
+bind Scrollbar <ButtonRelease-2> {
+ tk::ScrollButtonUp %W %x %y
+}
+bind Scrollbar <B1-ButtonRelease-2> {
+ # Do nothing: B1 release will handle it.
+}
+bind Scrollbar <B2-ButtonRelease-1> {
+ # Do nothing: B2 release will handle it.
+}
+bind Scrollbar <B2-Leave> {
+ # Prevents <Leave> binding from being invoked.
+}
+bind Scrollbar <B2-Enter> {
+ # Prevents <Enter> binding from being invoked.
+}
+bind Scrollbar <Control-Button-1> {
+ tk::ScrollTopBottom %W %x %y
+}
+bind Scrollbar <Control-Button-2> {
+ tk::ScrollTopBottom %W %x %y
+}
+
+bind Scrollbar <<PrevLine>> {
+ tk::ScrollByUnits %W v -1
+}
+bind Scrollbar <<NextLine>> {
+ tk::ScrollByUnits %W v 1
+}
+bind Scrollbar <<PrevPara>> {
+ tk::ScrollByPages %W v -1
+}
+bind Scrollbar <<NextPara>> {
+ tk::ScrollByPages %W v 1
+}
+bind Scrollbar <<PrevChar>> {
+ tk::ScrollByUnits %W h -1
+}
+bind Scrollbar <<NextChar>> {
+ tk::ScrollByUnits %W h 1
+}
+bind Scrollbar <<PrevWord>> {
+ tk::ScrollByPages %W h -1
+}
+bind Scrollbar <<NextWord>> {
+ tk::ScrollByPages %W h 1
+}
+bind Scrollbar <Prior> {
+ tk::ScrollByPages %W hv -1
+}
+bind Scrollbar <Next> {
+ tk::ScrollByPages %W hv 1
+}
+bind Scrollbar <<LineStart>> {
+ tk::ScrollToPos %W 0
+}
+bind Scrollbar <<LineEnd>> {
+ tk::ScrollToPos %W 1
+}
+}
+
+bind Scrollbar <Enter> {+
+ set tk::Priv(xEvents) 0; set tk::Priv(yEvents) 0
+}
+bind Scrollbar <MouseWheel> {
+ tk::ScrollByUnits %W vh %D -40.0
+}
+bind Scrollbar <Option-MouseWheel> {
+ tk::ScrollByUnits %W vh %D -12.0
+}
+bind Scrollbar <Shift-MouseWheel> {
+ tk::ScrollByUnits %W hv %D -40.0
+}
+bind Scrollbar <Shift-Option-MouseWheel> {
+ tk::ScrollByUnits %W hv %D -12.0
+}
+bind Scrollbar <TouchpadScroll> {
+ lassign [tk::PreciseScrollDeltas %D] tk::Priv(deltaX) tk::Priv(deltaY)
+ if {$tk::Priv(deltaX) != 0 && [%W cget -orient] eq "horizontal"} {
+ tk::ScrollbarScrollByPixels %W h $tk::Priv(deltaX)
+ }
+ if {$tk::Priv(deltaY) != 0 && [%W cget -orient] eq "vertical"} {
+ tk::ScrollbarScrollByPixels %W v $tk::Priv(deltaY)
+ }
+}
+
+# tk::ScrollButtonDown --
+# 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 tk::ScrollButtonDown {w x y} {
+ variable ::tk::Priv
+ set Priv(relief) [$w cget -activerelief]
+ $w configure -activerelief sunken
+ set element [$w identify $x $y]
+ if {$element eq "slider"} {
+ ScrollStartDrag $w $x $y
+ } else {
+ ScrollSelect $w $element initial
+ }
+}
+
+# ::tk::ScrollButtonUp --
+# 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 ::tk::ScrollButtonUp {w x y} {
+ variable ::tk::Priv
+ tk::CancelRepeat
+ if {[info exists Priv(relief)]} {
+ # Avoid error due to spurious release events
+ $w configure -activerelief $Priv(relief)
+ ScrollEndDrag $w $x $y
+ $w activate [$w identify $x $y]
+ }
+}
+
+# ::tk::ScrollSelect --
+# 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 ::tk::ScrollSelect {w element repeat} {
+ variable ::tk::Priv
+ if {![winfo exists $w]} return
+ switch -- $element {
+ "arrow1" {ScrollByUnits $w hv -1}
+ "trough1" {ScrollByPages $w hv -1}
+ "trough2" {ScrollByPages $w hv 1}
+ "arrow2" {ScrollByUnits $w hv 1}
+ default {return}
+ }
+ if {$repeat eq "again"} {
+ set Priv(afterId) [after [$w cget -repeatinterval] \
+ [list tk::ScrollSelect $w $element again]]
+ } elseif {$repeat eq "initial"} {
+ set delay [$w cget -repeatdelay]
+ if {$delay > 0} {
+ set Priv(afterId) [after $delay \
+ [list tk::ScrollSelect $w $element again]]
+ }
+ }
+}
+
+# ::tk::ScrollStartDrag --
+# 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 ::tk::ScrollStartDrag {w x y} {
+ variable ::tk::Priv
+
+ if {[$w cget -command] eq ""} {
+ return
+ }
+ set Priv(pressX) $x
+ set Priv(pressY) $y
+ set Priv(initValues) [$w get]
+ set iv0 [lindex $Priv(initValues) 0]
+ if {[llength $Priv(initValues)] == 2} {
+ set Priv(initPos) $iv0
+ } elseif {$iv0 == 0} {
+ set Priv(initPos) 0.0
+ } else {
+ set Priv(initPos) [expr {(double([lindex $Priv(initValues) 2])) \
+ / [lindex $Priv(initValues) 0]}]
+ }
+}
+
+# ::tk::ScrollDrag --
+# 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 ::tk::ScrollDrag {w x y} {
+ variable ::tk::Priv
+
+ if {$Priv(initPos) eq ""} {
+ return
+ }
+ set delta [$w delta [expr {$x - $Priv(pressX)}] [expr {$y - $Priv(pressY)}]]
+ if {[$w cget -jump]} {
+ if {[llength $Priv(initValues)] == 2} {
+ $w set [expr {[lindex $Priv(initValues) 0] + $delta}] \
+ [expr {[lindex $Priv(initValues) 1] + $delta}]
+ } else {
+ set delta [expr {round($delta * [lindex $Priv(initValues) 0])}]
+ eval [list $w] set [lreplace $Priv(initValues) 2 3 \
+ [expr {[lindex $Priv(initValues) 2] + $delta}] \
+ [expr {[lindex $Priv(initValues) 3] + $delta}]]
+ }
+ } else {
+ ScrollToPos $w [expr {$Priv(initPos) + $delta}]
+ }
+}
+
+# ::tk::ScrollEndDrag --
+# 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 ::tk::ScrollEndDrag {w x y} {
+ variable ::tk::Priv
+
+ if {$Priv(initPos) eq ""} {
+ return
+ }
+ if {[$w cget -jump]} {
+ set delta [$w delta [expr {$x - $Priv(pressX)}] \
+ [expr {$y - $Priv(pressY)}]]
+ ScrollToPos $w [expr {$Priv(initPos) + $delta}]
+ }
+ set Priv(initPos) ""
+}
+
+# ::tk::ScrollbarScrollByPixels --
+# This procedure tells the scrollbar's associated widget to scroll up
+# or down by a given number of pixels. It only works with scrollbars
+# because it uses the delta command.
+#
+# Arguments:
+# w - The scrollbar widget.
+# orient - Which kind of scrollbar this applies to: "h" for
+# horizontal, "v" for vertical.
+# amount - How many pixels to scroll.
+
+proc ::tk::ScrollbarScrollByPixels {w orient amount} {
+ set cmd [$w cget -command]
+ if {$cmd eq ""} {
+ return
+ }
+ set xyview [lindex [split $cmd] end]
+ if {$orient eq "v"} {
+ if {$xyview eq "xview"} {
+ return
+ }
+ }
+ if {$orient eq "h"} {
+ if {$xyview eq "yview"} {
+ return
+ }
+ }
+
+ # The code below works with both the current and old syntax for
+ # the scrollbar get command.
+
+ set info [$w get]
+ if {[llength $info] == 2} {
+ set first [lindex $info 0]
+ } else {
+ set first [lindex $info 2]
+ }
+ set pixels [expr {-$amount}]
+ uplevel #0 $cmd moveto [expr $first + [$w delta $pixels $pixels]]
+}
+
+# ::tk::ScrollByUnits --
+# 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" or "vh" for both.
+# amount - How many units to scroll: typically 1 or -1.
+
+proc ::tk::ScrollByUnits {w orient amount {factor 1.0}} {
+ set cmd [$w cget -command]
+ if {$cmd eq "" || ([string first \
+ [string index [$w cget -orient] 0] $orient] < 0)} {
+ return
+ }
+
+ if {[string length $orient] == 2 && $factor != 1.0} {
+ # Count both the <MouseWheel> and <Shift-MouseWheel>
+ # events, and ignore the non-dominant ones
+
+ variable ::tk::Priv
+ set axis [expr {[string index $orient 0] eq "h" ? "x" : "y"}]
+ incr Priv(${axis}Events)
+ if {($Priv(xEvents) + $Priv(yEvents) > 10) &&
+ ($axis eq "x" && $Priv(xEvents) < $Priv(yEvents) ||
+ $axis eq "y" && $Priv(yEvents) < $Priv(xEvents))} {
+ return
+ }
+ }
+
+ set info [$w get]
+ if {[llength $info] == 2} {
+ uplevel #0 $cmd scroll [expr {$amount/$factor}] units
+ } else {
+ uplevel #0 $cmd [expr {[lindex $info 2] + [expr {$amount/$factor}]}]
+ }
+}
+
+# ::tk::ScrollByPages --
+# 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 ::tk::ScrollByPages {w orient amount} {
+ set cmd [$w cget -command]
+ if {$cmd eq "" || ([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)}]
+ }
+}
+
+# ::tk::ScrollToPos --
+# 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 ::tk::ScrollToPos {w pos} {
+ set cmd [$w cget -command]
+ if {$cmd eq ""} {
+ return
+ }
+ set info [$w get]
+ if {[llength $info] == 2} {
+ uplevel #0 $cmd moveto $pos
+ } else {
+ uplevel #0 $cmd [expr {round([lindex $info 0]*$pos)}]
+ }
+}
+
+# ::tk::ScrollTopBottom
+# 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 ::tk::ScrollTopBottom {w x y} {
+ variable ::tk::Priv
+ set element [$w identify $x $y]
+ if {[string match *1 $element]} {
+ ScrollToPos $w 0
+ } elseif {[string match *2 $element]} {
+ ScrollToPos $w 1
+ }
+
+ # Set Priv(relief), since it's needed by tk::ScrollButtonUp.
+
+ set Priv(relief) [$w cget -activerelief]
+}
+
+# ::tk::ScrollButton2Down
+# 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 ::tk::ScrollButton2Down {w x y} {
+ variable ::tk::Priv
+ if {![winfo exists $w]} {
+ return
+ }
+ set element [$w identify $x $y]
+ if {[string match {arrow[12]} $element]} {
+ ScrollButtonDown $w $x $y
+ return
+ }
+ ScrollToPos $w [$w fraction $x $y]
+ set Priv(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
+ if {[winfo exists $w]} {
+ $w configure -activerelief sunken
+ $w activate slider
+ ScrollStartDrag $w $x $y
+ }
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk9.0/scrlbar.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tk9.0/spinbox.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk9.0/spinbox.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk9.0/spinbox.tcl 2025-02-24 13:59:26 UTC (rev 74255)
@@ -0,0 +1,580 @@
+# spinbox.tcl --
+#
+# This file defines the default bindings for Tk spinbox widgets and provides
+# procedures that help in implementing those bindings. The spinbox builds
+# off the entry widget, so it can reuse Entry bindings and procedures.
+#
+# Copyright © 1992-1994 The Regents of the University of California.
+# Copyright © 1994-1997 Sun Microsystems, Inc.
+# Copyright © 1999-2000 Jeffrey Hobbs
+# Copyright © 2000 Ajuba Solutions
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+
+#-------------------------------------------------------------------------
+# Elements of tk::Priv 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.
+# data - Used for Cut and Copy
+#-------------------------------------------------------------------------
+
+# Initialize namespace
+namespace eval ::tk::spinbox {}
+
+#-------------------------------------------------------------------------
+# The code below creates the default class bindings for entries.
+#-------------------------------------------------------------------------
+bind Spinbox <<Cut>> {
+ if {![catch {::tk::spinbox::GetSelection %W} tk::Priv(data)]} {
+ clipboard clear -displayof %W
+ clipboard append -displayof %W $tk::Priv(data)
+ %W delete sel.first sel.last
+ unset tk::Priv(data)
+ }
+}
+bind Spinbox <<Copy>> {
+ if {![catch {::tk::spinbox::GetSelection %W} tk::Priv(data)]} {
+ clipboard clear -displayof %W
+ clipboard append -displayof %W $tk::Priv(data)
+ unset tk::Priv(data)
+ }
+}
+bind Spinbox <<Paste>> {
+ catch {
+ if {[tk windowingsystem] ne "x11"} {
+ catch {
+ %W delete sel.first sel.last
+ }
+ }
+ %W insert insert [::tk::GetSelection %W CLIPBOARD]
+ ::tk::EntrySeeInsert %W
+ }
+}
+bind Spinbox <<Clear>> {
+ %W delete sel.first sel.last
+}
+bind Spinbox <<PasteSelection>> {
+ if {$tk_strictMotif || ![info exists tk::Priv(mouseMoved)]
+ || !$tk::Priv(mouseMoved)} {
+ ::tk::spinbox::Paste %W %x
+ }
+}
+
+bind Spinbox <<TraverseIn>> {
+ %W selection range 0 end
+ %W icursor end
+}
+
+# Standard Motif bindings:
+
+bind Spinbox <Button-1> {
+ ::tk::spinbox::ButtonDown %W %x %y
+}
+bind Spinbox <B1-Motion> {
+ ::tk::spinbox::Motion %W %x %y
+}
+bind Spinbox <Double-Button-1> {
+ ::tk::spinbox::ArrowPress %W %x %y
+ set tk::Priv(selectMode) word
+ ::tk::spinbox::MouseSelect %W %x sel.first
+}
+bind Spinbox <Triple-Button-1> {
+ ::tk::spinbox::ArrowPress %W %x %y
+ set tk::Priv(selectMode) line
+ ::tk::spinbox::MouseSelect %W %x 0
+}
+bind Spinbox <Shift-Button-1> {
+ set tk::Priv(selectMode) char
+ %W selection adjust @%x
+}
+bind Spinbox <Double-Shift-Button-1> {
+ set tk::Priv(selectMode) word
+ ::tk::spinbox::MouseSelect %W %x
+}
+bind Spinbox <Triple-Shift-Button-1> {
+ set tk::Priv(selectMode) line
+ ::tk::spinbox::MouseSelect %W %x
+}
+bind Spinbox <B1-Leave> {
+ set tk::Priv(x) %x
+ ::tk::spinbox::AutoScan %W
+}
+bind Spinbox <B1-Enter> {
+ tk::CancelRepeat
+}
+bind Spinbox <ButtonRelease-1> {
+ ::tk::spinbox::ButtonUp %W %x %y
+}
+bind Spinbox <Control-Button-1> {
+ %W icursor @%x
+}
+
+bind Spinbox <<PrevLine>> {
+ %W invoke buttonup
+}
+bind Spinbox <<NextLine>> {
+ %W invoke buttondown
+}
+
+bind Spinbox <<PrevChar>> {
+ ::tk::EntrySetCursor %W [tk::EntryPreviousChar %W insert]
+}
+bind Spinbox <<NextChar>> {
+ ::tk::EntrySetCursor %W [tk::EntryNextChar %W insert]
+}
+bind Spinbox <<SelectPrevChar>> {
+ ::tk::EntryKeySelect %W [tk::EntryPreviousChar %W insert]
+ ::tk::EntrySeeInsert %W
+}
+bind Spinbox <<SelectNextChar>> {
+ ::tk::EntryKeySelect %W [tk::EntryNextChar %W insert]
+ ::tk::EntrySeeInsert %W
+}
+bind Spinbox <<PrevWord>> {
+ ::tk::EntrySetCursor %W [::tk::EntryPreviousWord %W insert]
+}
+bind Spinbox <<NextWord>> {
+ ::tk::EntrySetCursor %W [::tk::EntryNextWord %W insert]
+}
+bind Spinbox <<SelectPrevWord>> {
+ ::tk::EntryKeySelect %W [::tk::EntryPreviousWord %W insert]
+ ::tk::EntrySeeInsert %W
+}
+bind Spinbox <<SelectNextWord>> {
+ ::tk::EntryKeySelect %W [::tk::EntrySelectNextWord %W insert]
+ ::tk::EntrySeeInsert %W
+}
+bind Spinbox <<LineStart>> {
+ ::tk::EntrySetCursor %W 0
+}
+bind Spinbox <<SelectLineStart>> {
+ ::tk::EntryKeySelect %W 0
+ ::tk::EntrySeeInsert %W
+}
+bind Spinbox <<LineEnd>> {
+ ::tk::EntrySetCursor %W end
+}
+bind Spinbox <<SelectLineEnd>> {
+ ::tk::EntryKeySelect %W end
+ ::tk::EntrySeeInsert %W
+}
+
+bind Spinbox <Delete> {
+ if {[%W selection present]} {
+ %W delete sel.first sel.last
+ } else {
+ %W delete [tk::startOfCluster [%W get] [%W index insert]] \
+ [tk::endOfCluster [%W get] [%W index insert]]
+ }
+}
+bind Spinbox <BackSpace> {
+ ::tk::EntryBackspace %W
+}
+
+bind Spinbox <Control-space> {
+ %W selection from insert
+}
+bind Spinbox <Select> {
+ %W selection from insert
+}
+bind Spinbox <Control-Shift-space> {
+ %W selection adjust insert
+}
+bind Spinbox <Shift-Select> {
+ %W selection adjust insert
+}
+bind Spinbox <<SelectAll>> {
+ %W selection range 0 end
+}
+bind Spinbox <<SelectNone>> {
+ %W selection clear
+}
+bind Spinbox <Key> {
+ ::tk::EntryInsert %W %A
+}
+
+# Ignore all Alt, Meta, Control, Command, and Fn keypresses unless explicitly bound.
+# Otherwise, if a widget binding for one of these is defined, the
+# <Key> class binding will also fire and insert the character,
+# which is wrong. Ditto for Escape, Return, and Tab.
+
+bind Spinbox <Alt-Key> {# nothing}
+bind Spinbox <Meta-Key> {# nothing}
+bind Spinbox <Control-Key> {# nothing}
+bind Spinbox <Escape> {# nothing}
+bind Spinbox <Return> {# nothing}
+bind Spinbox <KP_Enter> {# nothing}
+bind Spinbox <Tab> {# nothing}
+bind Spinbox <Prior> {# nothing}
+bind Spinbox <Next> {# nothing}
+bind Spinbox <Command-Key> {# nothing}
+bind Spinbox <Fn-Key> {# nothing}
+
+# On Windows, paste is done using Shift-Insert. Shift-Insert already
+# generates the <<Paste>> event, so we don't need to do anything here.
+if {[tk windowingsystem] ne "win32"} {
+ bind Spinbox <Insert> {
+ catch {::tk::EntryInsert %W [::tk::GetSelection %W PRIMARY]}
+ }
+}
+
+# Additional emacs-like bindings:
+
+bind Spinbox <Control-d> {
+ if {!$tk_strictMotif} {
+ %W delete insert
+ }
+}
+bind Spinbox <Control-h> {
+ if {!$tk_strictMotif} {
+ ::tk::EntryBackspace %W
+ }
+}
+bind Spinbox <Control-k> {
+ if {!$tk_strictMotif} {
+ %W delete insert end
+ }
+}
+bind Spinbox <Control-t> {
+ if {!$tk_strictMotif} {
+ ::tk::EntryTranspose %W
+ }
+}
+bind Spinbox <Meta-b> {
+ if {!$tk_strictMotif} {
+ ::tk::EntrySetCursor %W [::tk::EntryPreviousWord %W insert]
+ }
+}
+bind Spinbox <Meta-d> {
+ if {!$tk_strictMotif} {
+ %W delete insert [::tk::EntryNextWord %W insert]
+ }
+}
+bind Spinbox <Meta-f> {
+ if {!$tk_strictMotif} {
+ ::tk::EntrySetCursor %W [::tk::EntryNextWord %W insert]
+ }
+}
+bind Spinbox <Meta-BackSpace> {
+ if {!$tk_strictMotif} {
+ %W delete [::tk::EntryPreviousWord %W insert] insert
+ }
+}
+bind Spinbox <Meta-Delete> {
+ if {!$tk_strictMotif} {
+ %W delete [::tk::EntryPreviousWord %W insert] insert
+ }
+}
+
+# A few additional bindings of my own.
+
+bind Spinbox <Button-2> {
+ if {!$tk_strictMotif} {
+ ::tk::EntryScanMark %W %x
+ }
+}
+bind Spinbox <B2-Motion> {
+ if {!$tk_strictMotif} {
+ ::tk::EntryScanDrag %W %x
+ }
+}
+
+# ::tk::spinbox::Invoke --
+# Invoke an element of the spinbox
+#
+# Arguments:
+# w - The spinbox window.
+# elem - Element to invoke
+
+proc ::tk::spinbox::Invoke {w elem} {
+ variable ::tk::Priv
+
+ if {![winfo exists $w]} {
+ return
+ }
+
+ if {![info exists Priv(outsideElement)]} {
+ $w invoke $elem
+ incr Priv(repeated)
+ }
+ set delay [$w cget -repeatinterval]
+ if {$delay > 0} {
+ set Priv(afterId) [after $delay \
+ [list ::tk::spinbox::Invoke $w $elem]]
+ }
+}
+
+# ::tk::spinbox::ClosestGap --
+# Given x and y coordinates, this procedure finds the closest boundary
+# between characters to the given coordinates and returns the index
+# of the character just after the boundary.
+#
+# Arguments:
+# w - The spinbox window.
+# x - X-coordinate within the window.
+
+proc ::tk::spinbox::ClosestGap {w x} {
+ set pos [$w index @$x]
+ set bbox [$w bbox $pos]
+ if {($x - [lindex $bbox 0]) < ([lindex $bbox 2]/2)} {
+ return $pos
+ }
+ incr pos
+}
+
+# ::tk::spinbox::ArrowPress --
+# This procedure is invoked to handle button-1 presses in buttonup
+# or buttondown elements of spinbox widgets.
+#
+# Arguments:
+# w - The spinbox window in which the button was pressed.
+# x - The x-coordinate of the button press.
+# y - The y-coordinate of the button press.
+
+proc ::tk::spinbox::ArrowPress {w x y} {
+ variable ::tk::Priv
+
+ if {[$w cget -state] ne "disabled" && \
+ [string match "button*" $Priv(element)]} {
+ $w selection element $Priv(element)
+ set Priv(repeated) 0
+ set Priv(relief) [$w cget -$Priv(element)relief]
+ catch {after cancel $Priv(afterId)}
+ set delay [$w cget -repeatdelay]
+ if {$delay > 0} {
+ set Priv(afterId) [after $delay \
+ [list ::tk::spinbox::Invoke $w $Priv(element)]]
+ }
+ if {[info exists Priv(outsideElement)]} {
+ unset Priv(outsideElement)
+ }
+ }
+}
+
+# ::tk::spinbox::ButtonDown --
+# This procedure is invoked to handle button-1 presses in spinbox
+# widgets. It moves the insertion cursor, sets the selection anchor,
+# and claims the input focus.
+#
+# Arguments:
+# w - The spinbox window in which the button was pressed.
+# x - The x-coordinate of the button press.
+# y - The y-coordinate of the button press.
+
+proc ::tk::spinbox::ButtonDown {w x y} {
+ variable ::tk::Priv
+
+ # Get the element that was clicked in. If we are not directly over
+ # the spinbox, default to entry. This is necessary for spinbox grabs.
+ #
+ set Priv(element) [$w identify $x $y]
+ if {$Priv(element) eq ""} {
+ set Priv(element) "entry"
+ }
+
+ switch -exact $Priv(element) {
+ "buttonup" - "buttondown" {
+ ::tk::spinbox::ArrowPress $w $x $y
+ }
+ "entry" {
+ set Priv(selectMode) char
+ set Priv(mouseMoved) 0
+ set Priv(pressX) $x
+ $w icursor [::tk::spinbox::ClosestGap $w $x]
+ $w selection from insert
+ if {"disabled" ne [$w cget -state]} {focus $w}
+ $w selection clear
+ }
+ default {
+ return -code error -errorcode {TK SPINBOX UNKNOWN_ELEMENT} \
+ "unknown spinbox element \"$Priv(element)\""
+ }
+ }
+}
+
+# ::tk::spinbox::ButtonUp --
+# This procedure is invoked to handle button-1 releases in spinbox
+# widgets.
+#
+# Arguments:
+# w - The spinbox window in which the button was pressed.
+# x - The x-coordinate of the button press.
+# y - The y-coordinate of the button press.
+
+proc ::tk::spinbox::ButtonUp {w x y} {
+ variable ::tk::Priv
+
+ ::tk::CancelRepeat
+
+ # Priv(relief) may not exist if the ButtonUp is not paired with
+ # a preceding ButtonDown
+ if {[info exists Priv(element)] && [info exists Priv(relief)] && \
+ [string match "button*" $Priv(element)]} {
+ if {[info exists Priv(repeated)] && !$Priv(repeated)} {
+ $w invoke $Priv(element)
+ }
+ $w configure -$Priv(element)relief $Priv(relief)
+ $w selection element none
+ }
+}
+
+# ::tk::spinbox::MouseSelect --
+# This procedure is invoked when dragging out a selection with
+# the mouse. Depending on the selection mode (character, word,
+# line) it selects in different-sized units. This procedure
+# ignores mouse motions initially until the mouse has moved from
+# one character to another or until there have been multiple clicks.
+#
+# Arguments:
+# w - The spinbox window in which the button was pressed.
+# x - The x-coordinate of the mouse.
+# cursor - optional place to set cursor.
+
+proc ::tk::spinbox::MouseSelect {w x {cursor {}}} {
+ variable ::tk::Priv
+
+ if {$Priv(element) ne "entry"} {
+ # The ButtonUp command triggered by ButtonRelease-1 handles
+ # invoking one of the spinbuttons.
+ return
+ }
+ set cur [::tk::spinbox::ClosestGap $w $x]
+ set anchor [$w index anchor]
+ if {($cur ne $anchor) || (abs($Priv(pressX) - $x) >= 3)} {
+ set Priv(mouseMoved) 1
+ }
+ switch $Priv(selectMode) {
+ char {
+ if {$Priv(mouseMoved)} {
+ if {$cur < $anchor} {
+ $w selection range $cur $anchor
+ } elseif {$cur > $anchor} {
+ $w selection range $anchor $cur
+ } else {
+ $w selection clear
+ }
+ }
+ }
+ word {
+ if {$cur < [$w index anchor]} {
+ set before [tk::wordBreakBefore [$w get] $cur]
+ set after [tk::wordBreakAfter [$w get] $anchor-1]
+ } else {
+ set before [tk::wordBreakBefore [$w get] $anchor]
+ set after [tk::wordBreakAfter [$w get] $cur-1]
+ }
+ if {$before < 0} {
+ set before 0
+ }
+ if {$after < 0} {
+ set after end
+ }
+ $w selection range $before $after
+ }
+ line {
+ $w selection range 0 end
+ }
+ }
+ if {$cursor ne {} && $cursor ne "ignore"} {
+ catch {$w icursor $cursor}
+ }
+ update idletasks
+}
+
+# ::tk::spinbox::Paste --
+# This procedure sets the insertion cursor to the current mouse position,
+# pastes the selection there, and sets the focus to the window.
+#
+# Arguments:
+# w - The spinbox window.
+# x - X position of the mouse.
+
+proc ::tk::spinbox::Paste {w x} {
+ $w icursor [::tk::spinbox::ClosestGap $w $x]
+ catch {$w insert insert [::tk::GetSelection $w PRIMARY]}
+ if {"disabled" eq [$w cget -state]} {
+ focus $w
+ }
+}
+
+# ::tk::spinbox::Motion --
+# This procedure is invoked when the mouse moves in a spinbox window
+# with button 1 down.
+#
+# Arguments:
+# w - The spinbox window.
+# x - The x-coordinate of the mouse.
+# y - The y-coordinate of the mouse.
+
+proc ::tk::spinbox::Motion {w x y} {
+ variable ::tk::Priv
+
+ if {![info exists Priv(element)]} {
+ set Priv(element) [$w identify $x $y]
+ }
+
+ set Priv(x) $x
+ if {"entry" eq $Priv(element)} {
+ ::tk::spinbox::MouseSelect $w $x ignore
@@ Diff output truncated at 1234567 characters. @@
More information about the tex-live-commits
mailing list.