From 869bf32db73b6f54154db6eb050de85ef18ea7f3 Mon Sep 17 00:00:00 2001 From: Patrick Monnerat Date: Tue, 17 Feb 2015 17:23:52 +0100 Subject: [PATCH] Unbundle tcl, tk, itcl, itk, iwidgets. --- .gitmodules | 16 - README | 23 +- binutils-gdb | 2 +- configure.ac | 103 +- itcl | 1 - itk | 1 - iwidgets/README | 44 - iwidgets/iwidgets.patch | 108 - iwidgets/library/buttonbox.itk | 571 ---- iwidgets/library/calendar.itk | 991 ------- iwidgets/library/canvasprintbox.itk | 1111 -------- iwidgets/library/canvasprintdialog.itk | 155 -- iwidgets/library/checkbox.itk | 341 --- iwidgets/library/colors.itcl | 209 -- iwidgets/library/combobox.itk | 1446 ---------- iwidgets/library/dateentry.itk | 424 --- iwidgets/library/datefield.itk | 1020 ------- iwidgets/library/dialog.itk | 92 - iwidgets/library/dialogshell.itk | 350 --- iwidgets/library/disjointlistbox.itk | 533 ---- iwidgets/library/entryfield.itk | 610 ---- iwidgets/library/extbutton.itk | 439 --- iwidgets/library/extfileselectionbox.itk | 1187 -------- iwidgets/library/extfileselectiondialog.itk | 182 -- iwidgets/library/feedback.itk | 212 -- iwidgets/library/fileselectionbox.itk | 1296 --------- iwidgets/library/fileselectiondialog.itk | 181 -- iwidgets/library/finddialog.itk | 488 ---- iwidgets/library/hierarchy.itk | 1983 ------------- iwidgets/library/hyperhelp.itk | 508 ---- iwidgets/library/labeledframe.itk | 497 ---- iwidgets/library/labeledwidget.itk | 445 --- iwidgets/library/mainwindow.itk | 313 --- iwidgets/library/menubar.itk | 2267 --------------- iwidgets/library/messagebox.itk | 399 --- iwidgets/library/messagedialog.itk | 144 - iwidgets/library/notebook.itk | 946 ------- iwidgets/library/optionmenu.itk | 664 ----- iwidgets/library/pane.itk | 128 - iwidgets/library/panedwindow.itk | 942 ------- iwidgets/library/pkgIndex.tcl | 66 - iwidgets/library/promptdialog.itk | 199 -- iwidgets/library/pushbutton.itk | 361 --- iwidgets/library/radiobox.itk | 427 --- iwidgets/library/regexpfield.itk | 455 --- iwidgets/library/roman.itcl | 29 - iwidgets/library/scopedobject.itcl | 181 -- iwidgets/library/scrolledcanvas.itk | 477 ---- iwidgets/library/scrolledframe.itk | 250 -- iwidgets/library/scrolledhtml.itk | 2522 ----------------- iwidgets/library/scrolledlistbox.itk | 732 ----- iwidgets/library/scrolledtext.itk | 501 ---- iwidgets/library/scrolledwidget.itk | 376 --- iwidgets/library/selectionbox.itk | 560 ---- iwidgets/library/selectiondialog.itk | 233 -- iwidgets/library/shell.itk | 387 --- iwidgets/library/spindate.itk | 693 ----- iwidgets/library/spinint.itk | 237 -- iwidgets/library/spinner.itk | 448 --- iwidgets/library/spintime.itk | 527 ---- iwidgets/library/tabnotebook.itk | 1105 -------- iwidgets/library/tabset.itk | 2753 ------------------- iwidgets/library/tclIndex | 1372 --------- iwidgets/library/timeentry.itk | 398 --- iwidgets/library/timefield.itk | 1018 ------- iwidgets/library/toolbar.itk | 984 ------- iwidgets/library/unknownimage.gif | Bin 472 -> 0 bytes iwidgets/library/watch.itk | 626 ----- iwidgets/license.terms | 35 - libgui/configure.ac | 29 +- patches/binutils-gdb/001-itcltk4.patch | 242 +- patches/itcl/001-cflags.patch | 18 - patches/itcl/002-ranlib.patch | 17 - patches/itk/001-cflags.patch | 18 - patches/itk/002-ranlib.patch | 17 - patches/itk/003-pathlist.patch | 17 - patches/iwidgets/configure.in | 30 - patches/tcl/configure.in | 19 - patches/tk/configure.in | 19 - tcl | 1 - tk | 1 - 81 files changed, 187 insertions(+), 39565 deletions(-) delete mode 160000 itcl delete mode 160000 itk delete mode 100644 iwidgets/README delete mode 100644 iwidgets/iwidgets.patch delete mode 100644 iwidgets/library/buttonbox.itk delete mode 100644 iwidgets/library/calendar.itk delete mode 100644 iwidgets/library/canvasprintbox.itk delete mode 100644 iwidgets/library/canvasprintdialog.itk delete mode 100644 iwidgets/library/checkbox.itk delete mode 100644 iwidgets/library/colors.itcl delete mode 100644 iwidgets/library/combobox.itk delete mode 100644 iwidgets/library/dateentry.itk delete mode 100644 iwidgets/library/datefield.itk delete mode 100644 iwidgets/library/dialog.itk delete mode 100644 iwidgets/library/dialogshell.itk delete mode 100644 iwidgets/library/disjointlistbox.itk delete mode 100644 iwidgets/library/entryfield.itk delete mode 100644 iwidgets/library/extbutton.itk delete mode 100644 iwidgets/library/extfileselectionbox.itk delete mode 100644 iwidgets/library/extfileselectiondialog.itk delete mode 100644 iwidgets/library/feedback.itk delete mode 100644 iwidgets/library/fileselectionbox.itk delete mode 100644 iwidgets/library/fileselectiondialog.itk delete mode 100644 iwidgets/library/finddialog.itk delete mode 100644 iwidgets/library/hierarchy.itk delete mode 100644 iwidgets/library/hyperhelp.itk delete mode 100644 iwidgets/library/labeledframe.itk delete mode 100644 iwidgets/library/labeledwidget.itk delete mode 100644 iwidgets/library/mainwindow.itk delete mode 100644 iwidgets/library/menubar.itk delete mode 100644 iwidgets/library/messagebox.itk delete mode 100644 iwidgets/library/messagedialog.itk delete mode 100644 iwidgets/library/notebook.itk delete mode 100644 iwidgets/library/optionmenu.itk delete mode 100644 iwidgets/library/pane.itk delete mode 100644 iwidgets/library/panedwindow.itk delete mode 100644 iwidgets/library/pkgIndex.tcl delete mode 100644 iwidgets/library/promptdialog.itk delete mode 100644 iwidgets/library/pushbutton.itk delete mode 100644 iwidgets/library/radiobox.itk delete mode 100644 iwidgets/library/regexpfield.itk delete mode 100644 iwidgets/library/roman.itcl delete mode 100644 iwidgets/library/scopedobject.itcl delete mode 100644 iwidgets/library/scrolledcanvas.itk delete mode 100644 iwidgets/library/scrolledframe.itk delete mode 100644 iwidgets/library/scrolledhtml.itk delete mode 100644 iwidgets/library/scrolledlistbox.itk delete mode 100644 iwidgets/library/scrolledtext.itk delete mode 100644 iwidgets/library/scrolledwidget.itk delete mode 100644 iwidgets/library/selectionbox.itk delete mode 100644 iwidgets/library/selectiondialog.itk delete mode 100644 iwidgets/library/shell.itk delete mode 100644 iwidgets/library/spindate.itk delete mode 100644 iwidgets/library/spinint.itk delete mode 100644 iwidgets/library/spinner.itk delete mode 100644 iwidgets/library/spintime.itk delete mode 100644 iwidgets/library/tabnotebook.itk delete mode 100644 iwidgets/library/tabset.itk delete mode 100644 iwidgets/library/tclIndex delete mode 100644 iwidgets/library/timeentry.itk delete mode 100644 iwidgets/library/timefield.itk delete mode 100644 iwidgets/library/toolbar.itk delete mode 100644 iwidgets/library/unknownimage.gif delete mode 100644 iwidgets/library/watch.itk delete mode 100644 iwidgets/license.terms delete mode 100644 patches/itcl/001-cflags.patch delete mode 100644 patches/itcl/002-ranlib.patch delete mode 100644 patches/itk/001-cflags.patch delete mode 100644 patches/itk/002-ranlib.patch delete mode 100644 patches/itk/003-pathlist.patch delete mode 100644 patches/iwidgets/configure.in delete mode 100644 patches/tcl/configure.in delete mode 100644 patches/tk/configure.in delete mode 160000 tcl delete mode 160000 tk diff --git a/.gitmodules b/.gitmodules index 88c8a94..8df5815 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,19 +1,3 @@ -[submodule "tcl"] - path = tcl - url = https://github.com/tcltk/tcl.git - branch = master -[submodule "tk"] - path = tk - url = https://github.com/tcltk/tk.git - branch = master -[submodule "itcl"] - path = itcl - url = https://github.com/tcltk/itcl.git - branch = master -[submodule "itk"] - path = itk - url = https://github.com/tcltk/itk.git - branch = master [submodule "binutils-gdb"] path = binutils-gdb url = git://sourceware.org/git/binutils-gdb.git diff --git a/README b/README index e671b62..23128b3 100644 --- a/README +++ b/README @@ -10,20 +10,13 @@ therefore needed to get the whole code embedded. They are implemented as: - libgui does not appear in any other repository and thus is now part of insight. -- binutils-gdb, tcl, tk, itcl, itk are included as git submodules. +- binutils-gdb is included as a git submodule. -- iwidgets is no longer part of itk project and is not kept in a git - repository. The current snapshot has been obtained on 2014/06/25 with: - - fossil clone http://chiselapp.com/user/rene/repository/iwidgets \ - iwidgets.fossil - mkdir iwidgets - cd iwidgets - fossil open ../iwidgets.fossil +- tcl, tk, itcl, itk and iwidgets must be provided externally. Cloning: - After a simple clone, submodules have to be initialized and downloaded. This + After a simple clone, the submodule has to be initialized and downloaded. This is done as: git clone cd insight.git @@ -54,6 +47,11 @@ autoconf - Configure the package with the needed options. In example: ./configure --prefix=/usr/. \ + --libdir=/usr/lib64 \ + --disable-gas \ + --disable-gold \ + --disable-gprof \ + --disable-ld \ --enable-sim \ --disable-rpath \ --with-gdb-datadir=/usr/share/insight \ @@ -63,11 +61,6 @@ autoconf --with-python=yes \ --without-libunwind - Some new configuration options have been provided to ease use of - system-installed submodules: - --disable-bundled-xxx - where xxx can be tcl, tk, itcl, itk or iwidgets. - The configure script builds the "bundle" directory where the rest of the build will be performed. diff --git a/binutils-gdb b/binutils-gdb index 6dfb72b..2ec55de 160000 --- a/binutils-gdb +++ b/binutils-gdb @@ -1 +1 @@ -Subproject commit 6dfb72b9068626cbbf0017df092162d11304a3b0 +Subproject commit 2ec55de302e4a6c49a06c673c8262a119fa6226f diff --git a/configure.ac b/configure.ac index 9a8c93e..aeb4a9c 100644 --- a/configure.ac +++ b/configure.ac @@ -1,5 +1,5 @@ dnl Autoconf configure script for insight, the GNU debugger GUI. -dnl Copyright (C) 1995-2014 Free Software Foundation, Inc. +dnl Copyright (C) 1995-2015 Free Software Foundation, Inc. dnl dnl This file is part of GDB. dnl @@ -47,50 +47,6 @@ AC_DISABLE_OPTION_CHECKING dnl AC_CONFIG_SRCDIR([gdbtk/generic/gdbtk.c]) dnl AC_CONFIG_MACRO_DIR([binutils-gdb/config]) -dnl Determine target OS. -TARGETOS=unix -case "${target_os}" in -interix|winnt*|cygwin|msys|mingw*|mks) - TARGETOS=win;; -macos*) - TARGETOS=macosx;; -esac -AC_SUBST([TARGETOS]) - -dnl Check if using the bundled tcl/tk/itcl/itk/iwidgets. -AC_ARG_ENABLE([bundled-tcl], - [--disable-bundled-tcl to use system installed tcl],, - [enable_bundled_tcl=yes]) dnl -if test "${enable_bundled_tcl}" != no -then with_tclinclude="`pwd`/bundle/tcl/generic" - with_tcl="`pwd`/bundle/tcl/${TARGETOS}" -fi -AC_ARG_ENABLE([bundled-tk], - [--disable-bundled-tk to use system installed tk],, - [enable_bundled_tk=yes]) dnl -if test "${enable_bundled_tk}" != no -then with_tkinclude="`pwd`/bundle/tk/generic" - with_tk="`pwd`/bundle/tk/${TARGETOS}" -fi -AC_ARG_ENABLE([bundled-itcl], - [--disable-bundled-itcl to use system installed itcl],, - [enable_bundled_itcl=yes]) dnl -AC_ARG_ENABLE([bundled-itk], - [--disable-bundled-itk to use system installed itk],, - [enable_bundled_itk=yes]) dnl -AC_ARG_ENABLE([bundled-iwidgets], - [--disable-bundled-iwidgets to use system installed iwidgets],, - [enable_bundled_iwidgets=yes]) dnl - -dnl Add configure options according to enabled bundles. -test "${with_tcl}" && - CONFARGS="${CONFARGS} --with-tcl=${with_tcl}" -test "${with_tclinclude}" && - CONFARGS="${CONFARGS} --with-tclinclude=${with_tclinclude}" -test "${with_tk}" && - CONFARGS="${CONFARGS} --with-tk=${with_tk}" -test "${with_tkinclude}" && - CONFARGS="${CONFARGS} --with-tkinclude=${with_tkinclude}" CONFARGS="${CONFARGS} --enable-gdbtk" dnl Remove the initial space we introduced and, as these will be @@ -105,31 +61,6 @@ cp -a gdbtk bundle/gdb/ cp -a testsuite bundle/gdb/ cp -a libgui bundle/ -if test "${enable_bundled_tcl}" != no -then cp -a tcl bundle/ -else rm -rf bundle/tcl -fi - -if test "${enable_bundled_tk}" != no -then cp -a tk bundle/ -else rm -rf bundle/tk -fi - -if test "${enable_bundled_itcl}" != no -then cp -a itcl bundle/ -else rm -rf bundle/itcl -fi - -if test "${enable_bundled_itk}" != no -then cp -a itk bundle/ -else rm -rf bundle/itk -fi - -if test "${enable_bundled_iwidgets}" != no -then cp -a iwidgets bundle/ -else rm -rf bundle/iwidgets -fi - dnl Apply patches for patchfile in patches/*/*.patch do patchdir=`basename \`dirname "${patchfile}"\`` @@ -181,38 +112,6 @@ dnl Now regenerate the configure files automake autoconf --force ) -if test "${enable_bundled_tcl}" != no -then ( - cd bundle/tcl/"${TARGETOS}"; - echo "Regenerate `pwd`" - aclocal -I . -I ../../config - autoconf --force - ) -fi -if test "${enable_bundled_tk}" != no -then ( - cd bundle/tk/"${TARGETOS}" - echo "Regenerate `pwd`" - aclocal -I . -I ../../config - autoconf --force - ) -fi -if test "${enable_bundled_itcl}" != no -then ( - cd bundle/itcl - echo "Regenerate `pwd`" - ln -s -f itclWidget/tclconfig ./ - autoconf --force - ) -fi -if test "${enable_bundled_itk}" != no -then ( - cd bundle/itk - echo "Regenerate `pwd`" - ln -s -f ../itcl/itclWidget/tclconfig ./ - autoconf --force - ) -fi dnl Prepare to configure in the bundle directory. AC_CONFIG_COMMANDS([config_bundle], diff --git a/itcl b/itcl deleted file mode 160000 index c9c1f38..0000000 --- a/itcl +++ /dev/null @@ -1 +0,0 @@ -Subproject commit c9c1f3805163b828819505d462adfc1507bbfdf1 diff --git a/itk b/itk deleted file mode 160000 index 3427561..0000000 --- a/itk +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 342756156a9a45521c101c780e8b795e2fa0768e diff --git a/iwidgets/README b/iwidgets/README deleted file mode 100644 index 3664d9e..0000000 --- a/iwidgets/README +++ /dev/null @@ -1,44 +0,0 @@ -iwidgets 4.1 -- iwidgets for itk4 -================================= - -Slightly modified iwidgets implementation for itk4. -For changes see the iwidgets.patch file. - -Sources -------- - -The itk repository is hosted at: - http://chiselapp.com/user/rene/repository/itk/ -A slightly modified iwidgets (see iwidgets.patch) is hosted at: - http://chiselapp.com/user/rene/repository/iwidgets/ - -Ready to run binaries (*-itk) can be found at: - https://sourceforge.net/projects/kbskit/files/itk/ - -To load itk call: - package require itk 4.0 -and to load itk and iwidgets call: - package require iwidgets 4.1 - -Install -------- - -Copy the library directory as iwidgets4.1 in your tcl library path. - cp -r library /iwidgets4.1 - -Documentation -------------- - -Please refer to the original documantation at - http://incrtcl.sourceforge.net/iwidgets/ - -License & support ------------------ - -This work is under BSD license (see file 'license.terms') - -Acknowledgements ----------------- - -This work is based on the original "iwidgets" work at - http://incrtcl.sourceforge.net/iwidgets/ diff --git a/iwidgets/iwidgets.patch b/iwidgets/iwidgets.patch deleted file mode 100644 index 3ed7a46..0000000 --- a/iwidgets/iwidgets.patch +++ /dev/null @@ -1,108 +0,0 @@ -diff -Nupr /home/rene/kbs.sf/sources/iwidgets4.0.2/generic/combobox.itk generic/combobox.itk ---- /home/rene/kbs.sf/sources/iwidgets4.0.2/generic/combobox.itk 2007-05-25 01:06:45.000000000 +0200 -+++ generic/combobox.itk 2012-05-21 10:35:15.933262250 +0200 -@@ -521,7 +521,8 @@ itcl::body iwidgets::Combobox::insert {c - } else { - if {$itk_option(-state) == "normal"} { - eval iwidgets::Entryfield::insert $index $args -- [itcl::code $this _lookup ""] -+ #RZ [itcl::code $this _lookup ""] -+ eval [itcl::code $this _lookup ""] - } - } - } -diff -Nupr /home/rene/kbs.sf/sources/iwidgets4.0.2/generic/labeledframe.itk generic/labeledframe.itk ---- /home/rene/kbs.sf/sources/iwidgets4.0.2/generic/labeledframe.itk 2001-08-15 20:32:51.000000000 +0200 -+++ generic/labeledframe.itk 2012-05-21 12:23:03.849527914 +0200 -@@ -289,6 +289,7 @@ itcl::configbody iwidgets::Labeledframe: - # {"-relx" "-rely" } - # ----------------------------------------------------------------------------- - itcl::body iwidgets::Labeledframe::_initTable {} { -+ if {![catch {set _LAYOUT_TABLE(nw-relx)}]} return ;#RZ - array set _LAYOUT_TABLE { - nw-relx 0.0 nw-rely 0.0 nw-wrap 0 nw-conf rowconfigure nw-num 0 - n-relx 0.5 n-rely 0.0 n-wrap 0 n-conf rowconfigure n-num 0 -@@ -313,7 +314,7 @@ itcl::body iwidgets::Labeledframe::_init - # - # NOTE: Be careful to use the "body" command, or the proc will get lost! - # -- itcl::body ::iwidgets::Labeledframe::_initTable {} {} -+ #RZ itcl::body ::iwidgets::Labeledframe::_initTable {} {} - } - - # ----------------------------------------------------------------------------- -diff -Nupr /home/rene/kbs.sf/sources/iwidgets4.0.2/generic/menubar.itk generic/menubar.itk ---- /home/rene/kbs.sf/sources/iwidgets4.0.2/generic/menubar.itk 2001-08-15 20:33:13.000000000 +0200 -+++ generic/menubar.itk 2012-05-21 12:27:32.039459872 +0200 -@@ -160,6 +160,7 @@ itcl::class iwidgets::Menubar { - - variable _menuOption ;# The -menu option - variable _helpString ;# The -helpstr optio -+ variable _fixed 0 ;#RZ bug fix - } - } - -@@ -198,7 +199,7 @@ itcl::body iwidgets::Menubar::constructo - set _pathMap(.) $itk_component(menubar) - - eval itk_initialize $args -- -+ set _fixed 1 ;#RZ - # - # HACK HACK HACK - # Tk expects some variables to be defined and due to some -@@ -357,7 +358,8 @@ itcl::configbody iwidgets::Menubar::menu - - # IF one exists already, delete the old one and create - # a new one -- if { ! [catch {_parsePath .0}] } { -+ #RZ if { ! [catch {_parsePath .0}] } -+ if { $_fixed && ! [catch {_parsePath .0}] } { - delete .0 .last - } - -@@ -2071,9 +2073,7 @@ itcl::body iwidgets::Menubar::_parsePath - - set concatPath "" - foreach seg $segments { -- - set concatPath [_getSymbolicPath $concatPath $seg] -- - if { [catch {set _pathMap($concatPath)} ] } { - error "bad path: \"$path\" does not exist. \"$seg\" not valid" - } -diff -Nupr /home/rene/kbs.sf/sources/iwidgets4.0.2/generic/scrolledhtml.itk generic/scrolledhtml.itk ---- /home/rene/kbs.sf/sources/iwidgets4.0.2/generic/scrolledhtml.itk 2004-12-02 18:49:18.000000000 +0100 -+++ generic/scrolledhtml.itk 2012-05-21 10:46:55.428543431 +0200 -@@ -139,7 +139,7 @@ itcl::class iwidgets::Scrolledhtml { - itk_option define -alink alink ALink red - itk_option define -linkhighlight alink ALink red - itk_option define -unknownimage unknownimage File {} -- itk_option define -textbackground textBackground Background {} -+ itk_option define -textbackground textBackground Background {#ffffff};#RZ - itk_option define -update update Update 1 - itk_option define -debug debug Debug 0 - -@@ -352,7 +352,8 @@ itcl::body iwidgets::Scrolledhtml::destr - foreach x $_images { - ::image delete $x - } -- if {$_unknownimg != $_defUnknownImg} { -+ #RZ if {$_unknownimg != $_defUnknownImg} -+ if {$_unknownimg != "" && $_unknownimg != $_defUnknownImg} { - ::image delete $_unknownimg - } - } -diff -Nupr /home/rene/kbs.sf/sources/iwidgets4.0.2/generic/toolbar.itk generic/toolbar.itk ---- /home/rene/kbs.sf/sources/iwidgets4.0.2/generic/toolbar.itk 2001-08-17 21:05:54.000000000 +0200 -+++ generic/toolbar.itk 2012-05-21 10:59:31.804539052 +0200 -@@ -684,7 +684,8 @@ itcl::body iwidgets::Toolbar::_addWidget - foreach optionSet [$itk_component($name) configure] { - set option [lindex $optionSet 0] - if { [lsearch $_optionList $option] != -1 } { -- itk_option add $name.$option -+ #RZ itk_option add $name.$option -+ itk_option add $name.[string range $option 1 end] - } - } - diff --git a/iwidgets/library/buttonbox.itk b/iwidgets/library/buttonbox.itk deleted file mode 100644 index 4e8317a..0000000 --- a/iwidgets/library/buttonbox.itk +++ /dev/null @@ -1,571 +0,0 @@ -# -# Buttonbox -# ---------------------------------------------------------------------- -# Manages a framed area with Motif style buttons. The button box can -# be configured either horizontally or vertically. -# -# ---------------------------------------------------------------------- -# AUTHOR: Mark L. Ulferts EMAIL: mulferts@austin.dsccc.com -# Bret A. Schuhmacher EMAIL: bas@wn.com -# -# @(#) $Id: buttonbox.itk,v 1.3 2001/08/15 18:30:53 smithc Exp $ -# ---------------------------------------------------------------------- -# Copyright (c) 1995 DSC Technologies Corporation -# ====================================================================== -# Permission to use, copy, modify, distribute and license this software -# and its documentation for any purpose, and without fee or written -# agreement with DSC, is hereby granted, provided that the above copyright -# notice appears in all copies and that both the copyright notice and -# warranty disclaimer below appear in supporting documentation, and that -# the names of DSC Technologies Corporation or DSC Communications -# Corporation not be used in advertising or publicity pertaining to the -# software without specific, written prior permission. -# -# DSC DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING -# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, 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. IN NO EVENT SHALL -# DSC BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR -# ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, -# WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION, -# ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS -# SOFTWARE. -# ====================================================================== - -# -# Usual options. -# -itk::usual Buttonbox { - keep -background -cursor -foreground -} - -# ------------------------------------------------------------------ -# BUTTONBOX -# ------------------------------------------------------------------ -itcl::class iwidgets::Buttonbox { - inherit itk::Widget - - constructor {args} {} - destructor {} - - itk_option define -pady padY Pad 5 - itk_option define -padx padX Pad 5 - itk_option define -orient orient Orient "horizontal" - itk_option define -foreground foreground Foreground black - - public method index {args} - public method add {args} - public method insert {args} - public method delete {args} - public method default {args} - public method hide {args} - public method show {args} - public method invoke {args} - public method buttonconfigure {args} - public method buttoncget {index option} - - private method _positionButtons {} - private method _setBoxSize {{when later}} - private method _getMaxWidth {} - private method _getMaxHeight {} - - private variable _resizeFlag {} ;# Flag for resize needed. - private variable _buttonList {} ;# List of all buttons in box. - private variable _displayList {} ;# List of displayed buttons. - private variable _unique 0 ;# Counter for button widget ids. -} - -namespace eval iwidgets::Buttonbox { - # - # Set up some class level bindings for map and configure events. - # - bind bbox-map [itcl::code %W _setBoxSize] - bind bbox-config [itcl::code %W _positionButtons] -} - -# -# Provide a lowercased access method for the Buttonbox class. -# -proc ::iwidgets::buttonbox {pathName args} { - uplevel ::iwidgets::Buttonbox $pathName $args -} - -# ------------------------------------------------------------------ -# CONSTRUCTOR -# ------------------------------------------------------------------ -itcl::body iwidgets::Buttonbox::constructor {args} { - # - # Add Configure bindings for geometry management. - # - bindtags $itk_component(hull) \ - [linsert [bindtags $itk_component(hull)] 0 bbox-map] - bindtags $itk_component(hull) \ - [linsert [bindtags $itk_component(hull)] 1 bbox-config] - - pack propagate $itk_component(hull) no - - # - # Initialize the widget based on the command line options. - # - eval itk_initialize $args -} - -# ------------------------------------------------------------------ -# DESTRUCTOR -# ------------------------------------------------------------------ -itcl::body iwidgets::Buttonbox::destructor {} { - if {$_resizeFlag != ""} {after cancel $_resizeFlag} -} - -# ------------------------------------------------------------------ -# OPTIONS -# ------------------------------------------------------------------ - -# ------------------------------------------------------------------ -# OPTION: -pady -# -# Pad the y space between the button box frame and the hull. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Buttonbox::pady { - _setBoxSize -} - -# ------------------------------------------------------------------ -# OPTION: -padx -# -# Pad the x space between the button box frame and the hull. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Buttonbox::padx { - _setBoxSize -} - -# ------------------------------------------------------------------ -# OPTION: -orient -# -# Position buttons either horizontally or vertically. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Buttonbox::orient { - switch $itk_option(-orient) { - "horizontal" - - "vertical" { - _setBoxSize - } - - default { - error "bad orientation option \"$itk_option(-orient)\",\ - should be either horizontal or vertical" - } - } -} - -# ------------------------------------------------------------------ -# METHODS -# ------------------------------------------------------------------ - -# ------------------------------------------------------------------ -# METHOD: index index -# -# Searches the buttons in the box for the one with the requested tag, -# numerical index, keyword "end" or "default". Returns the button's -# tag if found, otherwise error. -# ------------------------------------------------------------------ -itcl::body iwidgets::Buttonbox::index {index} { - if {[llength $_buttonList] > 0} { - if {[regexp {(^[0-9]+$)} $index]} { - if {$index < [llength $_buttonList]} { - return $index - } else { - error "Buttonbox index \"$index\" is out of range" - } - - } elseif {$index == "end"} { - return [expr {[llength $_buttonList] - 1}] - - } elseif {$index == "default"} { - foreach knownButton $_buttonList { - if {[$itk_component($knownButton) cget -defaultring]} { - return [lsearch -exact $_buttonList $knownButton] - } - } - - error "Buttonbox \"$itk_component(hull)\" has no default" - - } else { - if {[set idx [lsearch $_buttonList $index]] != -1} { - return $idx - } - - error "bad Buttonbox index \"$index\": must be number, end,\ - default, or pattern" - } - - } else { - error "Buttonbox \"$itk_component(hull)\" has no buttons" - } -} - -# ------------------------------------------------------------------ -# METHOD: add tag ?option value option value ...? -# -# Add the specified button to the button box. All PushButton options -# are allowed. New buttons are added to the list of buttons and the -# list of displayed buttons. The PushButton path name is returned. -# ------------------------------------------------------------------ -itcl::body iwidgets::Buttonbox::add {tag args} { - itk_component add $tag { - iwidgets::Pushbutton $itk_component(hull).[incr _unique] - } { - usual - rename -highlightbackground -background background Background - } - - if {$args != ""} { - uplevel $itk_component($tag) configure $args - } - - lappend _buttonList $tag - lappend _displayList $tag - - _setBoxSize -} - -# ------------------------------------------------------------------ -# METHOD: insert index tag ?option value option value ...? -# -# Insert the specified button in the button box just before the one -# given by index. All PushButton options are allowed. New buttons -# are added to the list of buttons and the list of displayed buttons. -# The PushButton path name is returned. -# ------------------------------------------------------------------ -itcl::body iwidgets::Buttonbox::insert {index tag args} { - itk_component add $tag { - iwidgets::Pushbutton $itk_component(hull).[incr _unique] - } { - usual - rename -highlightbackground -background background Background - } - - if {$args != ""} { - uplevel $itk_component($tag) configure $args - } - - set index [index $index] - set _buttonList [linsert $_buttonList $index $tag] - set _displayList [linsert $_displayList $index $tag] - - _setBoxSize -} - -# ------------------------------------------------------------------ -# METHOD: delete index -# -# Delete the specified button from the button box. -# ------------------------------------------------------------------ -itcl::body iwidgets::Buttonbox::delete {index} { - set index [index $index] - set tag [lindex $_buttonList $index] - - destroy $itk_component($tag) - - set _buttonList [lreplace $_buttonList $index $index] - - if {[set dind [lsearch $_displayList $tag]] != -1} { - set _displayList [lreplace $_displayList $dind $dind] - } - - _setBoxSize - update idletasks -} - -# ------------------------------------------------------------------ -# METHOD: default index -# -# Sets the default to the push button given by index. -# ------------------------------------------------------------------ -itcl::body iwidgets::Buttonbox::default {index} { - set index [index $index] - - set defbtn [lindex $_buttonList $index] - - foreach knownButton $_displayList { - if {$knownButton == $defbtn} { - $itk_component($knownButton) configure -defaultring yes - } else { - $itk_component($knownButton) configure -defaultring no - } - } -} - -# ------------------------------------------------------------------ -# METHOD: hide index -# -# Hide the push button given by index. This doesn't remove the button -# permanently from the display list, just inhibits its display. -# ------------------------------------------------------------------ -itcl::body iwidgets::Buttonbox::hide {index} { - set index [index $index] - set tag [lindex $_buttonList $index] - - if {[set dind [lsearch $_displayList $tag]] != -1} { - place forget $itk_component($tag) - set _displayList [lreplace $_displayList $dind $dind] - - _setBoxSize - } -} - -# ------------------------------------------------------------------ -# METHOD: show index -# -# Displays a previously hidden push button given by index. Check if -# the button is already in the display list. If not then add it back -# at it's original location and redisplay. -# ------------------------------------------------------------------ -itcl::body iwidgets::Buttonbox::show {index} { - set index [index $index] - set tag [lindex $_buttonList $index] - - if {[lsearch $_displayList $tag] == -1} { - set _displayList [linsert $_displayList $index $tag] - - _setBoxSize - } -} - -# ------------------------------------------------------------------ -# METHOD: invoke ?index? -# -# Invoke the command associated with a push button. If no arguments -# are given then the default button is invoked, otherwise the argument -# is expected to be a button index. -# ------------------------------------------------------------------ -itcl::body iwidgets::Buttonbox::invoke {args} { - if {[llength $args] == 0} { - $itk_component([lindex $_buttonList [index default]]) invoke - - } else { - $itk_component([lindex $_buttonList [index [lindex $args 0]]]) \ - invoke - } -} - -# ------------------------------------------------------------------ -# METHOD: buttonconfigure index ?option? ?value option value ...? -# -# Configure a push button given by index. This method allows -# configuration of pushbuttons from the Buttonbox level. The options -# may have any of the values accepted by the add method. -# ------------------------------------------------------------------ -itcl::body iwidgets::Buttonbox::buttonconfigure {index args} { - set tag [lindex $_buttonList [index $index]] - - set retstr [uplevel $itk_component($tag) configure $args] - - _setBoxSize - - return $retstr -} - -# ------------------------------------------------------------------ -# METHOD: buttonccget index option -# -# Return value of option for push button given by index. Option may -# have any of the values accepted by the add method. -# ------------------------------------------------------------------ -itcl::body iwidgets::Buttonbox::buttoncget {index option} { - set tag [lindex $_buttonList [index $index]] - - set retstr [uplevel $itk_component($tag) cget [list $option]] - - return $retstr -} - -# ----------------------------------------------------------------- -# PRIVATE METHOD: _getMaxWidth -# -# Returns the required width of the largest button. -# ----------------------------------------------------------------- -itcl::body iwidgets::Buttonbox::_getMaxWidth {} { - set max 0 - - foreach tag $_displayList { - set w [winfo reqwidth $itk_component($tag)] - - if {$w > $max} { - set max $w - } - } - - return $max -} - -# ----------------------------------------------------------------- -# PRIVATE METHOD: _getMaxHeight -# -# Returns the required height of the largest button. -# ----------------------------------------------------------------- -itcl::body iwidgets::Buttonbox::_getMaxHeight {} { - set max 0 - - foreach tag $_displayList { - set h [winfo reqheight $itk_component($tag)] - - if {$h > $max} { - set max $h - } - } - - return $max -} - -# ------------------------------------------------------------------ -# METHOD: _setBoxSize ?when? -# -# Sets the proper size of the frame surrounding all the buttons. -# If "when" is "now", the change is applied immediately. If it is -# "later" or it is not specified, then the change is applied later, -# when the application is idle. -# ------------------------------------------------------------------ -itcl::body iwidgets::Buttonbox::_setBoxSize {{when later}} { - if {[winfo ismapped $itk_component(hull)]} { - if {$when == "later"} { - if {$_resizeFlag == ""} { - set _resizeFlag [after idle [itcl::code $this _setBoxSize now]] - } - return - } elseif {$when != "now"} { - error "bad option \"$when\": should be now or later" - } - - set _resizeFlag "" - - set numBtns [llength $_displayList] - - if {$itk_option(-orient) == "horizontal"} { - set minw [expr {$numBtns * [_getMaxWidth] \ - + ($numBtns+1) * $itk_option(-padx)}] - set minh [expr {[_getMaxHeight] + 2 * $itk_option(-pady)}] - - } else { - set minw [expr {[_getMaxWidth] + 2 * $itk_option(-padx)}] - set minh [expr {$numBtns * [_getMaxHeight] \ - + ($numBtns+1) * $itk_option(-pady)}] - } - - # - # Remove the configure event bindings on the hull while we adjust the - # width/height and re-position the buttons. Once we're through, we'll - # update and reinstall them. This prevents double calls to position - # the buttons. - # - set tags [bindtags $itk_component(hull)] - if {[set i [lsearch $tags bbox-config]] != -1} { - set tags [lreplace $tags $i $i] - bindtags $itk_component(hull) $tags - } - - component hull configure -width $minw -height $minh - - update idletasks - - _positionButtons - - bindtags $itk_component(hull) [linsert $tags 0 bbox-config] - } -} - -# ------------------------------------------------------------------ -# METHOD: _positionButtons -# -# This method is responsible setting the width/height of all the -# displayed buttons to the same value and for placing all the buttons -# in equidistant locations. -# ------------------------------------------------------------------ -itcl::body iwidgets::Buttonbox::_positionButtons {} { - set bf $itk_component(hull) - set numBtns [llength $_displayList] - - # - # First, determine the common width and height for all the - # displayed buttons. - # - if {$numBtns > 0} { - set bfWidth [winfo width $itk_component(hull)] - set bfHeight [winfo height $itk_component(hull)] - - if {$bfWidth >= [winfo reqwidth $itk_component(hull)]} { - set _btnWidth [_getMaxWidth] - - } else { - if {$itk_option(-orient) == "horizontal"} { - set _btnWidth [expr {$bfWidth / $numBtns}] - } else { - set _btnWidth $bfWidth - } - } - - if {$bfHeight >= [winfo reqheight $itk_component(hull)]} { - set _btnHeight [_getMaxHeight] - - } else { - if {$itk_option(-orient) == "vertical"} { - set _btnHeight [expr {$bfHeight / $numBtns}] - } else { - set _btnHeight $bfHeight - } - } - } - - # - # Place the buttons at the proper locations. - # - if {$numBtns > 0} { - if {$itk_option(-orient) == "horizontal"} { - set leftover [expr {[winfo width $bf] \ - - 2 * $itk_option(-padx) - $_btnWidth * $numBtns}] - - if {$numBtns > 0} { - set offset [expr {$leftover / ($numBtns + 1)}] - } else { - set offset 0 - } - if {$offset < 0} {set offset 0} - - set xDist [expr {$itk_option(-padx) + $offset}] - set incrAmount [expr {$_btnWidth + $offset}] - - foreach button $_displayList { - place $itk_component($button) -anchor w \ - -x $xDist -rely .5 -y 0 -relx 0 \ - -width $_btnWidth -height $_btnHeight - - set xDist [expr {$xDist + $incrAmount}] - } - - } else { - set leftover [expr {[winfo height $bf] \ - - 2 * $itk_option(-pady) - $_btnHeight * $numBtns}] - - if {$numBtns > 0} { - set offset [expr {$leftover / ($numBtns + 1)}] - } else { - set offset 0 - } - if {$offset < 0} {set offset 0} - - set yDist [expr {$itk_option(-pady) + $offset}] - set incrAmount [expr {$_btnHeight + $offset}] - - foreach button $_displayList { - place $itk_component($button) -anchor n \ - -y $yDist -relx .5 -x 0 -rely 0 \ - -width $_btnWidth -height $_btnHeight - - set yDist [expr {$yDist + $incrAmount}] - } - } - } -} - - diff --git a/iwidgets/library/calendar.itk b/iwidgets/library/calendar.itk deleted file mode 100644 index 81d7ab5..0000000 --- a/iwidgets/library/calendar.itk +++ /dev/null @@ -1,991 +0,0 @@ -# -# Calendar -# ---------------------------------------------------------------------- -# Implements a calendar widget for the selection of a date. It displays -# a single month at a time. Buttons exist on the top to change the -# month in effect turning th pages of a calendar. As a page is turned, -# the dates for the month are modified. Selection of a date visually -# marks that date. The selected value can be monitored via the -# -command option or just retrieved using the get method. Methods also -# exist to select a date and show a particular month. The option set -# allows the calendars appearance to take on many forms. -# ---------------------------------------------------------------------- -# AUTHOR: Mark L. Ulferts E-mail: mulferts@austin.dsccc.com -# -# ACKNOWLEDGEMENTS: Michael McLennan E-mail: mmclennan@lucent.com -# -# This code is an [incr Tk] port of the calendar code shown in Michael -# J. McLennan's book "Effective Tcl" from Addison Wesley. Small -# modificiations were made to the logic here and there to make it a -# mega-widget and the command and option interface was expanded to make -# it even more configurable, but the underlying logic is the same. -# -# @(#) $Id: calendar.itk,v 1.9 2007/05/24 22:41:02 hobbs Exp $ -# ---------------------------------------------------------------------- -# Copyright (c) 1997 DSC Technologies Corporation -# ====================================================================== -# Permission to use, copy, modify, distribute and license this software -# and its documentation for any purpose, and without fee or written -# agreement with DSC, is hereby granted, provided that the above copyright -# notice appears in all copies and that both the copyright notice and -# warranty disclaimer below appear in supporting documentation, and that -# the names of DSC Technologies Corporation or DSC Communications -# Corporation not be used in advertising or publicity pertaining to the -# software without specific, written prior permission. -# -# DSC DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING -# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, 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. IN NO EVENT SHALL -# DSC BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR -# ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, -# WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION, -# ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS -# SOFTWARE. -# ====================================================================== - -# -# Usual options. -# -itk::usual Calendar { - keep -background -cursor -} - -# ------------------------------------------------------------------ -# CALENDAR -# ------------------------------------------------------------------ -itcl::class iwidgets::Calendar { - inherit itk::Widget - - constructor {args} {} - - itk_option define -days days Days {Su Mo Tu We Th Fr Sa} - itk_option define -command command Command {} - itk_option define -forwardimage forwardImage Image {} - itk_option define -backwardimage backwardImage Image {} - itk_option define -weekdaybackground weekdayBackground Background \#d9d9d9 - itk_option define -weekendbackground weekendBackground Background \#d9d9d9 - itk_option define -outline outline Outline \#d9d9d9 - itk_option define -buttonforeground buttonForeground Foreground blue - itk_option define -foreground foreground Foreground black - itk_option define -selectcolor selectColor Foreground red - itk_option define -selectthickness selectThickness SelectThickness 3 - itk_option define -titlefont titleFont Font \ - -*-helvetica-bold-r-normal--*-140-* - itk_option define -dayfont dayFont Font \ - -*-helvetica-medium-r-normal--*-120-* - itk_option define -datefont dateFont Font \ - -*-helvetica-medium-r-normal--*-120-* - itk_option define -currentdatefont currentDateFont Font \ - -*-helvetica-bold-r-normal--*-120-* - itk_option define -startday startDay Day sunday - itk_option define -int int DateFormat no - - public method get {{format "-string"}} ;# Returns the selected date - public method select {{date_ "now"}} ;# Selects date, moving select ring - public method show {{date_ "now"}} ;# Displays a specific date - - protected method _drawtext {canvas_ day_ date_ now_ x0_ y0_ x1_ y1_} - - private method _change {delta_} - private method _configureHandler {} - private method _redraw {} - private method _days {{wmax {}}} - private method _layout {time_} - private method _select {date_} - private method _selectEvent {date_} - private method _adjustday {day_} - private method _percentSubst {pattern_ string_ subst_} - - private variable _time {} - private variable _selected {} - private variable _initialized 0 - private variable _offset 0 - private variable _format {} -} - -# -# Provide a lowercased access method for the Calendar class. -# -proc ::iwidgets::calendar {pathName args} { - uplevel ::iwidgets::Calendar $pathName $args -} - -# -# Use option database to override default resources of base classes. -# -option add *Calendar.width 200 widgetDefault -option add *Calendar.height 165 widgetDefault - -# ------------------------------------------------------------------ -# CONSTRUCTOR -# ------------------------------------------------------------------ -itcl::body iwidgets::Calendar::constructor {args} { - # - # Create the canvas which displays each page of the calendar. - # - itk_component add page { - canvas $itk_interior.page - } { - keep -background -cursor -width -height - } - pack $itk_component(page) -expand yes -fill both - - # - # Create the forward and backward buttons. Rather than pack - # them directly in the hull, we'll waittill later and make - # them canvas window items. - # - itk_component add backward { - button $itk_component(page).backward \ - -command [itcl::code $this _change -1] - } { - keep -background -cursor - } - - itk_component add forward { - button $itk_component(page).forward \ - -command [itcl::code $this _change +1] - } { - keep -background -cursor - } - - # - # Set the initial time to now. - # - set _time [clock seconds] - - # - # Bind to the configure event which will be used to redraw - # the calendar and display the month. - # - bind $itk_component(page) [itcl::code $this _configureHandler] - - # - # Evaluate the option arguments. - # - eval itk_initialize $args -} - -# ------------------------------------------------------------------ -# OPTIONS -# ------------------------------------------------------------------ -# ------------------------------------------------------------------ -# OPTION: -int -# -# Added by Mark Alston 2001/10/21 -# -# Allows for the use of dates in "international" format: YYYY-MM-DD. -# It must be a boolean value. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Calendar::int { - switch $itk_option(-int) { - 1 - yes - true - on { - set itk_option(-int) yes - } - 0 - no - false - off { - set itk_option(-int) no - } - default { - error "bad int option \"$itk_option(-int)\": should be boolean" - } - } -} - -# ------------------------------------------------------------------ -# OPTION: -command -# -# Sets the selection command for the calendar. When the user -# selects a date on the calendar, the date is substituted in -# place of "%d" in this command, and the command is executed. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Calendar::command {} - -# ------------------------------------------------------------------ -# OPTION: -days -# -# The days option takes a list of values to set the text used to display the -# days of the week header above the dates. The default value is -# {Su Mo Tu We Th Fr Sa}. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Calendar::days { - if {$_initialized} { - if {[$itk_component(page) find withtag days] != {}} { - $itk_component(page) delete days - _days - } - } -} - -# ------------------------------------------------------------------ -# OPTION: -backwardimage -# -# Specifies a image to be displayed on the backwards calendar -# button. If none is specified, a default is provided. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Calendar::backwardimage { - - # - # If no image is given, then we'll use the default image. - # - if {$itk_option(-backwardimage) == {}} { - - # - # If the default image hasn't yet been created, then we - # need to create it. - # - if {[lsearch [image names] $this-backward] == -1} { - image create bitmap $this-backward \ - -foreground $itk_option(-buttonforeground) -data { - #define back_width 16 - #define back_height 16 - static unsigned char back_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xc0, 0x30, - 0xe0, 0x38, 0xf0, 0x3c, 0xf8, 0x3e, 0xfc, 0x3f, - 0xfc, 0x3f, 0xf8, 0x3e, 0xf0, 0x3c, 0xe0, 0x38, - 0xc0, 0x30, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; - } - } - - # - # Configure the button to use the default image. - # - $itk_component(backward) configure -image $this-backward - - # - # Else, an image has been specified. First, we'll need to make sure - # the image really exists before configuring the button to use it. - # If it doesn't generate an error. - # - } else { - if {[lsearch [image names] $itk_option(-backwardimage)] != -1} { - $itk_component(backward) configure \ - -image $itk_option(-backwardimage) - } else { - error "bad image name \"$itk_option(-backwardimage)\":\ - image does not exist" - } - - # - # If we previously created a default image, we'll just remove it. - # - if {[lsearch [image names] $this-backward] != -1} { - image delete $this-backward - } - } -} - - -# ------------------------------------------------------------------ -# OPTION: -forwardimage -# -# Specifies a image to be displayed on the forwards calendar -# button. If none is specified, a default is provided. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Calendar::forwardimage { - - # - # If no image is given, then we'll use the default image. - # - if {$itk_option(-forwardimage) == {}} { - - # - # If the default image hasn't yet been created, then we - # need to create it. - # - if {[lsearch [image names] $this-forward] == -1} { - image create bitmap $this-forward \ - -foreground $itk_option(-buttonforeground) -data { - #define fwd_width 16 - #define fwd_height 16 - static unsigned char fwd_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x0c, 0x03, - 0x1c, 0x07, 0x3c, 0x0f, 0x7c, 0x1f, 0xfc, 0x3f, - 0xfc, 0x3f, 0x7c, 0x1f, 0x3c, 0x0f, 0x1c, 0x07, - 0x0c, 0x03, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; - } - } - - # - # Configure the button to use the default image. - # - $itk_component(forward) configure -image $this-forward - - # - # Else, an image has been specified. First, we'll need to make sure - # the image really exists before configuring the button to use it. - # If it doesn't generate an error. - # - } else { - if {[lsearch [image names] $itk_option(-forwardimage)] != -1} { - $itk_component(forward) configure \ - -image $itk_option(-forwardimage) - } else { - error "bad image name \"$itk_option(-forwardimage)\":\ - image does not exist" - } - - # - # If we previously created a default image, we'll just remove it. - # - if {[lsearch [image names] $this-forward] != -1} { - image delete $this-forward - } - } -} - -# ------------------------------------------------------------------ -# OPTION: -weekdaybackground -# -# Specifies the background for the weekdays which allows it to -# be visually distinguished from the weekend. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Calendar::weekdaybackground { - if {$_initialized} { - $itk_component(page) itemconfigure weekday \ - -fill $itk_option(-weekdaybackground) - } -} - -# ------------------------------------------------------------------ -# OPTION: -weekendbackground -# -# Specifies the background for the weekdays which allows it to -# be visually distinguished from the weekdays. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Calendar::weekendbackground { - if {$_initialized} { - $itk_component(page) itemconfigure weekend \ - -fill $itk_option(-weekendbackground) - } -} - -# ------------------------------------------------------------------ -# OPTION: -foreground -# -# Specifies the foreground color for the textual items, buttons, -# and divider on the calendar. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Calendar::foreground { - if {$_initialized} { - $itk_component(page) itemconfigure text \ - -fill $itk_option(-foreground) - $itk_component(page) itemconfigure line \ - -fill $itk_option(-foreground) - } -} - -# ------------------------------------------------------------------ -# OPTION: -outline -# -# Specifies the outline color used to surround the date text. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Calendar::outline { - if {$_initialized} { - $itk_component(page) itemconfigure square \ - -outline $itk_option(-outline) - } -} - -# ------------------------------------------------------------------ -# OPTION: -buttonforeground -# -# Specifies the foreground color of the forward and backward buttons. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Calendar::buttonforeground { - if {$_initialized} { - if {$itk_option(-forwardimage) == {}} { - if {[lsearch [image names] $this-forward] != -1} { - $this-forward configure \ - -foreground $itk_option(-buttonforeground) - } - } else { - $itk_component(forward) configure \ - -foreground $itk_option(-buttonforeground) - } - - if {$itk_option(-backwardimage) == {}} { - if {[lsearch [image names] $this-backward] != -1} { - $this-backward configure \ - -foreground $itk_option(-buttonforeground) - } - } else { - $itk_component(-backward) configure \ - -foreground $itk_option(-buttonforeground) - } - } -} - -# ------------------------------------------------------------------ -# OPTION: -selectcolor -# -# Specifies the color of the ring displayed that distinguishes the -# currently selected date. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Calendar::selectcolor { - if {$_initialized} { - $itk_component(page) itemconfigure $_selected-sensor \ - -outline $itk_option(-selectcolor) - } -} - -# ------------------------------------------------------------------ -# OPTION: -selectthickness -# -# Specifies the thickness of the ring displayed that distinguishes -# the currently selected date. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Calendar::selectthickness { - if {$_initialized} { - $itk_component(page) itemconfigure $_selected-sensor \ - -width $itk_option(-selectthickness) - } -} - -# ------------------------------------------------------------------ -# OPTION: -titlefont -# -# Specifies the font used for the title text that consists of the -# month and year. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Calendar::titlefont { - if {$_initialized} { - $itk_component(page) itemconfigure title \ - -font $itk_option(-titlefont) - } -} - -# ------------------------------------------------------------------ -# OPTION: -datefont -# -# Specifies the font used for the date text that consists of the -# day of the month. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Calendar::datefont { - if {$_initialized} { - $itk_component(page) itemconfigure date \ - -font $itk_option(-datefont) - } -} - -# ------------------------------------------------------------------ -# OPTION: -currentdatefont -# -# Specifies the font used for the current date text. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Calendar::currentdatefont { - if {$_initialized} { - $itk_component(page) itemconfigure now \ - -font $itk_option(-currentdatefont) - } -} - -# ------------------------------------------------------------------ -# OPTION: -dayfont -# -# Specifies the font used for the day of the week text. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Calendar::dayfont { - if {$_initialized} { - $itk_component(page) itemconfigure days \ - -font $itk_option(-dayfont) - } -} - -# ------------------------------------------------------------------ -# OPTION: -startday -# -# Specifies the starting day for the week. The value must be a day of the -# week: sunday, monday, tuesday, wednesday, thursday, friday, or -# saturday. The default is sunday. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Calendar::startday { - set day [string tolower $itk_option(-startday)] - - switch $day { - sunday {set _offset 0} - monday {set _offset 1} - tuesday {set _offset 2} - wednesday {set _offset 3} - thursday {set _offset 4} - friday {set _offset 5} - saturday {set _offset 6} - default { - error "bad startday option \"$itk_option(-startday)\":\ - should be sunday, monday, tuesday, wednesday,\ - thursday, friday, or saturday" - } - } - - if {$_initialized} { - $itk_component(page) delete all-page - _redraw - } -} - -# ------------------------------------------------------------------ -# METHODS -# ------------------------------------------------------------------ - -# ------------------------------------------------------------------ -# PUBLIC METHOD: get ?format? -# -# Returns the currently selected date in one of two formats, string -# or as an integer clock value using the -string and -clicks -# options respectively. The default is by string. Reference the -# clock command for more information on obtaining dates and their -# formats. -# ------------------------------------------------------------------ -itcl::body iwidgets::Calendar::get {{format "-string"}} { - switch -- $format { - "-string" { - return $_selected - } - "-clicks" { - return [clock scan $_selected] - } - default { - error "bad format option \"$format\":\ - should be -string or -clicks" - } - } -} - -# ------------------------------------------------------------------ -# PUBLIC METHOD: select date_ -# -# Changes the currently selected date to the value specified. -# ------------------------------------------------------------------ -itcl::body iwidgets::Calendar::select {{date_ "now"}} { - if {$date_ == "now"} { - set time [clock seconds] - } else { - if {[catch {clock format $date_}] == 0} { - set time $date_ - } elseif {[catch {set time [clock scan $date_]}] != 0} { - error "bad date: \"$date_\", must be a valid date string, clock clicks value or the keyword now" - } - } - switch $itk_option(-int) { - yes { set _format "%Y-%m-%d" } - no { set _format "%m/%d/%Y" } - } - _select [clock format $time -format "$_format"] -} - -# ------------------------------------------------------------------ -# PUBLIC METHOD: show date_ -# -# Changes the currently display month to be that of the specified -# date. -# ------------------------------------------------------------------ -itcl::body iwidgets::Calendar::show {{date_ "now"}} { - if {$date_ == "now"} { - set _time [clock seconds] - } else { - if {[catch {clock format $date_}] == 0} { - set _time $date_ - } elseif {[catch {set _time [clock scan $date_]}] != 0} { - error "bad date: \"$date_\", must be a valid date string, clock clicks value or the keyword now" - } - } - - $itk_component(page) delete all-page - _redraw -} - -# ------------------------------------------------------------------ -# PROTECTED METHOD: _drawtext canvas_ day_ date_ now_ -# x0_ y0_ x1_ y1_ -# -# Draws the text in the date square. The method is protected such that -# it can be overridden in derived classes that may wish to add their -# own unique text. The method receives the day to draw along with -# the coordinates of the square. -# ------------------------------------------------------------------ -itcl::body iwidgets::Calendar::_drawtext {canvas_ day_ date_ now_ x0_ y0_ x1_ y1_} { - set item [$canvas_ create text \ - [expr {(($x1_ - $x0_) / 2) + $x0_}] \ - [expr {(($y1_ -$y0_) / 2) + $y0_ + 1}] \ - -anchor center -text "$day_" \ - -fill $itk_option(-foreground)] - - if {$date_ == $now_} { - $canvas_ itemconfigure $item \ - -font $itk_option(-currentdatefont) \ - -tags [list all-page date $date_-date text now] - } else { - $canvas_ itemconfigure $item \ - -font $itk_option(-datefont) \ - -tags [list all-page date $date_-date text] - } -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _configureHandler -# -# Processes a configure event received on the canvas. The method -# deletes all the current canvas items and forces a redraw. -# ------------------------------------------------------------------ -itcl::body iwidgets::Calendar::_configureHandler {} { - set _initialized 1 - - $itk_component(page) delete all - _redraw -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _change delta_ -# -# Changes the current month displayed in the calendar, moving -# forward or backward by months where is +/- -# some number. -# ------------------------------------------------------------------ -itcl::body iwidgets::Calendar::_change {delta_} { - set dir [expr {($delta_ > 0) ? 1 : -1}] - set month [clock format $_time -format "%m"] - set month [string trimleft $month 0] - set year [clock format $_time -format "%Y"] - - for {set i 0} {$i < abs($delta_)} {incr i} { - incr month $dir - if {$month < 1} { - set month 12 - incr year -1 - } elseif {$month > 12} { - set month 1 - incr year 1 - } - } - if {[catch {set _time [clock scan "$month/1/$year"]}]} { - bell - } else { - _redraw - } -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _redraw -# -# Redraws the calendar. This method is invoked whenever the -# calendar changes size or we need to effect a change such as draw -# it with a new month. -# ------------------------------------------------------------------ -itcl::body iwidgets::Calendar::_redraw {} { - # - # Set the format based on the option -int - # - switch $itk_option(-int) { - yes { set _format "%Y-%m-%d" } - no { set _format "%m/%d/%Y" } - } - # - # Remove all the items that typically change per redraw request - # such as the title and dates. Also, get the maximum width and - # height of the page. - # - $itk_component(page) delete all-page - - set wmax [winfo width $itk_component(page)] - set hmax [winfo height $itk_component(page)] - - # - # If we haven't yet created the forward and backwards buttons, - # then dot it; otherwise, skip it. - # - if {[$itk_component(page) find withtag button] == {}} { - $itk_component(page) create window 3 3 -anchor nw \ - -window $itk_component(backward) -tags button - $itk_component(page) create window [expr {$wmax-3}] 3 -anchor ne \ - -window $itk_component(forward) -tags button - } - - # - # Create the title centered between the buttons. - # - foreach {x0 y0 x1 y1} [$itk_component(page) bbox button] { - set x [expr {(($x1-$x0)/2)+$x0}] - set y [expr {(($y1-$y0)/2)+$y0}] - } - - set title [clock format $_time -format "%B %Y"] - $itk_component(page) create text $x $y -anchor center \ - -text $title -font $itk_option(-titlefont) \ - -fill $itk_option(-foreground) \ - -tags [list title text all-page] - - # - # Add the days of the week labels if they haven't yet been created. - # - if {[$itk_component(page) find withtag days] == {}} { - _days $wmax - } - - # - # Add a line between the calendar header and the dates if needed. - # - set bottom [expr {[lindex [$itk_component(page) bbox all] 3] + 3}] - - if {[$itk_component(page) find withtag line] == {}} { - $itk_component(page) create line 0 $bottom $wmax $bottom \ - -width 2 -tags line - } - - incr bottom 3 - - # - # Get the layout for the time value and create the date squares. - # This includes the surrounding date rectangle, the date text, - # and the sensor. Bind selection to the sensor. - # - set current "" - set now [clock format [clock seconds] -format "$_format"] - - set layout [_layout $_time] - set weeks [expr {[lindex $layout end] + 1}] - - foreach {day date kind dcol wrow} $layout { - set x0 [expr {$dcol*($wmax-7)/7+3}] - set y0 [expr {$wrow*($hmax-$bottom-4)/$weeks+$bottom}] - set x1 [expr {($dcol+1)*($wmax-7)/7+3}] - set y1 [expr {($wrow+1)*($hmax-$bottom-4)/$weeks+$bottom}] - - if {$date == $_selected} { - set current $date - } - - # - # Create the rectangle that surrounds the date and configure - # its background based on the wheather it is a weekday or - # a weekend. - # - set item [$itk_component(page) create rectangle $x0 $y0 $x1 $y1 \ - -outline $itk_option(-outline)] - - if {$kind == "weekend"} { - $itk_component(page) itemconfigure $item \ - -fill $itk_option(-weekendbackground) \ - -tags [list all-page square weekend] - } else { - $itk_component(page) itemconfigure $item \ - -fill $itk_option(-weekdaybackground) \ - -tags [list all-page square weekday] - } - - # - # Create the date text and configure its font based on the - # wheather or not it is the current date. - # - _drawtext $itk_component(page) $day $date $now $x0 $y0 $x1 $y1 - - # - # Create a sensor area to detect selections. Bind the - # sensor and pass the date to the bind script. - # - $itk_component(page) create rectangle $x0 $y0 $x1 $y1 \ - -outline "" -fill "" \ - -tags [list $date-sensor all-sensor all-page] - - $itk_component(page) bind $date-sensor \ - [itcl::code $this _selectEvent $date] - - $itk_component(page) bind $date-date \ - [itcl::code $this _selectEvent $date] - } - - # - # Highlight the selected date if it is on this page. - # - if {$current != ""} { - $itk_component(page) itemconfigure $current-sensor \ - -outline $itk_option(-selectcolor) \ - -width $itk_option(-selectthickness) - - $itk_component(page) raise $current-sensor - - } elseif {$_selected == ""} { - set date [clock format $_time -format "$_format"] - _select $date - } -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _days -# -# Used to rewite the days of the week label just below the month -# title string. The days are given in the -days option. -# ------------------------------------------------------------------ -itcl::body iwidgets::Calendar::_days {{wmax {}}} { - if {$wmax == {}} { - set wmax [winfo width $itk_component(page)] - } - - set col 0 - set bottom [expr {[lindex [$itk_component(page) bbox title buttons] 3] + 7}] - - foreach dayoweek $itk_option(-days) { - set x0 [expr {$col*($wmax/7)}] - set x1 [expr {($col+1)*($wmax/7)}] - - $itk_component(page) create text \ - [expr {(($x1 - $x0) / 2) + $x0}] $bottom \ - -anchor n -text "$dayoweek" \ - -fill $itk_option(-foreground) \ - -font $itk_option(-dayfont) \ - -tags [list days text] - - incr col - } -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _layout time_ -# -# Used whenever the calendar is redrawn. Finds the month containing -# a in seconds, and returns a list for all of the days in -# that month. The list looks like this: -# -# {day1 date1 kind1 c1 r1 day2 date2 kind2 c2 r2 ...} -# -# where dayN is a day number like 1,2,3,..., dateN is the date for -# dayN, kindN is the day type of weekday or weekend, and cN,rN -# are the column/row indices for the square containing that date. -# ------------------------------------------------------------------ -itcl::body iwidgets::Calendar::_layout {time_} { - - switch $itk_option(-int) { - yes { set _format "%Y-%m-%d" } - no { set _format "%m/%d/%Y" } - } - - set month [clock format $time_ -format "%m"] - set year [clock format $time_ -format "%Y"] - - if {[info tclversion] >= 8.5} { - set startOfMonth [clock scan "$year-$month-01" -format %Y-%m-%d] - set lastday [clock format [clock add $startOfMonth 1 month -1 day] -format %d] - } else { - foreach lastday {31 30 29 28} { - if {[catch {clock scan "$month/$lastday/$year"}] == 0} { - break - } - } - } - set seconds [clock scan "$month/1/$year"] - set firstday [_adjustday [clock format $seconds -format %w]] - - set weeks [expr {ceil(double($lastday+$firstday)/7)}] - - set rlist "" - for {set day 1} {$day <= $lastday} {incr day} { - set seconds [clock scan "$month/$day/$year"] - set date [clock format $seconds -format "$_format"] - set dayoweek [clock format $seconds -format %w] - - if {$dayoweek == 0 || $dayoweek == 6} { - set kind "weekend" - } else { - set kind "weekday" - } - - set daycol [_adjustday $dayoweek] - - set weekrow [expr {($firstday+$day-1)/7}] - lappend rlist $day $date $kind $daycol $weekrow - } - return $rlist -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _adjustday day_ -# -# Modifies the day to be in accordance with the startday option. -# ------------------------------------------------------------------ -itcl::body iwidgets::Calendar::_adjustday {day_} { - set retday [expr {$day_ - $_offset}] - - if {$retday < 0} { - set retday [expr {$retday + 7}] - } - - return $retday -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _select date_ -# -# Selects the current on the calendar. Highlights the date -# on the calendar, and executes the command associated with the -# calendar, with the selected date substituted in place of "%d". -# ------------------------------------------------------------------ -itcl::body iwidgets::Calendar::_select {date_} { - - switch $itk_option(-int) { - yes { set _format "%Y-%m-%d" } - no { set _format "%m/%d/%Y" } - } - - - set time [clock scan $date_] - set date [clock format $time -format "$_format"] - - set _selected $date - set current [clock format $_time -format "%m %Y"] - set selected [clock format $time -format "%m %Y"] - - if {$current == $selected} { - $itk_component(page) itemconfigure all-sensor \ - -outline "" -width 1 - - $itk_component(page) itemconfigure $date-sensor \ - -outline $itk_option(-selectcolor) \ - -width $itk_option(-selectthickness) - $itk_component(page) raise $date-sensor - } else { - set _time $time - _redraw - } -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _selectEvent date_ -# -# Selects the current on the calendar. Highlights the date -# on the calendar, and executes the command associated with the -# calendar, with the selected date substituted in place of "%d". -# ------------------------------------------------------------------ -itcl::body iwidgets::Calendar::_selectEvent {date_} { - _select $date_ - - if {[string trim $itk_option(-command)] != ""} { - set cmd $itk_option(-command) - set cmd [_percentSubst %d $cmd [get]] - uplevel #0 $cmd - } -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _percentSubst pattern_ string_ subst_ -# -# This command is a "safe" version of regsub, for substituting -# each occurance of <%pattern_> in with . The -# usual Tcl "regsub" command does the same thing, but also -# converts characters like "&" and "\0", "\1", etc. that may -# be present in the string. -# -# Returns with substituted in place of each -# <%pattern_>. -# ------------------------------------------------------------------ -itcl::body iwidgets::Calendar::_percentSubst {pattern_ string_ subst_} { - if {![string match %* $pattern_]} { - error "bad pattern \"$pattern_\": should be %something" - } - - set rval "" - while {[regexp "(.*)${pattern_}(.*)" $string_ all head tail]} { - set rval "$subst_$tail$rval" - set string_ $head - } - set rval "$string_$rval" -} diff --git a/iwidgets/library/canvasprintbox.itk b/iwidgets/library/canvasprintbox.itk deleted file mode 100644 index 9d41daa..0000000 --- a/iwidgets/library/canvasprintbox.itk +++ /dev/null @@ -1,1111 +0,0 @@ -# -# CanvasPrintBox v1.5 -# ---------------------------------------------------------------------- -# Implements a print box for printing the contents of a canvas widget -# to a printer or a file. It is possible to specify page orientation, the -# number of pages to print the image on and if the output should be -# stretched to fit the page. -# -# CanvasPrintBox is a "super-widget" that can be used as an -# element in ones own GUIs. It is used to print the contents -# of a canvas (called the source hereafter) to a printer or a -# file. Possible settings include: portrait and landscape orientation -# of the output, stretching the output to fit the page while maintaining -# a proper aspect-ratio and posterizing to enlarge the output to fit on -# multiple pages. A stamp-sized copy of the source will be shown (called -# the stamp hereafter) at all times to reflect the effect of changing -# the settings will have on the output. -# -# ---------------------------------------------------------------------- -# AUTHOR: Tako Schotanus EMAIL: Tako.Schotanus@bouw.tno.nl -# ---------------------------------------------------------------------- -# Copyright (c) 1995 Tako Schotanus -# ====================================================================== -# Permission is hereby granted, without written agreement and without -# license or royalty fees, to use, copy, modify, and distribute this -# software and its documentation for any purpose, provided that the -# above copyright notice and the following two paragraphs appear in -# all copies of this software. -# -# IN NO EVENT SHALL THE COPYRIGHT HOLDER BE LIABLE TO ANY PARTY FOR -# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES -# ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN -# IF THE COPYRIGHT HOLDER HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH -# DAMAGE. -# -# THE COPYRIGHT HOLDER SPECIFICALLY DISCLAIMS ANY WARRANTIES, INCLUDING, -# BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -# FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS -# ON AN "AS IS" BASIS, AND THE COPYRIGHT HOLDER HAS NO OBLIGATION TO -# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. -# ====================================================================== - -# -# Default resources. -# -option add *Canvasprintbox.filename "canvas.ps" widgetDefault -option add *Canvasprintbox.hPageCnt 1 widgetDefault -option add *Canvasprintbox.orient landscape widgetDefault -option add *Canvasprintbox.output printer widgetDefault -option add *Canvasprintbox.pageSize A4 widgetDefault -option add *Canvasprintbox.posterize 0 widgetDefault -option add *Canvasprintbox.printCmd lpr widgetDefault -option add *Canvasprintbox.printRegion "" widgetDefault -option add *Canvasprintbox.vPageCnt 1 widgetDefault - -# -# Usual options. -# -itk::usual Canvasprintbox { - keep -background -cursor -textbackground -foreground -} - -#< -# -# CanvasPrintBox is a "super-widget" that can be used as an -# element in ones own GUIs. It is used to print the contents -# of a canvas (called the source hereafter) to a printer or a -# file. Possible settings include: portrait and landscape orientation -# of the output, stretching the output to fit the page while maintaining -# a proper aspect-ratio and posterizing to enlarge the output to fit on -# multiple pages. A stamp-sized copy of the source will be shown (called -# the stamp hereafter) at all times to reflect the effect of changing -# the settings will have on the output. -# -#> -itcl::class iwidgets::Canvasprintbox { - inherit itk::Widget - - # - # Holds the current state for all check- and radiobuttons. - # - itk_option define -filename filename FileName "canvas.ps" - itk_option define -hpagecnt hPageCnt PageCnt 1 - itk_option define -orient orient Orient "landscape" - itk_option define -output output Output "printer" - itk_option define -pagesize pageSize PageSize "A4" - itk_option define -posterize posterize Posterize 0 - itk_option define -printcmd printCmd PrintCmd "" - itk_option define -printregion printRegion PrintRegion "" - itk_option define -stretch stretch Stretch 0 - itk_option define -vpagecnt vPageCnt PageCnt 1 - - constructor {args} {} - destructor {} - - # --------------------------------------------------------------- - # PUBLIC - #---------------------------------------------------------------- - public { - method getoutput {} - method print {} - method refresh {} - method setcanvas {canv} - method stop {} - } - - # --------------------------------------------------------------- - # PROTECTED - #---------------------------------------------------------------- - protected { - # - # Just holds the names of some widgets/objects. "win" is used to - # determine if the object is fully constructed and initialized. - # - variable win "" - variable canvw "" - - # - # The canvas we want to print. - # - variable canvas "" - - # - # Boolean indicating if the attribute "orient" is set - # to landscape or not. - # - variable rotate 1 - - # - # Holds the configure options that were used to create this object. - # - variable init_opts "" - - # - # The following attributes hold a list of lines that are - # currently drawn on the "stamp" to show how the page(s) is/are - # oriented. The first holds the vertical dividing lines and the - # second the horizontal ones. - # - variable hlines "" - variable vlines "" - - # - # Updating is set when the thumbnail is being drawn. Settings - # this to 0 while drawing is still busy will terminate the - # proces. - # Restart_update can be set to 1 when the thumbnail is being - # drawn to force a redraw. - # - variable _reposition "" - variable _update_attr_id "" - - method _calc_poster_size {} - method _calc_print_region {} - method _calc_print_scale {} - method _mapEventHandler {} - method _update_attr {{when later}} - method _update_canvas {{when later}} - - common _globVar - - proc ezPaperInfo {size {attr ""} \ - {orient "portrait"} {window ""}} {} - } -} - -# -# Provide a lowercased access method for the Canvasprintbox class. -# -proc ::iwidgets::canvasprintbox {args} { - uplevel ::iwidgets::Canvasprintbox $args -} - -# ------------------------------------------------------------------ -# OPTIONS -# ------------------------------------------------------------------ - -#< -# A list of four coordinates specifying which part of the canvas to print. -# An empty list means that the canvas' entire scrollregion should be -# printed. Any change to this attribute will automatically update the "stamp". -# Defaults to an empty list. -#> -itcl::configbody iwidgets::Canvasprintbox::printregion { - if {$itk_option(-printregion) != "" - && [llength $itk_option(-printregion)] != 4} { - error {bad option "printregion": should contain 4 coordinates} - } - _update_canvas -} - -#< -# Specifies where the postscript output should go: to the printer -# or to a file. Can take on the values "printer" or "file". -# The corresponding entry-widget will reflect the contents of -# either the printcmd attribute or the filename attribute. -#> -itcl::configbody iwidgets::Canvasprintbox::output { - switch $itk_option(-output) { - file - printer { - set _globVar($this,output) $itk_option(-output) - } - default { - error {bad output option \"$itk_option(-output)\":\ - should be file or printer} - } - } - _update_attr -} - -#< -# The command to execute when printing the postscript output. -# The command will get the postscript directed to its standard -# input. (Only when output is set to "printer") -#> -itcl::configbody iwidgets::Canvasprintbox::printcmd { - set _globVar($this,printeref) $itk_option(-printcmd) - _update_attr -} - -#< -# The file to write the postscript output to (Only when output -# is set to "file"). If posterizing is turned on and hpagecnt -# and/or vpagecnt is more than 1, x.y is appended to the filename -# where x is the horizontal page number and y the vertical page number. -#> -itcl::configbody iwidgets::Canvasprintbox::filename { - set _globVar($this,fileef) $itk_option(-filename) - _update_attr -} - -#< -# The pagesize the printer supports. Changes to this attribute -# will be reflected immediately in the "stamp". -#> -itcl::configbody iwidgets::Canvasprintbox::pagesize { - set opt [string tolower $itk_option(-pagesize)] - set lst [string tolower [ezPaperInfo types]] - if {[lsearch $lst $opt] == -1} { - error "bad option \"pagesize\": should be one of: [ezPaperInfo types]" - } - $itk_component(paperom) select "*[string range $opt 1 end]" - _update_canvas -} - -#< -# Determines the orientation of the output to the printer (or file). -# It can take the value "portrait" or "landscape" (default). Changes -# to this attribute will be reflected immediately in the "stamp". -#> -itcl::configbody iwidgets::Canvasprintbox::orient { - switch $itk_option(-orient) { - "portrait" - "landscape" { - $itk_component(orientom) select $itk_option(-orient) - _update_canvas - - } - default { - error "bad orient option \"$itk_option(-orient)\":\ - should be portrait or landscape" - } - } -} - -#< -# Determines if the output should be stretched to fill the -# page (as defined by the attribute pagesize) as large as -# possible. The aspect-ratio of the output will be retained -# and the output will never fall outside of the boundaries -# of the page. -#> -itcl::configbody iwidgets::Canvasprintbox::stretch { - if {$itk_option(-stretch) != 0 && $itk_option(-stretch) != 1} { - error {bad option "stretch": should be a boolean} - } - set _globVar($this,stretchcb) $itk_option(-stretch) - _update_attr -} - -#< -# Indicates if posterizing is turned on or not. Posterizing -# the output means that it is possible to distribute the -# output over more than one page. This way it is possible to -# print a canvas/region which is larger than the specified -# pagesize without stretching. If used in combination with -# stretching it can be used to "blow up" the contents of a -# canvas to as large as size as you want (See attributes: -# hpagecnt end vpagecnt). Any change to this attribute will -# automatically update the "stamp". -#> -itcl::configbody iwidgets::Canvasprintbox::posterize { - if {$itk_option(-posterize) != "0" && $itk_option(-posterize) != "1"} { - error "expected boolean but got \"$itk_option(-posterize)\"" - } - set _globVar($this,postercb) $itk_option(-posterize) - _update_canvas -} - -#< -# Is used in combination with "posterize" to determine over -# how many pages the output should be distributed. This -# attribute specifies how many pages should be used horizontaly. -# Any change to this attribute will automatically update the "stamp". -#> -itcl::configbody iwidgets::Canvasprintbox::hpagecnt { - set _globVar($this,hpc) $itk_option(-hpagecnt) - _update_canvas -} - -#< -# Is used in combination with "posterize" to determine over -# how many pages the output should be distributed. This -# attribute specifies how many pages should be used verticaly. -# Any change to this attribute will automatically update the "stamp". -#> -itcl::configbody iwidgets::Canvasprintbox::vpagecnt { - set _globVar($this,vpc) $itk_option(-vpagecnt) - _update_canvas -} - -# ------------------------------------------------------------------ -# CONSTRUCTOR -# ------------------------------------------------------------------ -itcl::body iwidgets::Canvasprintbox::constructor {args} { - set _globVar($this,output) printer - set _globVar($this,printeref) "" - set _globVar($this,fileef) "canvas.ps" - set _globVar($this,hpc) 1 - set _globVar($this,vpc) 1 - set _globVar($this,postercb) 0 - set _globVar($this,stretchcb) 0 - - itk_component add canvasframe { - frame $itk_interior.f18 -bd 2 - } - - itk_component add canvas { - canvas $itk_component(canvasframe).c1 \ - -bd 2 -relief sunken \ - -scrollregion {0c 0c 10c 10c} \ - -width 250 - } - pack $itk_component(canvas) -expand 1 -fill both - - itk_component add outputom { - iwidgets::Labeledframe $itk_interior.outputom \ - -labelpos nw \ - -labeltext "Output to" - } - set cs [$itk_component(outputom) childsite] - - itk_component add printerrb { - radiobutton $cs.printerrb \ - -text Printer \ - -variable [itcl::scope _globVar($this,output)] \ - -anchor w \ - -justify left \ - -value printer \ - -command [itcl::code $this _update_attr] - } { - usual - rename -font -labelfont labelFont Font - } - itk_component add printeref { - iwidgets::entryfield $cs.printeref \ - -labeltext "command:" \ - -state normal \ - -labelpos w \ - -textvariable [itcl::scope _globVar($this,printeref)] - } - - itk_component add filerb { - radiobutton $cs.filerb \ - -text File \ - -justify left \ - -anchor w \ - -variable [itcl::scope _globVar($this,output)] \ - -value file \ - -command [itcl::code $this _update_attr] - } { - usual - rename -font -labelfont labelFont Font - } - itk_component add fileef { - iwidgets::entryfield $cs.fileef \ - -labeltext "filename:" \ - -state disabled \ - -labelpos w \ - -textvariable [itcl::scope _globVar($this,fileef)] - } - - itk_component add propsframe { - iwidgets::Labeledframe $itk_interior.propsframe \ - -labelpos nw \ - -labeltext "Properties" - } - set cs [$itk_component(propsframe) childsite] - - itk_component add paperom { - iwidgets::optionmenu $cs.paperom \ - -labelpos w -cyclicon 1 \ - -labeltext "Paper size:" \ - -command [itcl::code $this refresh] - } { - usual - rename -font -labelfont labelFont Font - } - eval $itk_component(paperom) insert end [ezPaperInfo types] - $itk_component(paperom) select A4 - - itk_component add orientom { - iwidgets::radiobox $itk_interior.orientom \ - -labeltext "Orientation" -command [itcl::code $this refresh] - } - $itk_component(orientom) add landscape -text Landscape - $itk_component(orientom) add portrait -text Portrait - $itk_component(orientom) select 0 - - itk_component add stretchcb { - checkbutton $cs.stretchcb \ - -relief flat \ - -text {Stretch to fit} \ - -justify left \ - -anchor w \ - -variable [itcl::scope _globVar($this,stretchcb)] \ - -command [itcl::code $this refresh] - } { - usual - rename -font -labelfont labelFont Font - } - - itk_component add postercb { - checkbutton $cs.postercb \ - -relief flat \ - -text Posterize \ - -justify left \ - -anchor w \ - -variable [itcl::scope _globVar($this,postercb)] \ - -command [itcl::code $this refresh] - } { - usual - rename -font -labelfont labelFont Font - } - - itk_component add hpcnt { - iwidgets::entryfield $cs.hpcnt \ - -labeltext on \ - -textvariable [itcl::scope _globVar($this,hpc)] \ - -validate integer -width 3 \ - -command [itcl::code $this refresh] - } - - itk_component add vpcnt { - iwidgets::entryfield $cs.vpcnt \ - -labeltext by \ - -textvariable [itcl::scope _globVar($this,vpc)] \ - -validate integer -width 3 \ - -command [itcl::code $this refresh] - } - - itk_component add pages { - label $cs.pages -text pages. - } { - usual - rename -font -labelfont labelFont Font - } - - set init_opts $args - - grid $itk_component(canvasframe) -row 0 -column 0 -rowspan 4 -sticky nsew - grid $itk_component(propsframe) -row 0 -column 1 -sticky nsew - grid $itk_component(outputom) -row 1 -column 1 -sticky nsew - grid $itk_component(orientom) -row 2 -column 1 -sticky nsew - grid columnconfigure $itk_interior 0 -weight 1 - grid rowconfigure $itk_interior 3 -weight 1 - - grid $itk_component(printerrb) -row 0 -column 0 -sticky nsw - grid $itk_component(printeref) -row 0 -column 1 -sticky nsw - grid $itk_component(filerb) -row 1 -column 0 -sticky nsw - grid $itk_component(fileef) -row 1 -column 1 -sticky nsw - iwidgets::Labeledwidget::alignlabels $itk_component(printeref) $itk_component(fileef) - grid columnconfigure $itk_component(outputom) 1 -weight 1 - - grid $itk_component(paperom) -row 0 -column 0 -columnspan 2 -sticky nsw - grid $itk_component(stretchcb) -row 1 -column 0 -sticky nsw - grid $itk_component(postercb) -row 2 -column 0 -sticky nsw - grid $itk_component(hpcnt) -row 2 -column 1 -sticky nsw - grid $itk_component(vpcnt) -row 2 -column 2 -sticky nsw - grid $itk_component(pages) -row 2 -column 3 -sticky nsw - grid columnconfigure $itk_component(propsframe) 3 -weight 1 - - eval itk_initialize $args - - bind $itk_component(pages) +[itcl::code $this _mapEventHandler] - bind $itk_component(canvas) +[itcl::code $this refresh] -} - - -# --------------------------------------------------------------- -# PUBLIC METHODS -#---------------------------------------------------------------- - -#< -# This is used to set the canvas that has to be printed. -# A stamp-sized copy will automatically be drawn to show how the -# output would look with the current settings. -# -# In: canv - The canvas to be printed -# Out: canvas (attrib) - Holds the canvas to be printed -#> -itcl::body iwidgets::Canvasprintbox::setcanvas {canv} { - set canvas $canv - _update_canvas -} - -#< -# Returns the value of the -printercmd or -filename option -# depending on the current setting of -output. -# -# In: itk_option (attrib) -# Out: The value of -printercmd or -filename -#> -itcl::body iwidgets::Canvasprintbox::getoutput {} { - switch $_globVar($this,output) { - "file" { - return $_globVar($this,fileef) - } - "printer" { - return $_globVar($this,printeref) - } - } - return "" -} - -#< -# Perfrom the actual printing of the canvas using the current settings of -# all the attributes. -# -# In: itk_option, rotate (attrib) -# Out: A boolean indicating wether printing was successful -#> -itcl::body iwidgets::Canvasprintbox::print {} { - - global env tcl_platform - - stop - - if {$itk_option(-output) == "file"} { - set nm $_globVar($this,fileef) - if {[string range $nm 0 1] == "~/"} { - set nm "$env(HOME)/[string range $nm 2 end]" - } - } else { - set nm "/tmp/xge[winfo id $canvas]" - } - - set pr [_calc_print_region] - set x1 [lindex $pr 0] - set y1 [lindex $pr 1] - set x2 [lindex $pr 2] - set y2 [lindex $pr 3] - set cx [expr {int(($x2 + $x1) / 2)}] - set cy [expr {int(($y2 + $y1) / 2)}] - if {!$itk_option(-stretch)} { - set ps [_calc_poster_size] - set pshw [expr {int([lindex $ps 0] / 2)}] - set pshh [expr {int([lindex $ps 1] / 2)}] - set x [expr {$cx - $pshw}] - set y [expr {$cy - $pshh}] - set w [ezPaperInfo $itk_option(-pagesize) pwidth $itk_option(-orient) $win] - set h [ezPaperInfo $itk_option(-pagesize) pheight $itk_option(-orient) $win] - } else { - set x $x1 - set y $y1 - set w [expr {($x2-$x1) / $_globVar($this,hpc)}] - set h [expr {($y2-$y1) / $_globVar($this,vpc)}] - } - - set i 0 - set px $x - while {$i < $_globVar($this,hpc)} { - set j 0 - set py $y - while {$j < $_globVar($this,vpc)} { - set nm2 [expr {$_globVar($this,hpc) > 1 || $_globVar($this,vpc) > 1 ? "$nm$i.$j" : $nm}] - - if {$itk_option(-stretch)} { - $canvas postscript \ - -file $nm2 \ - -rotate $rotate \ - -x $px -y $py \ - -width $w \ - -height $h \ - -pagex [ezPaperInfo $itk_option(-pagesize) centerx] \ - -pagey [ezPaperInfo $itk_option(-pagesize) centery] \ - -pagewidth [ezPaperInfo $itk_option(-pagesize) pwidth $itk_option(-orient)] \ - -pageheight [ezPaperInfo $itk_option(-pagesize) pheight $itk_option(-orient)] - } else { - $canvas postscript \ - -file $nm2 \ - -rotate $rotate \ - -x $px -y $py \ - -width $w \ - -height $h \ - -pagex [ezPaperInfo $itk_option(-pagesize) centerx] \ - -pagey [ezPaperInfo $itk_option(-pagesize) centery] - } - - if {$itk_option(-output) == "printer"} { - set cmd "$itk_option(-printcmd) < $nm2" - if {[catch {eval exec $cmd &}]} { - return 0 - } - } - - set py [expr {$py + $h}] - incr j - } - set px [expr {$px + $w}] - incr i - } - - return 1 -} - -#< -# Retrieves the current value for all edit fields and updates -# the stamp accordingly. Is useful for Apply-buttons. -#> -itcl::body iwidgets::Canvasprintbox::refresh {} { - stop - _update_canvas - return -} - -#< -# Stops the drawing of the "stamp". I'm currently unable to detect -# when a Canvasprintbox gets withdrawn. It's therefore advised -# that you perform a stop before you do something like that. -#> -itcl::body iwidgets::Canvasprintbox::stop {} { - - if {$_reposition != ""} { - after cancel $_reposition - set _reposition "" - } - - if {$_update_attr_id != ""} { - after cancel $_update_attr_id - set _update_attr_id "" - } - - return -} - -# --------------------------------------------------------------- -# PROTECTED METHODS -#---------------------------------------------------------------- - -# -# Calculate the total size the output would be with the current -# settings for "pagesize" and "posterize" (and "hpagecnt" and -# "vpagecnt"). This size will be the size of the printable area, -# some space has been substracted to take into account that a -# page should have borders because most printers can't print on -# the very edge of the paper. -# -# In: posterize, hpagecnt, vpagecnt, pagesize, orient (attrib) -# Out: A list of two numbers indicating the width and the height -# of the total paper area which will be used for printing -# in pixels. -# -itcl::body iwidgets::Canvasprintbox::_calc_poster_size {} { - set tpw [expr {[ezPaperInfo $itk_option(-pagesize) \ - pwidth $itk_option(-orient) $win]*$_globVar($this,hpc)}] - set tph [expr {[ezPaperInfo $itk_option(-pagesize) \ - pheight $itk_option(-orient) $win]*$_globVar($this,vpc)}] - - return "$tpw $tph" -} - -# -# Determine which area of the "source" canvas will be printed. -# If "printregion" was set by the "user" this will be used and -# converted to pixel-coordinates. If the user didn't set it -# the bounding box that contains all canvas-items will be used -# instead. -# -# In: printregion, canvas (attrib) -# Out: Four floats specifying the region to be printed in -# pixel-coordinates (topleft & bottomright). -# -itcl::body iwidgets::Canvasprintbox::_calc_print_region {} { - set printreg [expr {$itk_option(-printregion) != "" - ? $itk_option(-printregion) : [$canvas bbox all]}] - - if {$printreg != ""} { - set prx1 [winfo fpixels $canvas [lindex $printreg 0]] - set pry1 [winfo fpixels $canvas [lindex $printreg 1]] - set prx2 [winfo fpixels $canvas [lindex $printreg 2]] - set pry2 [winfo fpixels $canvas [lindex $printreg 3]] - - set res "$prx1 $pry1 $prx2 $pry2" - } else { - set res "0 0 0 0" - } - - return $res -} - -# -# Calculate the scaling factor needed if the output was -# to be stretched to fit exactly on the page (or pages). -# If stretching is turned off this will always return 1.0. -# -# In: stretch (attrib) -# Out: A float specifying the scaling factor. -# -itcl::body iwidgets::Canvasprintbox::_calc_print_scale {} { - if {$itk_option(-stretch)} { - set pr [_calc_print_region] - set prw [expr {[lindex $pr 2] - [lindex $pr 0]}] - set prh [expr {[lindex $pr 3] - [lindex $pr 1]}] - set ps [_calc_poster_size] - set psw [lindex $ps 0] - set psh [lindex $ps 1] - set sfx [expr {$psw / $prw}] - set sfy [expr {$psh / $prh}] - set sf [expr {$sfx < $sfy ? $sfx : $sfy}] - return $sf - } else { - return 1.0 - } -} - -# -# Schedule the thread that makes a copy of the "source" -# canvas to the "stamp". -# -# In: win, canvas (attrib) -# Out: - -# -itcl::body iwidgets::Canvasprintbox::_update_canvas {{when later}} { - if {$win == "" || $canvas == "" || [$canvas find all] == ""} { - return - } - if {$when == "later"} { - if {$_reposition == ""} { - set _reposition [after idle [itcl::code $this _update_canvas now]] - } - return - } - - _update_attr now - - # - # Make a copy of the "source" canvas to the "stamp". - # - if {$_globVar($this,hpc) == [llength $vlines] && - $_globVar($this,vpc) == [llength $hlines]} { - stop - return - } - - $canvw delete all - - set width [winfo width $canvw] - set height [winfo height $canvw] - set ps [_calc_poster_size] - - # - # Calculate the scaling factor that would be needed to fit the - # whole "source" into the "stamp". This takes into account the - # total amount of "paper" that would be needed to print the - # contents of the "source". - # - set xsf [expr {$width/[lindex $ps 0]}] - set ysf [expr {$height/[lindex $ps 1]}] - set sf [expr {$xsf < $ysf ? $xsf : $ysf}] - set w [expr {[lindex $ps 0]*$sf}] - set h [expr {[lindex $ps 1]*$sf}] - set x1 [expr {($width-$w)/2}] - set y1 [expr {($height-$h)/2}] - set x2 [expr {$x1+$w}] - set y2 [expr {$y1+$h}] - set cx [expr {($x2+$x1)/ 2}] - set cy [expr {($y2+$y1)/ 2}] - - set printreg [_calc_print_region] - set prx1 [lindex $printreg 0] - set pry1 [lindex $printreg 1] - set prx2 [lindex $printreg 2] - set pry2 [lindex $printreg 3] - set prcx [expr {($prx2+$prx1)/2}] - set prcy [expr {($pry2+$pry1)/2}] - - set psf [_calc_print_scale] - - # - # Copy all items from the "real" canvas to the canvas - # showing what we'll send to the printer. Bitmaps and - # texts are not copied because they can't be scaled, - # a rectangle will be created instead. - # - set tsf [expr {$sf * $psf}] - set dx [expr {$cx-($prcx*$tsf)}] - set dy [expr {$cy-($prcy*$tsf)}] - $canvw create rectangle \ - [expr {$x1+0}] \ - [expr {$y1+0}] \ - [expr {$x2-0}] \ - [expr {$y2-0}] -fill white - set items [eval "$canvas find overlapping $printreg"] - - set itemCount [llength $items] - for {set cnt 0} {$cnt < $itemCount} {incr cnt} { - # - # Determine the item's type and coordinates - # - set i [lindex $items $cnt] - set t [$canvas type $i] - set crds [$canvas coords $i] - - # - # Ask for the item's configuration settings and strip - # it to leave only a list of option names and values. - # - set cfg [$canvas itemconfigure $i] - set cfg2 "" - foreach c $cfg { - if {[llength $c] == 5} { - lappend cfg2 [lindex $c 0] [lindex $c 4] - } - } - - # - # Handle texts and bitmaps differently: they will - # be represented as rectangles. - # - if {$t == "text" || $t == "bitmap" || $t == "window"} { - set t "rectangle" - set crds [$canvas bbox $i] - set cfg2 "-outline {} -fill gray" - } - - # - # Remove the arrows from a line item when the scale - # factor drops below 1/3rd of the original size. - # This to prevent the arrowheads from dominating the - # display. - # - if {$t == "line" && $tsf < 0.33} { - lappend cfg2 -arrow none - } - - # - # Create a copy of the item on the "printing" canvas. - # - set i2 [eval "$canvw create $t $crds $cfg2"] - $canvw scale $i2 0 0 $tsf $tsf - $canvw move $i2 $dx $dy - - if {($cnt%25) == 0} { - update - } - if {$_reposition == ""} { - return - } - } - - set p $x1 - set i 1 - set vlines {} - while {$i < $_globVar($this,hpc)} { - set p [expr {$p + ($w/$_globVar($this,hpc))}] - set l [$canvw create line $p $y1 $p $y2] - lappend vlines $l - incr i - } - - set p $y1 - set i 1 - set vlines {} - while {$i < $_globVar($this,vpc)} { - set p [expr {$p + ($h/$_globVar($this,vpc))}] - set l [$canvw create line $x1 $p $x2 $p] - lappend vlines $l - incr i - } - - set _reposition "" -} - -# -# Update the attributes to reflect changes made in the user- -# interface. -# -# In: itk_option (attrib) - the attributes to update -# itk_component (attrib) - the widgets -# _globVar (common) - the global var holding the state -# of all radiobuttons and checkboxes. -# Out: - -# -itcl::body iwidgets::Canvasprintbox::_update_attr {{when "later"}} { - if {$when != "now"} { - if {$_update_attr_id == ""} { - set _update_attr_id [after idle [itcl::code $this _update_attr now]] - } - return - } - - set itk_option(-printcmd) $_globVar($this,printeref) - set itk_option(-filename) $_globVar($this,fileef) - set itk_option(-output) $_globVar($this,output) - set itk_option(-pagesize) [string tolower [$itk_component(paperom) get]] - set itk_option(-stretch) $_globVar($this,stretchcb) - set itk_option(-posterize) $_globVar($this,postercb) - set itk_option(-vpagecnt) $_globVar($this,vpc) - set itk_option(-hpagecnt) $_globVar($this,hpc) - set itk_option(-orient) [$itk_component(orientom) get] - set rotate [expr {$itk_option(-orient) == "landscape"}] - - if {$_globVar($this,output) == "file"} { - $itk_component(fileef) configure \ - -state normal -foreground $itk_option(-foreground) - $itk_component(printeref) configure \ - -state disabled -foreground $itk_option(-disabledforeground) - } else { - $itk_component(fileef) configure \ - -state disabled -foreground $itk_option(-disabledforeground) - $itk_component(printeref) configure \ - -state normal -foreground $itk_option(-foreground) - } - - set fg [expr {$_globVar($this,postercb) \ - ? $itk_option(-foreground) : $itk_option(-disabledforeground)}] - - $itk_component(vpcnt) configure -foreground $fg - $itk_component(hpcnt) configure -foreground $fg - $itk_component(pages) configure -foreground $fg - - # - # Update dependencies among widgets. (For example: disabling - # an entry-widget when its associated checkbox-button is used - # to turn of the option (the entry's value is not needed - # anymore and this should be reflected in the fact that it - # isn't possible to change it anymore). - # - # former method:_update_widgets/_update_UI - # - set state [expr {$itk_option(-posterize) ? "normal" : "disabled"}] - $itk_component(vpcnt) configure -state $state - $itk_component(hpcnt) configure -state $state - $itk_component(paperom) select "*[string range $itk_option(-pagesize) 1 end]" - - set _update_attr_id "" -} - -# -# Gets called when the CanvasPrintBox-widget gets mapped. -# -itcl::body iwidgets::Canvasprintbox::_mapEventHandler {} { - set win $itk_interior - set canvw $itk_component(canvas) - if {$canvas != ""} { - setcanvas $canvas - } - _update_attr -} - -# -# Destroy this object and its associated widgets. -# -itcl::body iwidgets::Canvasprintbox::destructor {} { - stop -} - -# -# Hold the information about common paper sizes. A bit of a hack, but it -# should be possible to add your own if you take a look at it. -# -itcl::body iwidgets::Canvasprintbox::ezPaperInfo {size {attr ""} \ - {orient "portrait"} {window ""}} { - - set size [string tolower $size] - set attr [string tolower $attr] - set orient [string tolower $orient] - - case $size in { - types { - return "A5 A4 A3 A2 A1 Legal Letter" - } - a5 { - set paper(x1) "1.0c" - set paper(y1) "1.0c" - set paper(x2) "13.85c" - set paper(y2) "20.0c" - set paper(pheight) "19.0c" - set paper(pwidth) "12.85c" - set paper(height) "21.0c" - set paper(width) "14.85c" - set paper(centerx) "7.425c" - set paper(centery) "10.5c" - } - a4 { - set paper(x1) "1.0c" - set paper(y1) "1.0c" - set paper(x2) "20.0c" - set paper(y2) "28.7c" - set paper(pheight) "27.7c" - set paper(pwidth) "19.0c" - set paper(height) "29.7c" - set paper(width) "21.0c" - set paper(centerx) "10.5c" - set paper(centery) "14.85c" - } - a3 { - set paper(x1) "1.0c" - set paper(y1) "1.0c" - set paper(x2) "28.7c" - set paper(y2) "41.0c" - set paper(pheight) "40.0c" - set paper(pwidth) "27.7c" - set paper(height) "42.0c" - set paper(width) "29.7c" - set paper(centerx) "14.85c" - set paper(centery) "21.0c" - } - a2 { - set paper(x1) "1.0c" - set paper(y1) "1.0c" - set paper(x2) "41.0c" - set paper(y2) "58.4c" - set paper(pheight) "57.4c" - set paper(pwidth) "40.0c" - set paper(height) "59.4c" - set paper(width) "42.0c" - set paper(centerx) "21.0c" - set paper(centery) "29.7c" - } - a1 { - set paper(x1) "1.0c" - set paper(y1) "1.0c" - set paper(x2) "58.4c" - set paper(y2) "83.0c" - set paper(pheight) "82.0c" - set paper(pwidth) "57.4c" - set paper(height) "84.0c" - set paper(width) "59.4c" - set paper(centerx) "29.7c" - set paper(centery) "42.0c" - } - legal { - set paper(x1) "0.2i" - set paper(y1) "0.2i" - set paper(x2) "8.3i" - set paper(y2) "13.8i" - set paper(pheight) "13.6i" - set paper(pwidth) "8.1i" - set paper(height) "14.0i" - set paper(width) "8.5i" - set paper(centerx) "4.25i" - set paper(centery) "7.0i" - } - letter { - set paper(x1) "0.2i" - set paper(y1) "0.2i" - set paper(x2) "8.3i" - set paper(y2) "10.8i" - set paper(pheight) "10.6i" - set paper(pwidth) "8.1i" - set paper(height) "11.0i" - set paper(width) "8.5i" - set paper(centerx) "4.25i" - set paper(centery) "5.5i" - } - default { - error "ezPaperInfo: Unknown paper type ($type)" - } - } - - set inv(x1) "y1" - set inv(x2) "y2" - set inv(y1) "x1" - set inv(y2) "x2" - set inv(pwidth) "pheight" - set inv(pheight) "pwidth" - set inv(width) "height" - set inv(height) "width" - set inv(centerx) "centery" - set inv(centery) "centerx" - - case $orient in { - landscape { - set res $paper($inv($attr)) - } - portrait { - set res $paper($attr) - } - default { - error "ezPaperInfo: orientation should be\ - portrait or landscape (not $orient)" - } - } - - if {$window != ""} { - set res [winfo fpixels $window $res] - } - - return $res -} diff --git a/iwidgets/library/canvasprintdialog.itk b/iwidgets/library/canvasprintdialog.itk deleted file mode 100644 index ddd14cf..0000000 --- a/iwidgets/library/canvasprintdialog.itk +++ /dev/null @@ -1,155 +0,0 @@ -# -# CanvasPrintDialog v1.5 -# ---------------------------------------------------------------------- -# Implements a print dialog for printing the contents of a canvas widget -# to a printer or a file. It is possible to specify page orientation, the -# number of pages to print the image on and if the output should be -# stretched to fit the page. The CanvasPrintDialog is derived from the -# Dialog class and is composed of a CanvasPrintBox with attributes set to -# manipulate the dialog buttons. -# -# ---------------------------------------------------------------------- -# AUTHOR: Tako Schotanus EMAIL: Tako.Schotanus@bouw.tno.nl -# ---------------------------------------------------------------------- -# Copyright (c) 1995 Tako Schotanus -# ====================================================================== -# Permission is hereby granted, without written agreement and without -# license or royalty fees, to use, copy, modify, and distribute this -# software and its documentation for any purpose, provided that the -# above copyright notice and the following two paragraphs appear in -# all copies of this software. -# -# IN NO EVENT SHALL THE COPYRIGHT HOLDER BE LIABLE TO ANY PARTY FOR -# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES -# ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN -# IF THE COPYRIGHT HOLDER HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH -# DAMAGE. -# -# THE COPYRIGHT HOLDER SPECIFICALLY DISCLAIMS ANY WARRANTIES, INCLUDING, -# BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -# FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS -# ON AN "AS IS" BASIS, AND THE COPYRIGHT HOLDER HAS NO OBLIGATION TO -# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. -# ====================================================================== - -# -# Option database default resources: -# -option add *Canvasprintdialog.filename "canvas.ps" widgetDefault -option add *Canvasprintdialog.hPageCnt 1 widgetDefault -option add *Canvasprintdialog.orient landscape widgetDefault -option add *Canvasprintdialog.output printer widgetDefault -option add *Canvasprintdialog.pageSize A4 widgetDefault -option add *Canvasprintdialog.posterize 0 widgetDefault -option add *Canvasprintdialog.printCmd lpr widgetDefault -option add *Canvasprintdialog.printRegion "" widgetDefault -option add *Canvasprintdialog.vPageCnt 1 widgetDefault -option add *Canvasprintdialog.title "Canvas Print Dialog" widgetDefault -option add *Canvasprintdialog.master "." widgetDefault - -# -# Usual options. -# -itk::usual Canvasprintdialog { - keep -background -cursor -foreground -modality -} - -# ------------------------------------------------------------------ -# CANVASPRINTDIALOG -# ------------------------------------------------------------------ -itcl::class iwidgets::Canvasprintdialog { - inherit iwidgets::Dialog - - constructor {args} {} - destructor {} - - method deactivate {args} {} - method getoutput {} {} - method setcanvas {canv} {} - method refresh {} {} - method print {} {} -} - -# -# Provide a lowercased access method for the Canvasprintdialog class. -# -proc ::iwidgets::canvasprintdialog {args} { - uplevel ::iwidgets::Canvasprintdialog $args -} - -# ------------------------------------------------------------------ -# CONSTRUCTOR -# -# Create new file selection dialog. -# ------------------------------------------------------------------ -itcl::body iwidgets::Canvasprintdialog::constructor {args} { - component hull configure -borderwidth 0 - - # - # Instantiate a file selection box widget. - # - itk_component add cpb { - iwidgets::Canvasprintbox $itk_interior.cpb - } { - usual - keep -printregion -output -printcmd -filename -pagesize \ - -orient -stretch -posterize -hpagecnt -vpagecnt - } - pack $itk_component(cpb) -fill both -expand yes - - # - # Hide the apply and help buttons. - # - buttonconfigure OK -text Print - buttonconfigure Apply -command [itcl::code $this refresh] -text Refresh - hide Help - - eval itk_initialize $args -} - -# ------------------------------------------------------------------ -# METHOD: deactivate -# -# Redefines method of dialog shell class. Stops the drawing of the -# thumbnail (when busy) upon deactivation of the dialog. -# ------------------------------------------------------------------ -itcl::body iwidgets::Canvasprintdialog::deactivate {args} { - $itk_component(cpb) stop - return [eval Shell::deactivate $args] -} - -# ------------------------------------------------------------------ -# METHOD: getoutput -# -# Thinwrapped method of canvas print box class. -# ------------------------------------------------------------------ -itcl::body iwidgets::Canvasprintdialog::getoutput {} { - return [$itk_component(cpb) getoutput] -} - -# ------------------------------------------------------------------ -# METHOD: setcanvas -# -# Thinwrapped method of canvas print box class. -# ------------------------------------------------------------------ -itcl::body iwidgets::Canvasprintdialog::setcanvas {canv} { - return [$itk_component(cpb) setcanvas $canv] -} - -# ------------------------------------------------------------------ -# METHOD: refresh -# -# Thinwrapped method of canvas print box class. -# ------------------------------------------------------------------ -itcl::body iwidgets::Canvasprintdialog::refresh {} { - return [$itk_component(cpb) refresh] -} - -# ------------------------------------------------------------------ -# METHOD: print -# -# Thinwrapped method of canvas print box class. -# ------------------------------------------------------------------ -itcl::body iwidgets::Canvasprintdialog::print {} { - return [$itk_component(cpb) print] -} diff --git a/iwidgets/library/checkbox.itk b/iwidgets/library/checkbox.itk deleted file mode 100644 index 49e8888..0000000 --- a/iwidgets/library/checkbox.itk +++ /dev/null @@ -1,341 +0,0 @@ -# -# Checkbox -# ---------------------------------------------------------------------- -# Implements a checkbuttonbox. Supports adding, inserting, deleting, -# selecting, and deselecting of checkbuttons by tag and index. -# -# ---------------------------------------------------------------------- -# AUTHOR: John A. Tucker EMAIL: jatucker@spd.dsccc.com -# -# ---------------------------------------------------------------------- -# Copyright (c) 1997 DSC Technologies Corporation -# ====================================================================== -# Permission to use, copy, modify, distribute and license this software -# and its documentation for any purpose, and without fee or written -# agreement with DSC, is hereby granted, provided that the above copyright -# notice appears in all copies and that both the copyright notice and -# warranty disclaimer below appear in supporting documentation, and that -# the names of DSC Technologies Corporation or DSC Communications -# Corporation not be used in advertising or publicity pertaining to the -# software without specific, written prior permission. -# -# DSC DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING -# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, 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. IN NO EVENT SHALL -# DSC BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR -# ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, -# WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION, -# ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS -# SOFTWARE. -# ====================================================================== - - -# -# Use option database to override default resources of base classes. -# -option add *Checkbox.labelMargin 10 widgetDefault -option add *Checkbox.labelFont \ - "-Adobe-Helvetica-Bold-R-Normal--*-120-*-*-*-*-*-*" widgetDefault -option add *Checkbox.labelPos nw widgetDefault -option add *Checkbox.borderWidth 2 widgetDefault -option add *Checkbox.relief groove widgetDefault - -# -# Usual options. -# -itk::usual Checkbox { - keep -background -borderwidth -cursor -foreground -labelfont -} - -# ------------------------------------------------------------------ -# CHECKBOX -# ------------------------------------------------------------------ -itcl::class iwidgets::Checkbox { - inherit iwidgets::Labeledframe - - constructor {args} {} - - itk_option define -orient orient Orient vertical - - public { - method add {tag args} - method insert {index tag args} - method delete {index} - method get {{index ""}} - method index {index} - method select {index} - method deselect {index} - method flash {index} - method toggle {index} - method buttonconfigure {index args} - } - - private { - - method gettag {index} ;# Get the tag of the checkbutton associated - ;# with a numeric index - - variable _unique 0 ;# Unique id for choice creation. - variable _buttons {} ;# List of checkbutton tags. - common buttonVar ;# Array of checkbutton "-variables" - } -} - -# -# Provide a lowercased access method for the Checkbox class. -# -proc ::iwidgets::checkbox {pathName args} { - uplevel ::iwidgets::Checkbox $pathName $args -} - -# ------------------------------------------------------------------ -# CONSTRUCTOR -# ------------------------------------------------------------------ -itcl::body iwidgets::Checkbox::constructor {args} { - - eval itk_initialize $args -} - -# ------------------------------------------------------------------ -# OPTIONS -# ------------------------------------------------------------------ - -# ------------------------------------------------------------------ -# OPTION: -orient -# -# Allows the user to orient the checkbuttons either horizontally -# or vertically. Added by Chad Smith (csmith@adc.com) 3/10/00. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Checkbox::orient { - if {$itk_option(-orient) == "horizontal"} { - foreach tag $_buttons { - pack $itk_component($tag) -side left -anchor nw -padx 4 -expand 1 - } - } elseif {$itk_option(-orient) == "vertical"} { - foreach tag $_buttons { - pack $itk_component($tag) -side top -anchor w -padx 4 -expand 0 - } - } else { - error "Bad orientation: $itk_option(-orient). Should be\ - \"horizontal\" or \"vertical\"." - } -} - - -# ------------------------------------------------------------------ -# METHODS -# ------------------------------------------------------------------ - -# ------------------------------------------------------------------ -# METHOD: index index -# -# Searches the checkbutton tags in the checkbox for the one with the -# requested tag, numerical index, or keyword "end". Returns the -# choices's numerical index if found, otherwise error. -# ------------------------------------------------------------------ -itcl::body iwidgets::Checkbox::index {index} { - if {[llength $_buttons] > 0} { - if {[regexp {(^[0-9]+$)} $index]} { - if {$index < [llength $_buttons]} { - return $index - } else { - error "Checkbox index \"$index\" is out of range" - } - - } elseif {$index == "end"} { - return [expr {[llength $_buttons] - 1}] - - } else { - if {[set idx [lsearch $_buttons $index]] != -1} { - return $idx - } - - error "bad Checkbox index \"$index\": must be number, end,\ - or pattern" - } - - } else { - error "Checkbox \"$itk_component(hull)\" has no checkbuttons" - } -} - -# ------------------------------------------------------------------ -# METHOD: add tag ?option value option value ...? -# -# Add a new tagged checkbutton to the checkbox at the end. The method -# takes additional options which are passed on to the checkbutton -# constructor. These include most of the typical checkbutton -# options. The tag is returned. -# ------------------------------------------------------------------ -itcl::body iwidgets::Checkbox::add {tag args} { - itk_component add $tag { - eval checkbutton $itk_component(childsite).cb[incr _unique] \ - -variable [list [itcl::scope buttonVar($this,$tag)]] \ - -anchor w \ - -justify left \ - -highlightthickness 0 \ - $args - } { - usual - keep -command -disabledforeground -selectcolor -state - ignore -highlightthickness -highlightcolor - rename -font -labelfont labelFont Font - } - - # Redraw the buttons with the proper orientation. - if {$itk_option(-orient) == "vertical"} { - pack $itk_component($tag) -side top -anchor w -padx 4 -expand 0 - } else { - pack $itk_component($tag) -side left -anchor nw -expand 1 - } - - lappend _buttons $tag - - return $tag -} - -# ------------------------------------------------------------------ -# METHOD: insert index tag ?option value option value ...? -# -# Insert the tagged checkbutton in the checkbox just before the -# one given by index. Any additional options are passed on to the -# checkbutton constructor. These include the typical checkbutton -# options. The tag is returned. -# ------------------------------------------------------------------ -itcl::body iwidgets::Checkbox::insert {index tag args} { - itk_component add $tag { - eval checkbutton $itk_component(childsite).cb[incr _unique] \ - -variable [list [itcl::scope buttonVar($this,$tag)]] \ - -anchor w \ - -justify left \ - -highlightthickness 0 \ - $args - } { - usual - ignore -highlightthickness -highlightcolor - rename -font -labelfont labelFont Font - } - - set index [index $index] - set before [lindex $_buttons $index] - set _buttons [linsert $_buttons $index $tag] - - pack $itk_component($tag) -anchor w -padx 4 -before $itk_component($before) - - return $tag -} - -# ------------------------------------------------------------------ -# METHOD: delete index -# -# Delete the specified checkbutton. -# ------------------------------------------------------------------ -itcl::body iwidgets::Checkbox::delete {index} { - - set tag [gettag $index] - set index [index $index] - destroy $itk_component($tag) - set _buttons [lreplace $_buttons $index $index] - - if { [info exists buttonVar($this,$tag)] == 1 } { - unset buttonVar($this,$tag) - } -} - -# ------------------------------------------------------------------ -# METHOD: select index -# -# Select the specified checkbutton. -# ------------------------------------------------------------------ -itcl::body iwidgets::Checkbox::select {index} { - set tag [gettag $index] - #----------------------------------------------------------- - # BUG FIX: csmith (Chad Smith: csmith@adc.com), 3/30/99 - #----------------------------------------------------------- - # This method should only invoke the checkbutton if it's not - # already selected. Check its associated variable, and if - # it's set, then just ignore and return. - #----------------------------------------------------------- - if {[set [itcl::scope buttonVar($this,$tag)]] == - [[component $tag] cget -onvalue]} { - return - } - $itk_component($tag) invoke -} - -# ------------------------------------------------------------------ -# METHOD: toggle index -# -# Toggle a specified checkbutton between selected and unselected -# ------------------------------------------------------------------ -itcl::body iwidgets::Checkbox::toggle {index} { - set tag [gettag $index] - $itk_component($tag) toggle -} - -# ------------------------------------------------------------------ -# METHOD: get -# -# Return the value of the checkbutton with the given index, or a -# list of all checkbutton values in increasing order by index. -# ------------------------------------------------------------------ -itcl::body iwidgets::Checkbox::get {{index ""}} { - set result {} - - if {$index == ""} { - foreach tag $_buttons { - if {$buttonVar($this,$tag)} { - lappend result $tag - } - } - } else { - set tag [gettag $index] - set result $buttonVar($this,$tag) - } - - return $result -} - -# ------------------------------------------------------------------ -# METHOD: deselect index -# -# Deselect the specified checkbutton. -# ------------------------------------------------------------------ -itcl::body iwidgets::Checkbox::deselect {index} { - set tag [gettag $index] - $itk_component($tag) deselect -} - -# ------------------------------------------------------------------ -# METHOD: flash index -# -# Flash the specified checkbutton. -# ------------------------------------------------------------------ -itcl::body iwidgets::Checkbox::flash {index} { - set tag [gettag $index] - $itk_component($tag) flash -} - -# ------------------------------------------------------------------ -# METHOD: buttonconfigure index ?option? ?value option value ...? -# -# Configure a specified checkbutton. This method allows configuration -# of checkbuttons from the Checkbox level. The options may have any -# of the values accepted by the add method. -# ------------------------------------------------------------------ -itcl::body iwidgets::Checkbox::buttonconfigure {index args} { - set tag [gettag $index] - eval $itk_component($tag) configure $args -} - -# ------------------------------------------------------------------ -# METHOD: gettag index -# -# Return the tag of the checkbutton associated with a specified -# numeric index -# ------------------------------------------------------------------ -itcl::body iwidgets::Checkbox::gettag {index} { - return [lindex $_buttons [index $index]] -} diff --git a/iwidgets/library/colors.itcl b/iwidgets/library/colors.itcl deleted file mode 100644 index c7b7c33..0000000 --- a/iwidgets/library/colors.itcl +++ /dev/null @@ -1,209 +0,0 @@ -# -# colors -# ---------------------------------------------------------------------- -# The colors class encapsulates several color related utility functions. -# Class level scope resolution must be used inorder to access the static -# member functions. -# -# USAGE: -# set hsb [colors::rgbToHsb [winfo rgb . bisque]] -# -# ---------------------------------------------------------------------- -# AUTHOR: Mark L. Ulferts EMAIL: mulferts@spd.dsccc.com -# -# @(#) $Id: colors.itcl,v 1.2 2001/08/15 18:33:55 smithc Exp $ -# ---------------------------------------------------------------------- -# Copyright (c) 1995 Mark L. Ulferts -# ====================================================================== -# Permission is hereby granted, without written agreement and without -# license or royalty fees, to use, copy, modify, and distribute this -# software and its documentation for any purpose, provided that the -# above copyright notice and the following two paragraphs appear in -# all copies of this software. -# -# IN NO EVENT SHALL THE COPYRIGHT HOLDER BE LIABLE TO ANY PARTY FOR -# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES -# ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN -# IF THE COPYRIGHT HOLDER HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH -# DAMAGE. -# -# THE COPYRIGHT HOLDER SPECIFICALLY DISCLAIMS ANY WARRANTIES, INCLUDING, -# BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -# FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS -# ON AN "AS IS" BASIS, AND THE COPYRIGHT HOLDER HAS NO OBLIGATION TO -# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. -# ====================================================================== - -namespace eval iwidgets::colors { - - # ------------------------------------------------------------------ - # PROCEDURE: rgbToNumeric - # - # Returns the numeric value for a list of red, green, and blue. - # ------------------------------------------------------------------ - proc rgbToNumeric {rgb} { - if {[llength $rgb] != 3} { - error "bad arg: \"$rgb\", should be list of red, green, and blue" - } - - return [format "#%04x%04x%04x" \ - [lindex $rgb 0] [lindex $rgb 1] [lindex $rgb 2]] - } - - # ------------------------------------------------------------------ - # PROCEDURE: rgbToHsb - # - # 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 rgbToHsb {rgb} { - if {[llength $rgb] != 3} { - error "bad arg: \"$rgb\", should be list of red, green, and blue" - } - - set r [expr {[lindex $rgb 0]/65535.0}] - set g [expr {[lindex $rgb 1]/65535.0}] - set b [expr {[lindex $rgb 2]/65535.0}] - - set max 0 - if {$r > $max} {set max $r} - if {$g > $max} {set max $g} - if {$b > $max} {set max $b} - - set min 65535 - if {$r < $min} {set min $r} - if {$g < $min} {set min $g} - if {$b < $min} {set min $b} - - if {$max != 0} { - set sat [expr {($max-$min)/$max}] - } else { - set sat 0 - } - if {$sat == 0} { - set hue 0 - } else { - set rc [expr {($max-$r)/($max-$min)}] - set gc [expr {($max-$g)/($max-$min)}] - set bc [expr {($max-$b)/($max-$min)}] - - if {$r == $max} { - set hue [expr {$bc-$gc}] - } elseif {$g == $max} { - set hue [expr {2+$rc-$bc}] - } elseif {$b == $max} { - set hue [expr {4+$gc-$rc}] - } - set hue [expr {$hue*0.1666667}] - if {$hue < 0} {set hue [expr {$hue+1.0}]} - } - return [list $hue $sat $max] - } - - # ------------------------------------------------------------------ - # PROCEDURE: hsbToRgb - # - # 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 {hsb} { - - if {[llength $hsb] != 3} { - error "bad arg: \"$hsb\", should be list of hue, saturation, and brightness" - } - - set hue [lindex $hsb 0] - set sat [lindex $hsb 1] - set value [lindex $hsb 2] - - set v [format %.0f [expr {65535.0*$value}]] - if {$sat == 0} { - return "$v $v $v" - } else { - set hue [expr {$hue*6.0}] - if {$hue >= 6.0} { - set hue 0.0 - } - scan $hue. %d i - set f [expr {$hue-$i}] - set p [format %.0f [expr {65535.0*$value*(1 - $sat)}]] - set q [format %.0f [expr {65535.0*$value*(1 - ($sat*$f))}]] - set t [format %.0f [expr {65535.0*$value*(1 - ($sat*(1 - $f)))}]] - case $i \ - 0 {return "$v $t $p"} \ - 1 {return "$q $v $p"} \ - 2 {return "$p $v $t"} \ - 3 {return "$p $q $v"} \ - 4 {return "$t $p $v"} \ - 5 {return "$v $p $q"} - error "i value $i is out of range" - } - } - - # ------------------------------------------------------------------ - # - # PROCEDURE: topShadow bgColor - # - # This method computes a lighter shadow variant of bgColor. - # It wants to decrease the saturation to 25%. But if there is - # no saturation (as in gray colors) it tries to turn the - # brightness up by 10%. It maxes the brightness at 1.0 to - # avoid bogus colors... - # - # bgColor is converted to HSB where the calculations are - # made. Then converted back to an rgb color number (hex fmt) - # - # ------------------------------------------------------------------ - proc topShadow { bgColor } { - - set hsb [rgbToHsb [winfo rgb . $bgColor]] - - set saturation [lindex $hsb 1] - set brightness [lindex $hsb 2] - - if { $brightness < 0.9 } { - # try turning the brightness up first. - set brightness [expr {$brightness * 1.1}] - } else { - # otherwise fiddle with saturation - set saturation [expr {$saturation * 0.25}] - } - - set hsb [lreplace $hsb 1 1 [set saturation]] - set hsb [lreplace $hsb 2 2 [set brightness]] - - set rgb [hsbToRgb $hsb] - set color [rgbToNumeric $rgb] - return $color - } - - - # ------------------------------------------------------------------ - # - # PROC: bottomShadow bgColor - # - # - # This method computes a darker shadow variant of bg color. - # It takes the brightness and decreases it to 80% of its - # original value. - # - # bgColor is converted to HSB where the calculations are - # made. Then converted back to an rgb color number (hex fmt) - # - # ------------------------------------------------------------------ - proc bottomShadow { bgColor } { - - set hsb [rgbToHsb [winfo rgb . $bgColor]] - set hsb [lreplace $hsb 2 2 [expr {[lindex $hsb 2] * 0.8}]] - set rgb [hsbToRgb $hsb] - set color [rgbToNumeric $rgb] - return $color - } -} diff --git a/iwidgets/library/combobox.itk b/iwidgets/library/combobox.itk deleted file mode 100644 index b7d5f18..0000000 --- a/iwidgets/library/combobox.itk +++ /dev/null @@ -1,1446 +0,0 @@ -# Combobox -# ---------------------------------------------------------------------- -# Implements a Combobox widget. A Combobox has 2 basic styles: simple and -# dropdown. Dropdowns display an entry field with an arrow button to the -# right of it. When the arrow button is pressed a selectable list of -# items is popped up. A simple Combobox displays an entry field and a listbox -# just beneath it which is always displayed. In both types, if the user -# selects an item in the listbox, the contents of the entry field are -# replaced with the text from the selected item. If the Combobox is -# editable, the user can type in the entry field and when is -# pressed the item will be inserted into the list. -# -# WISH LIST: -# This section lists possible future enhancements. -# -# Combobox 1.x: -# - convert bindings to bindtags. -# -# ---------------------------------------------------------------------- -# ORIGINAL AUTHOR: John S. Sigler -# ---------------------------------------------------------------------- -# CURRENT MAINTAINER: Chad Smith EMAIL: csmith@adc.com, itclguy@yahoo.com -# -# Copyright (c) 1995 John S. Sigler -# Copyright (c) 1997 Mitch Gorman -# ====================================================================== -# Permission is hereby granted, without written agreement and without -# license or royalty fees, to use, copy, modify, and distribute this -# software and its documentation for any purpose, provided that the -# above copyright notice and the following two paragraphs appear in -# all copies of this software. -# -# IN NO EVENT SHALL THE COPYRIGHT HOLDER BE LIABLE TO ANY PARTY FOR -# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES -# ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN -# IF THE COPYRIGHT HOLDER HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH -# DAMAGE. -# -# THE COPYRIGHT HOLDER SPECIFICALLY DISCLAIMS ANY WARRANTIES, INCLUDING, -# BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -# FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS -# ON AN "AS IS" BASIS, AND THE COPYRIGHT HOLDER HAS NO OBLIGATION TO -# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. -# ====================================================================== - -# -# Default resources. -# -option add *Combobox.borderWidth 2 widgetDefault -option add *Combobox.labelPos wn widgetDefault -option add *Combobox.listHeight 150 widgetDefault -option add *Combobox.hscrollMode dynamic widgetDefault -option add *Combobox.vscrollMode dynamic widgetDefault - -# -# Usual options. -# -itk::usual Combobox { - keep -background -borderwidth -cursor -foreground -highlightcolor \ - -highlightthickness -insertbackground -insertborderwidth \ - -insertofftime -insertontime -insertwidth -labelfont -popupcursor \ - -selectbackground -selectborderwidth -selectforeground \ - -textbackground -textfont -} - -# ------------------------------------------------------------------ -# COMBOBOX -# ------------------------------------------------------------------ -itcl::class iwidgets::Combobox { - inherit iwidgets::Entryfield - - constructor {args} {} - destructor {} - - itk_option define -arrowrelief arrowRelief Relief raised - itk_option define -completion completion Completion true - itk_option define -dropdown dropdown Dropdown true - itk_option define -editable editable Editable true - itk_option define -grab grab Grab local - itk_option define -listheight listHeight Height 150 - itk_option define -margin margin Margin 1 - itk_option define -popupcursor popupCursor Cursor arrow - itk_option define -selectioncommand selectionCommand SelectionCommand {} - itk_option define -state state State normal - itk_option define -unique unique Unique true - - public method clear {{component all}} - public method curselection {} - public method delete {component first {last {}}} - public method get {{index {}}} - public method getcurselection {} - public method insert {component index args} - public method invoke {} - public method justify {direction} - public method see {index} - public method selection {option first {last {}}} - public method size {} - public method sort {{mode ascending}} - public method xview {args} - public method yview {args} - - protected method _addToList {} - protected method _createComponents {} - protected method _deleteList {first {last {}}} - protected method _deleteText {first {last {}}} - protected method _doLayout {{when later}} - protected method _drawArrow {} - protected method _dropdownBtnRelease {{window {}} {x 1} {y 1}} - protected method _ignoreNextBtnRelease {ignore} - protected method _next {} - protected method _packComponents {{when later}} - protected method _positionList {} - protected method _postList {} - protected method _previous {} - protected method _resizeArrow {} - protected method _selectCmd {} - protected method _toggleList {} - protected method _unpostList {} - protected method _commonBindings {} - protected method _dropdownBindings {} - protected method _simpleBindings {} - protected method _listShowing {{val ""}} - - private method _bs {} - private method _lookup {key} - private method _slbListbox {} - private method _stateSelect {} - - private variable _doit 0; - private variable _inbs 0; - private variable _inlookup 0; - private variable _currItem {}; ;# current selected item. - private variable _ignoreRelease false ;# next button release ignored. - private variable _isPosted false; ;# is the dropdown popped up. - private variable _repacking {} ;# non-null => _packComponents pending. - private variable _grab ;# used to restore grabs - private variable _next_prevFLAG 0 ;# Used in _lookup to fix SF Bug 501300 - private common _listShowing - private common count 0 -} - -# -# Provide a lowercase access method for the Combobox class. -# -proc ::iwidgets::combobox {pathName args} { - uplevel ::iwidgets::Combobox $pathName $args -} - -# ------------------------------------------------------------------ -# CONSTRUCTOR -# ------------------------------------------------------------------ -itcl::body iwidgets::Combobox::constructor {args} { - set _listShowing($this) 0 - set _grab(window) "" - set _grab(status) "" - - # combobox is different as all components are created - # after determining what the dropdown style is... - - # configure args - eval itk_initialize $args - - # create components that are dependent on options - # (Scrolledlistbox, arrow button) and pack them. - if {$count == 0} { - image create bitmap downarrow -data { - #define down_width 16 - #define down_height 16 - static unsigned char down_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0xfc, 0x7f, 0xf8, 0x3f, - 0xf0, 0x1f, 0xe0, 0x0f, 0xc0, 0x07, 0x80, 0x03, - 0x00, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00 - }; - } - image create bitmap uparrow -data { - #define up_width 16 - #define up_height 16 - static unsigned char up_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x00, - 0xc0, 0x01, 0xe0, 0x03, 0xf0, 0x07, 0xf8, 0x0f, - 0xfc, 0x1f, 0xfe, 0x3f, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00 - }; - } - } - incr count - _doLayout -} - -# ------------------------------------------------------------------ -# DESTRUCTOR -# ------------------------------------------------------------------ -itcl::body iwidgets::Combobox::destructor {} { - # catch any repacking that may be waiting for idle time - if {$_repacking != ""} { - after cancel $_repacking - } - incr count -1 - if {$count == 0} { - image delete uparrow - image delete downarrow - } -} - -# ================================================================ -# OPTIONS -# ================================================================ - -# -------------------------------------------------------------------- -# OPTION: -arrowrelief -# -# Relief style used on the arrow button. -# -------------------------------------------------------------------- -itcl::configbody iwidgets::Combobox::arrowrelief {} - -# -------------------------------------------------------------------- -# OPTION: -completion -# -# Relief style used on the arrow button. -# -------------------------------------------------------------------- -itcl::configbody iwidgets::Combobox::completion { - switch -- $itk_option(-completion) { - 0 - no - false - off { } - 1 - yes - true - on { } - default { - error "bad completion option \"$itk_option(-completion)\":\ - should be boolean" - } - } -} - -# -------------------------------------------------------------------- -# OPTION: -dropdown -# -# Boolean which determines the Combobox style: dropdown or simple. -# Because the two style's lists reside in different toplevel widgets -# this is more complicated than it should be. -# -------------------------------------------------------------------- -itcl::configbody iwidgets::Combobox::dropdown { - switch -- $itk_option(-dropdown) { - 1 - yes - true - on { - if {[winfo exists $itk_interior.list]} { - set vals [$itk_component(list) get 0 end] - destroy $itk_component(list) - _doLayout - if [llength $vals] { - eval insert list end $vals - } - } - } - 0 - no - false - off { - if {[winfo exists $itk_interior.popup.list]} { - set vals [$itk_component(list) get 0 end] - catch {destroy $itk_component(arrowBtn)} - destroy $itk_component(popup) ;# this deletes the list too - _doLayout - if [llength $vals] { - eval insert list end $vals - } - } - } - default { - error "bad dropdown option \"$itk_option(-dropdown)\":\ - should be boolean" - } - } -} - -# -------------------------------------------------------------------- -# OPTION: -editable -# -# Boolean which allows/disallows user input to the entry field area. -# -------------------------------------------------------------------- -itcl::configbody iwidgets::Combobox::editable { - switch -- $itk_option(-editable) { - 1 - true - yes - on { - switch -- $itk_option(-state) { - normal { - $itk_component(entry) configure -state normal - } - } - } - 0 - false - no - off { - $itk_component(entry) configure -state readonly - } - default { - error "bad editable option \"$itk_option(-editable)\":\ - should be boolean" - } - } -} - -# -------------------------------------------------------------------- -# OPTION: -grab -# -# grab-state of megawidget -# -------------------------------------------------------------------- -itcl::configbody iwidgets::Combobox::grab { - switch -- $itk_option(-grab) { - local { } - global { } - default { - error "bad grab value \"$itk_option(-grab)\":\ - must be global or local" - } - } -} - -# -------------------------------------------------------------------- -# OPTION: -listheight -# -# Listbox height in pixels. (Need to integrate the scrolledlistbox -# -visibleitems option here - at least for simple listbox.) -# -------------------------------------------------------------------- -itcl::configbody iwidgets::Combobox::listheight {} - -# -------------------------------------------------------------------- -# OPTION: -margin -# -# Spacer between the entry field and arrow button of dropdown style -# Comboboxes. -# -------------------------------------------------------------------- -itcl::configbody iwidgets::Combobox::margin { - grid columnconfigure $itk_interior 0 -minsize $itk_option(-margin) -} - -# -------------------------------------------------------------------- -# OPTION: -popupcursor -# -# Set the cursor for the popup list. -# -------------------------------------------------------------------- -itcl::configbody iwidgets::Combobox::popupcursor {} - -# -------------------------------------------------------------------- -# OPTION: -selectioncommand -# -# Defines the proc to be called when an item is selected in the list. -# -------------------------------------------------------------------- -itcl::configbody iwidgets::Combobox::selectioncommand {} - -# -------------------------------------------------------------------- -# OPTION: -state -# -# overall state of megawidget -# -------------------------------------------------------------------- -itcl::configbody iwidgets::Combobox::state { - switch -- $itk_option(-state) { - disabled { - $itk_component(entry) configure -state disabled - } - normal { - switch -- $itk_option(-editable) { - 1 - true - yes - on { - $itk_component(entry) configure -state normal - } - 0 - false - no - off { - $itk_component(entry) configure -state readonly - } - } - } - readonly { - $itk_component(entry) configure -state readonly - } - default { - error "bad state value \"$itk_option(-state)\":\ - must be normal or disabled" - } - } - if {[info exists itk_component(arrowBtn)]} { - $itk_component(arrowBtn) configure -state $itk_option(-state) - } -} - -# -------------------------------------------------------------------- -# OPTION: -unique -# -# Boolean which disallows/allows adding duplicate items to the listbox. -# -------------------------------------------------------------------- -itcl::configbody iwidgets::Combobox::unique { - # boolean error check - switch -- $itk_option(-unique) { - 1 - true - yes - on { } - 0 - false - no - off { } - default { - error "bad unique value \"$itk_option(-unique)\":\ - should be boolean" - } - } -} - -# ================================================================= -# METHODS -# ================================================================= - -# ------------------------------------------------------ -# PUBLIC METHOD: clear ?component? -# -# Remove all elements from the listbox, all contents -# from the entry component, or both (if all). -# -# ------------------------------------------------------ -itcl::body iwidgets::Combobox::clear {{component all}} { - switch -- $component { - entry { - iwidgets::Entryfield::clear - } - list { - delete list 0 end - } - all { - delete list 0 end - iwidgets::Entryfield::clear - } - default { - error "bad Combobox component \"$component\":\ - must be entry, list, or all." - } - } - return -} - -# ------------------------------------------------------ -# PUBLIC METHOD: curselection -# -# Return the current selection index. -# -# ------------------------------------------------------ -itcl::body iwidgets::Combobox::curselection {} { - return [$itk_component(list) curselection] -} - -# ------------------------------------------------------ -# PUBLIC METHOD: delete component first ?last? -# -# Delete an item or items from the listbox OR delete -# text from the entry field. First argument determines -# which component deletion occurs in - valid values are -# entry or list. -# -# ------------------------------------------------------ -itcl::body iwidgets::Combobox::delete {component first {last {}}} { - switch -- $component { - entry { - if {$last == {}} { - set last [expr {$first + 1}] - } - iwidgets::Entryfield::delete $first $last - } - list { - _deleteList $first $last - } - default { - error "bad Combobox component \"$component\":\ - must be entry or list." - } - } -} - -# ------------------------------------------------------ -# PUBLIC METHOD: get ?index? -# -# -# Retrieve entry contents if no args OR use args as list -# index and retrieve list item at index . -# -# ------------------------------------------------------ -itcl::body iwidgets::Combobox::get {{index {}}} { - # no args means to get the current text in the entry field area - if {$index == {}} { - iwidgets::Entryfield::get - } else { - eval $itk_component(list) get $index - } -} - -# ------------------------------------------------------ -# PUBLIC METHOD: getcurselection -# -# Return currently selected item in the listbox. Shortcut -# version of get curselection command combination. -# -# ------------------------------------------------------ -itcl::body iwidgets::Combobox::getcurselection {} { - return [$itk_component(list) getcurselection] -} - -# ------------------------------------------------------------------ -# PUBLIC METHOD: invoke -# -# Pops up or down a dropdown combobox. -# -# ------------------------------------------------------------------ -itcl::body iwidgets::Combobox::invoke {} { - if {$itk_option(-dropdown)} { - return [_toggleList] - } - return -} - -# ------------------------------------------------------------ -# PUBLIC METHOD: insert comonent index string ?string ...? -# -# Insert an item into the listbox OR text into the entry area. -# Valid component names are entry or list. -# -# ------------------------------------------------------------ -itcl::body iwidgets::Combobox::insert {component index args} { - set nargs [llength $args] - - if {$nargs == 0} { - error "no value given for parameter \"string\" in function\ - \"Combobox::insert\"" - } - - switch -- $component { - entry { - if { $nargs > 1} { - error "called function \"Combobox::insert entry\"\ - with too many arguments" - } else { - if {$itk_option(-state) == "normal"} { - eval iwidgets::Entryfield::insert $index $args - #RZ [itcl::code $this _lookup ""] - eval [itcl::code $this _lookup ""] - } - } - } - list { - if {$itk_option(-state) == "normal"} { - eval $itk_component(list) insert $index $args - } - } - default { - error "bad Combobox component \"$component\": must\ - be entry or list." - } - } -} - -# ------------------------------------------------------ -# PUBLIC METHOD: justify direction -# -# Wrapper for justifying the listbox items in one of -# 4 directions: top, bottom, left, or right. -# -# ------------------------------------------------------ -itcl::body iwidgets::Combobox::justify {direction} { - return [$itk_component(list) justify $direction] -} - -# ------------------------------------------------------------------ -# PUBLIC METHOD: see index -# -# Adjusts the view such that the element given by index is visible. -# ------------------------------------------------------------------ -itcl::body iwidgets::Combobox::see {index} { - return [$itk_component(list) see $index] -} - -# ------------------------------------------------------------------ -# PUBLIC METHOD: selection option first ?last? -# -# Adjusts the selection within the listbox and changes the contents -# of the entry component to be the value of the selected list item. -# ------------------------------------------------------------------ -itcl::body iwidgets::Combobox::selection {option first {last {}}} { - # thin wrap - if {$option == "set"} { - $itk_component(list) selection clear 0 end - $itk_component(list) selection set $first - set rtn "" - } else { - set rtn [eval $itk_component(list) selection $option $first $last] - } - set _currItem $first - - # combobox additions - set theText [getcurselection] - if {$theText != [$itk_component(entry) get]} { - clear entry - if {$theText != ""} { - insert entry 0 $theText - } - } - return $rtn -} - -# ------------------------------------------------------------------ -# PUBLIC METHOD: size -# -# Returns a decimal string indicating the total number of elements -# in the listbox. -# ------------------------------------------------------------------ -itcl::body iwidgets::Combobox::size {} { - return [$itk_component(list) size] -} - -# ------------------------------------------------------ -# PUBLIC METHOD: sort ?mode? -# -# Sort the current list in either "ascending" or "descending" order. -# -# jss: how should i handle selected items? -# -# ------------------------------------------------------ -itcl::body iwidgets::Combobox::sort {{mode ascending}} { - $itk_component(list) sort $mode - # return [$itk_component(list) sort $mode] -} - - -# ------------------------------------------------------------------ -# PUBLIC METHOD: xview ?arg arg ...? -# -# Change or query the vertical position of the text in the list box. -# ------------------------------------------------------------------ -itcl::body iwidgets::Combobox::xview {args} { - return [eval $itk_component(list) xview $args] -} - -# ------------------------------------------------------------------ -# PUBLIC METHOD: yview ?arg arg ...? -# -# Change or query the horizontal position of the text in the list box. -# ------------------------------------------------------------------ -itcl::body iwidgets::Combobox::yview {args} { - return [eval $itk_component(list) yview $args] -} - -# ------------------------------------------------------ -# PROTECTED METHOD: _addToList -# -# Add the current item in the entry to the listbox. -# -# ------------------------------------------------------ -itcl::body iwidgets::Combobox::_addToList {} { - set input [get] - if {$input != ""} { - if {$itk_option(-unique)} { - # if item is already in list, select it and exit - set item [lsearch -exact [$itk_component(list) get 0 end] $input] - if {$item != -1} { - selection clear 0 end - if {$item != {}} { - selection set $item $item - set _currItem $item - } - return - } - } - # add the item to end of list - selection clear 0 end - insert list end $input - selection set end end - } -} - -# ------------------------------------------------------ -# PROTECTED METHOD: _createComponents -# -# Create deferred combobox components and add bindings. -# -# ------------------------------------------------------ -itcl::body iwidgets::Combobox::_createComponents {} { - if {$itk_option(-dropdown)} { - # --- build a dropdown combobox --- - - # make the arrow childsite be on the right hand side - - #------------------------------------------------------------- - # BUG FIX: csmith (Chad Smith: csmith@adc.com), 3/4/99 - #------------------------------------------------------------- - # The following commented line of code overwrites the -command - # option when passed into the constructor. The order of calls - # in the constructor is: - # 1) eval itk_initalize $args (initializes -command) - # 2) _doLayout - # 3) _createComponents (overwrites -command) - # The solution is to only set the -command option if it hasn't - # already been set. The following 4 lines of code do this. - #------------------------------------------------------------- - # ** configure -childsitepos e -command [code $this _addToList] - #------------------------------------------------------------- - configure -childsitepos e - if ![llength [cget -command]] { - configure -command [itcl::code $this _addToList] - } - - # arrow button to popup the list - itk_component add arrowBtn { - button $itk_interior.arrowBtn -borderwidth 2 \ - -width 15 -height 15 -image downarrow \ - -command [itcl::code $this _toggleList] -state $itk_option(-state) - } { - keep -background -borderwidth -cursor -state \ - -highlightcolor -highlightthickness - rename -relief -arrowrelief arrowRelief Relief - rename -highlightbackground -background background Background - } - - # popup list container - itk_component add popup { - toplevel $itk_interior.popup - } { - keep -background -cursor - } - wm withdraw $itk_interior.popup - - # the listbox - itk_component add list { - iwidgets::Scrolledlistbox $itk_interior.popup.list -exportselection no \ - -vscrollmode dynamic -hscrollmode dynamic -selectmode browse - } { - keep -background -borderwidth -cursor -foreground \ - -highlightcolor -highlightthickness \ - -hscrollmode -selectbackground \ - -selectborderwidth -selectforeground -textbackground \ - -textfont -vscrollmode - rename -height -listheight listHeight Height - rename -cursor -popupcursor popupCursor Cursor - } - # mode specific bindings - _dropdownBindings - - # Ugly hack to avoid tk buglet revealed in _dropdownBtnRelease where - # relief is used but not set in scrollbar.tcl. - global tkPriv - set tkPriv(relief) raise - - } else { - # --- build a simple combobox --- - configure -childsitepos s - itk_component add list { - iwidgets::Scrolledlistbox $itk_interior.list -exportselection no \ - -vscrollmode dynamic -hscrollmode dynamic - } { - keep -background -borderwidth -cursor -foreground \ - -highlightcolor -highlightthickness \ - -hscrollmode -selectbackground \ - -selectborderwidth -selectforeground -textbackground \ - -textfont -visibleitems -vscrollmode - rename -height -listheight listHeight Height - } - # add mode specific bindings - _simpleBindings - } - - # popup cursor applies only to the list within the combobox - configure -popupcursor $itk_option(-popupcursor) - - # add mode independent bindings - _commonBindings -} - -# ------------------------------------------------------ -# PROTECTED METHOD: _deleteList first ?last? -# -# Delete an item or items from the listbox. Called via -# "delete list args". -# -# ------------------------------------------------------ -itcl::body iwidgets::Combobox::_deleteList {first {last {}}} { - - if {$last == {}} { - set last $first - } - $itk_component(list) delete $first $last - - # remove the item if it is no longer in the list - set text [$this get] - if {$text != ""} { - set index [lsearch -exact [$itk_component(list) get 0 end] $text ] - if {$index == -1} { - clear entry - } - } - return -} - -# ------------------------------------------------------ -# PROTECTED METHOD: _deleteText first ?last? -# -# Renamed Entryfield delete method. Called via "delete entry args". -# -# ------------------------------------------------------ -itcl::body iwidgets::Combobox::_deleteText {first {last {}}} { - $itk_component(entry) configure -state normal - set rtrn [delete $first $last] - switch -- $itk_option(-editable) { - 0 - false - no - off { - $itk_component(entry) configure -state readonly - } - } - return $rtrn -} - -# ------------------------------------------------------ -# PROTECTED METHOD: _doLayout ?when? -# -# Call methods to create and pack the Combobox components. -# -# ------------------------------------------------------ -itcl::body iwidgets::Combobox::_doLayout {{when later}} { - _createComponents - _packComponents $when -} - - -# ------------------------------------------------------ -# PROTECTED METHOD: _drawArrow -# -# Draw the arrow button. Determines packing according to -# -labelpos. -# -# ------------------------------------------------------ -itcl::body iwidgets::Combobox::_drawArrow {} { - set flip false - set relief "" - set fg [cget -foreground] - if {$_isPosted} { - set flip true - set relief "-relief sunken" - } else { - set relief "-relief $itk_option(-arrowrelief)" - } - - if {$flip} { - # - # draw up arrow - # - eval $itk_component(arrowBtn) configure -image uparrow $relief - } else { - # - # draw down arrow - # - eval $itk_component(arrowBtn) configure -image downarrow $relief - } -} - -# ------------------------------------------------------ -# PROTECTED METHOD: _dropdownBtnRelease window x y -# -# Event handler for button releases while a dropdown list -# is posted. -# -# ------------------------------------------------------ -itcl::body iwidgets::Combobox::_dropdownBtnRelease {{window {}} {x 1} {y 1}} { - - # if it's a scrollbar then ignore the release - if {($window == [$itk_component(list) component vertsb]) || - ($window == [$itk_component(list) component horizsb])} { - return - } - - # 1st release allows list to stay up unless we are in listbox - if {$_ignoreRelease} { - _ignoreNextBtnRelease false - return - } - - # should I use just the listbox or also include the scrollbars - if { ($x >= 0) && ($x < [winfo width [_slbListbox]]) - && ($y >= 0) && ($y < [winfo height [_slbListbox]])} { - _stateSelect - } - - _unpostList - - # execute user command - if {$itk_option(-selectioncommand) != ""} { - uplevel #0 $itk_option(-selectioncommand) - } -} - -# ------------------------------------------------------ -# PROTECTED METHOD: _ignoreNextBtnRelease ignore -# -# Set private variable _ignoreRelease. If this variable -# is true then the next button release will not remove -# a dropdown list. -# -# ------------------------------------------------------ -itcl::body iwidgets::Combobox::_ignoreNextBtnRelease {ignore} { - set _ignoreRelease $ignore -} - -# ------------------------------------------------------ -# PROTECTED METHOD: _next -# -# Select the next item in the list. -# -# ------------------------------------------------------ -itcl::body iwidgets::Combobox::_next {} { - - set _next_prevFLAG 1 - - if {[size] <= 1} { - return - } - set i [curselection] - if {($i == {}) || ($i == ([size]-1)) } { - set i 0 - } else { - incr i - } - selection clear 0 end - selection set $i $i - see $i - set _currItem $i -} - -# ------------------------------------------------------ -# PROTECTED METHOD: _packComponents ?when? -# -# Pack the components of the combobox and add bindings. -# -# ------------------------------------------------------ -itcl::body iwidgets::Combobox::_packComponents {{when later}} { - if {$when == "later"} { - if {$_repacking == ""} { - set _repacking [after idle [itcl::code $this _packComponents now]] - return - } - } elseif {$when != "now"} { - error "bad option \"$when\": should be now or later" - } - - if {$itk_option(-dropdown)} { - grid configure $itk_component(list) -row 1 -column 0 -sticky news - _resizeArrow - grid config $itk_component(arrowBtn) -row 0 -column 1 -sticky nsew - } else { - # size and pack list hack - grid configure $itk_component(entry) -row 0 -column 0 -sticky ew - grid configure $itk_component(efchildsite) -row 1 -column 0 -sticky nsew - grid configure $itk_component(list) -row 0 -column 0 -sticky nsew - - grid rowconfigure $itk_component(efchildsite) 1 -weight 1 - grid columnconfigure $itk_component(efchildsite) 0 -weight 1 - } - set _repacking "" -} - -# ------------------------------------------------------ -# PROTECTED METHOD: _positionList -# -# Determine the position (geometry) for the popped up list -# and map it to the screen. -# -# ------------------------------------------------------ -itcl::body iwidgets::Combobox::_positionList {} { - - set x [winfo rootx $itk_component(entry) ] - set y [expr {[winfo rooty $itk_component(entry) ] + \ - [winfo height $itk_component(entry) ]}] - set w [winfo width $itk_component(entry) ] - set h [winfo height [_slbListbox] ] - set sh [winfo screenheight .] - - if {(($y+$h) > $sh) && ($y > ($sh/2))} { - set y [expr {[winfo rooty $itk_component(entry) ] - $h}] - } - - $itk_component(list) configure -width $w - wm overrideredirect $itk_component(popup) 0 - wm geometry $itk_component(popup) +$x+$y - wm overrideredirect $itk_component(popup) 1 -} - -# ------------------------------------------------------ -# PROTECTED METHOD: _postList -# -# Pop up the list in a dropdown style Combobox. -# -# ------------------------------------------------------ -itcl::body iwidgets::Combobox::_postList {} { - if {[$itk_component(list) size] == ""} { - return - } - - set _isPosted true - _positionList - - # map window and do a grab - wm deiconify $itk_component(popup) - _listShowing -wait - - # Added by csmith, 12/19/00. Thanks to Erik Leunissen for - # finding this problem. We need to restore any previous - # grabs after the dropdown listbox is withdrawn. To do this, - # save the currently grabbed window. It is then restored in - # the _unpostList method. - set _grab(window) [::grab current] - if {$_grab(window) != ""} { - set _grab(status) [::grab status $_grab(window)] - } - - # Now grab the dropdown listbox. - if {$itk_option(-grab) == "global"} { - ::grab -global $itk_component(popup) - } else { - ::grab $itk_component(popup) - } - raise $itk_component(popup) - focus $itk_component(popup) - _drawArrow - - # Added by csmith, 10/26/00. This binding keeps the listbox - # from staying mapped if the window in which the combobox - # is packed is iconified. - bind $itk_component(entry) [itcl::code $this _unpostList] -} - -# ------------------------------------------------------ -# PROTECTED METHOD: _previous -# -# Select the previous item in the list. Wraps at front -# and end of list. -# -# ------------------------------------------------------ -itcl::body iwidgets::Combobox::_previous {} { - - set _next_prevFLAG 1 - - if {[size] <= 1} { - return - } - set i [curselection] - if {$i == "" || $i == 0} { - set i [expr {[size] - 1}] - } else { - incr i -1 - } - selection clear 0 end - selection set $i $i - see $i - set _currItem $i -} - -# ------------------------------------------------------ -# PROTECTED METHOD: _resizeArrow -# -# Recalculate the arrow button size and then redraw it. -# -# ------------------------------------------------------ -itcl::body iwidgets::Combobox::_resizeArrow {} { - set bw [expr {[$itk_component(arrowBtn) cget -borderwidth]+ \ - [$itk_component(arrowBtn) cget -highlightthickness]}] - set newHeight [expr {[winfo reqheight $itk_component(entry)]-(2*$bw) - 2}] - $itk_component(arrowBtn) configure -width $newHeight -height $newHeight - _drawArrow -} - -# ------------------------------------------------------ -# PROTECTED METHOD: _selectCmd -# -# Called when list item is selected to insert new text -# in entry, and call user -command callback if defined. -# -# ------------------------------------------------------ -itcl::body iwidgets::Combobox::_selectCmd {} { - $itk_component(entry) configure -state normal - - set _currItem [$itk_component(list) curselection] - set item [$itk_component(list) getcurselection] - clear entry - $itk_component(entry) insert 0 $item - switch -- $itk_option(-editable) { - 0 - false - no - off { - $itk_component(entry) configure -state readonly - } - } -} - -# ------------------------------------------------------ -# PROTECTED METHOD: _toggleList -# -# Post or unpost the dropdown listbox (toggle). -# -# ------------------------------------------------------ -itcl::body iwidgets::Combobox::_toggleList {} { - if {[winfo ismapped $itk_component(popup)] } { - _unpostList - } else { - _postList - } -} - -# ------------------------------------------------------ -# PROTECTED METHOD: _unpostList -# -# Unmap the listbox (pop it down). -# -# ------------------------------------------------------ -itcl::body iwidgets::Combobox::_unpostList {} { - # Determine if event occured in the scrolledlistbox and, if it did, - # don't unpost it. (A selection in the list unposts it correctly and - # in the scrollbar we don't want to unpost it.) - set x [winfo x $itk_component(list)] - set y [winfo y $itk_component(list)] - set w [winfo width $itk_component(list)] - set h [winfo height $itk_component(list)] - - wm withdraw $itk_component(popup) - ::grab release $itk_component(popup) - - # Added by csmith, 12/19/00. Thanks to Erik Leunissen for finding - # this problem. We need to restore any previous grabs when the - # dropdown listbox is unmapped. - if {$_grab(window) != ""} { - if {$_grab(status) == "global"} { - ::grab -global $_grab(window) - } else { - ::grab $_grab(window) - } - set _grab(window) "" - set _grab(status) "" - } - - # Added by csmith, 10/26/00. This binding resets the binding - # created in _postList - see that method for further details. - bind $itk_component(entry) {} - - set _isPosted false - - $itk_component(list) selection clear 0 end - if {$_currItem != {}} { - $itk_component(list) selection set $_currItem $_currItem - $itk_component(list) activate $_currItem - } - - switch -- $itk_option(-editable) { - 1 - true - yes - on { - $itk_component(entry) configure -state normal - } - 0 - false - no - off { - $itk_component(entry) configure -state readonly - } - } - - _drawArrow - update -} - -# ------------------------------------------------------ -# PROTECTED METHOD: _commonBindings -# -# Bindings that are used by both simple and dropdown -# style Comboboxes. -# -# ------------------------------------------------------ -itcl::body iwidgets::Combobox::_commonBindings {} { - bind $itk_component(entry) [itcl::code $this _bs] - bind $itk_component(entry) [itcl::code $this _lookup %K] - bind $itk_component(entry) [itcl::code $this _next] - bind $itk_component(entry) [itcl::code $this _previous] - bind $itk_component(entry) [itcl::code $this _next] - bind $itk_component(entry) [itcl::code $this _previous] - bind [_slbListbox] [itcl::code $this _next] - bind [_slbListbox] [itcl::code $this _previous] -} - - -# ------------------------------------------------------ -# PROTECTED METHOD: _dropdownBindings -# -# Bindings used only by the dropdown type Combobox. -# -# ------------------------------------------------------ -itcl::body iwidgets::Combobox::_dropdownBindings {} { - bind $itk_component(popup) [itcl::code $this _unpostList] - bind $itk_component(popup) \ - "[itcl::code $this _stateSelect]; [itcl::code $this _unpostList]" - bind $itk_component(popup) \ - "[itcl::code $this _stateSelect]; [itcl::code $this _unpostList]" - bind $itk_component(popup) \ - [itcl::code $this _dropdownBtnRelease %W %x %y] - - bind $itk_component(list) \ - [itcl::code $this _listShowing 1] - bind $itk_component(list) \ - [itcl::code $this _listShowing 0] - - # once in the listbox, we drop on the next release (unless in scrollbar) - bind [_slbListbox] \ - [itcl::code $this _ignoreNextBtnRelease false] - - bind $itk_component(arrowBtn) <3> [itcl::code $this _next] - bind $itk_component(arrowBtn) [itcl::code $this _previous] - bind $itk_component(arrowBtn) [itcl::code $this _next] - bind $itk_component(arrowBtn) [itcl::code $this _previous] - bind $itk_component(arrowBtn) [itcl::code $this _next] - bind $itk_component(arrowBtn) [itcl::code $this _previous] - bind $itk_component(arrowBtn) [itcl::code $this _toggleList] - bind $itk_component(arrowBtn) [itcl::code $this _toggleList] - bind $itk_component(arrowBtn) [itcl::code $this _toggleList] - bind $itk_component(arrowBtn) [itcl::code $this _toggleList] - - bind $itk_component(entry) [itcl::code $this _resizeArrow] - bind $itk_component(entry) [itcl::code $this _toggleList] - bind $itk_component(entry) [itcl::code $this _toggleList] -} - -# ------------------------------------------------------ -# PROTECTED METHOD: _simpleBindings -# -# Bindings used only by the simple type Comboboxes. -# -# ------------------------------------------------------ -itcl::body iwidgets::Combobox::_simpleBindings {} { - bind [_slbListbox] [itcl::code $this _stateSelect] - bind [_slbListbox] [itcl::code $this _stateSelect] - bind [_slbListbox] [itcl::code $this _stateSelect] - bind $itk_component(entry) "" - bind $itk_component(entry) "" - bind $itk_component(entry) "" - bind $itk_component(entry) "" -} - -# ------------------------------------------------------ -# PROTECTED METHOD: _listShowing ?val? -# -# Used instead of "tkwait visibility" to make sure that -# the dropdown list is visible. Whenever the list gets -# mapped or unmapped, this method is called to keep -# track of it. When it is called with the value "-wait", -# it waits for the list to be mapped. -# ------------------------------------------------------ -itcl::body iwidgets::Combobox::_listShowing {{val ""}} { - if {$val == ""} { - return $_listShowing($this) - } elseif {$val == "-wait"} { - while {!$_listShowing($this)} { - tkwait variable [itcl::scope _listShowing($this)] - } - return - } - set _listShowing($this) $val -} - -# ------------------------------------------------------ -# PRIVATE METHOD: _slbListbox -# -# Access the tk listbox window out of the scrolledlistbox. -# -# ------------------------------------------------------ -itcl::body iwidgets::Combobox::_slbListbox {} { - return [$itk_component(list) component listbox] -} - -# ------------------------------------------------------ -# PRIVATE METHOD: _stateSelect -# -# only allows a B1 release in the listbox to have an effect if -state is -# normal. -# -# ------------------------------------------------------ -itcl::body iwidgets::Combobox::_stateSelect {} { - switch -- $itk_option(-state) { - normal { - [itcl::code $this _selectCmd] - } - } -} - -# ------------------------------------------------------ -# PRIVATE METHOD: _bs -# -# A part of the auto-completion code, this function sets a flag when the -# Backspace key is hit and there is a selection in the entry field. -# Note that it's probably buggy to assume that a selection being present -# means that that selection came from auto-completion. -# -# ------------------------------------------------------ -itcl::body iwidgets::Combobox::_bs {} { - # - # exit if completion is turned off - # - switch -- $itk_option(-completion) { - 0 - no - false - off { - return - } - } - # - # critical section flag. it ain't perfect, but for most usage it'll - # keep us from being in this code "twice" at the same time - # (auto-repeated keystrokes are a pain!) - # - if {$_inbs} { - return - } else { - set _inbs 1 - } - - # - # set the _doit flag if there is a selection set in the entry field - # - set _doit 0 - if [$itk_component(entry) selection present] { - set _doit 1 - } - - # - # clear the semaphore and return - # - set _inbs 0 -} - -# ------------------------------------------------------ -# PRIVATE METHOD: _lookup -# -# handles auto-completion of text typed (or insert'd) into the entry field. -# -# ------------------------------------------------------ -itcl::body iwidgets::Combobox::_lookup {key} { - - # - # Don't process auto-completion stuff if navigation key was released - # Fixes SF bug 501300 - # - if {$_next_prevFLAG} { - set _next_prevFLAG 0 - return - } - - # - # exit if completion is turned off - # - switch -- $itk_option(-completion) { - 0 - no - false - off { - return - } - } - - # - # critical section flag. it ain't perfect, but for most usage it'll - # keep us from being in this code "twice" at the same time - # (auto-repeated keystrokes are a pain!) - # - if {$_inlookup} { - return - } else { - set _inlookup 1 - } - - # - # if state of megawidget is disabled, or the entry is not editable, - # clear the semaphore and exit - # - if {$itk_option(-state) == "disabled" \ - || [lsearch {on 1 true yes} $itk_option(-editable)] == -1} { - set _inlookup 0 - return - } - - # - # okay, *now* we can get to work - # the _bs function is called on keyPRESS of BackSpace, and will set - # the _doit flag if there's a selection set in the entryfield. If - # there is, we're assuming that it's generated by completion itself - # (this is probably a Bad Assumption), so we'll want to whack the - # selected text, as well as the character immediately preceding the - # insertion cursor. - # - if {$key == "BackSpace"} { - if {$_doit} { - set first [expr {[$itk_component(entry) index insert] -1}] - $itk_component(entry) delete $first end - $itk_component(entry) icursor $first - } - } - - # - # get the text left in the entry field, and its length. if - # zero-length, clear the selection in the listbox, clear the - # semaphore, and boogie. - # - set text [get] - set len [string length $text] - if {$len == 0} { - $itk_component(list) selection clear 0 end - set _inlookup 0 - return - } - - # No need to do lookups for Shift keys or Arrows. The up/down - # arrow keys should walk up/down the listbox entries. - switch $key { - Shift_L - Shift_R - Up - Down - Left - Right { - set _inlookup 0 - return - } - default { } - } - - # Added by csmith 12/11/01 to resolve SF ticket #474817. It's an unusual - # circumstance, but we need to make sure the character passed into this - # method matches the last character in the entry's text string. It's - # possible to type fast enough that the _lookup method gets invoked - # *after* multiple characters have been typed and *before* the first - # character has been processed. For example, you can type "bl" very - # quickly, and by the time the interpreter processes "b", the "l" has - # already been placed in the entry field. This causes problems as noted - # in the SF ticket. - # - # Thus, if the character currently being processed does not match the - # last character in the entry field, reset the _inlookup flag and return. - # Also, note that we're only concerned with single characters here, not - # keys such as backspace, delete, etc. - if {$key != [string range $text end end] && [string match ? $key]} { - set _inlookup 0 - return - } - - # - # okay, so we have to do a lookup. find the first match in the - # listbox to the text we've got in the entry field (glob). - # if one exists, clear the current listbox selection, and set it to - # the one we just found, making that one visible in the listbox. - # then, pick off the text from the listbox entry that hadn't yet been - # entered into the entry field. we need to tack that text onto the - # end of the entry field, select it, and then set the insertion cursor - # back to just before the point where we just added that text. - # if one didn't exist, then just clear the listbox selection - # - set item [lsearch [$itk_component(list) get 0 end] "$text*" ] - if {$item != -1} { - $itk_component(list) selection clear 0 end - $itk_component(list) selection set $item $item - see $item - set remainder [string range [$itk_component(list) get $item] $len end] - $itk_component(entry) insert end $remainder - $itk_component(entry) selection range $len end - $itk_component(entry) icursor $len - } else { - $itk_component(list) selection clear 0 end - } - # - # clear the semaphore and return - # - set _inlookup 0 - return -} - - diff --git a/iwidgets/library/dateentry.itk b/iwidgets/library/dateentry.itk deleted file mode 100644 index 8f954e3..0000000 --- a/iwidgets/library/dateentry.itk +++ /dev/null @@ -1,424 +0,0 @@ -# -# Dateentry -# ---------------------------------------------------------------------- -# Implements a quicken style date entry field with a popup calendar -# by combining the datefield and calendar widgets together. This -# allows a user to enter the date via the keyboard or by using the -# mouse by selecting the calendar icon which brings up a popup calendar. -# ---------------------------------------------------------------------- -# AUTHOR: Mark L. Ulferts E-mail: mulferts@austin.dsccc.com -# -# @(#) $Id: dateentry.itk,v 1.7 2003/01/30 20:56:05 smithc Exp $ -# ---------------------------------------------------------------------- -# Copyright (c) 1997 DSC Technologies Corporation -# ====================================================================== -# Permission to use, copy, modify, distribute and license this software -# and its documentation for any purpose, and without fee or written -# agreement with DSC, is hereby granted, provided that the above copyright -# notice appears in all copies and that both the copyright notice and -# warranty disclaimer below appear in supporting documentation, and that -# the names of DSC Technologies Corporation or DSC Communications -# Corporation not be used in advertising or publicity pertaining to the -# software without specific, written prior permission. -# -# DSC DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING -# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, 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. IN NO EVENT SHALL -# DSC BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR -# ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, -# WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION, -# ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS -# SOFTWARE. -# ====================================================================== -# -# ---------------------------------------------------------------------- -# -# Modified 2001-10-23 by Mark Alston to pass options to the datefield -# constructor. Needed to allow use of new option -int which lets the -# user use dates in YYYY-MM-DD format as well as MM/DD/YYYY format. -# -# option -int yes sets dates to YYYY-MM-DD format -# -int no sets dates to MM/DD/YYYY format. -# -# ---------------------------------------------------------------------- -# -# Usual options. -# -itk::usual Dateentry { - keep -background -borderwidth -currentdatefont -cursor \ - -datefont -dayfont -foreground -highlightcolor \ - -highlightthickness -labelfont -textbackground -textfont \ - -titlefont -int -} - -# ------------------------------------------------------------------ -# DATEENTRY -# ------------------------------------------------------------------ -itcl::class iwidgets::Dateentry { - inherit iwidgets::Datefield - - constructor {args} { - eval Datefield::constructor $args - } {} - - itk_option define -grab grab Grab "global" - itk_option define -icon icon Icon {} - - # - # The calendar widget isn't created until needed, yet we need - # its options to be available upon creation of a dateentry widget. - # So, we'll define them in these class now so they can just be - # propagated onto the calendar later. - # - itk_option define -days days Days {Su Mo Tu We Th Fr Sa} - itk_option define -forwardimage forwardImage Image {} - itk_option define -backwardimage backwardImage Image {} - itk_option define -weekdaybackground weekdayBackground Background \#d9d9d9 - itk_option define -weekendbackground weekendBackground Background \#d9d9d9 - itk_option define -outline outline Outline \#d9d9d9 - itk_option define -buttonforeground buttonForeground Foreground blue - itk_option define -foreground foreground Foreground black - itk_option define -selectcolor selectColor Foreground red - itk_option define -selectthickness selectThickness SelectThickness 3 - itk_option define -titlefont titleFont Font \ - -*-helvetica-bold-r-normal--*-140-* - itk_option define -dayfont dayFont Font \ - -*-helvetica-medium-r-normal--*-120-* - itk_option define -datefont dateFont Font \ - -*-helvetica-medium-r-normal--*-120-* - itk_option define -currentdatefont currentDateFont Font \ - -*-helvetica-bold-r-normal--*-120-* - itk_option define -startday startDay Day sunday - itk_option define -height height Height 165 - itk_option define -width width Width 200 - itk_option define -state state State normal - - protected { - method _getPopupDate {date} - method _releaseGrab {} - method _releaseGrabCheck {rootx rooty} - method _popup {} - method _getDefaultIcon {} - - common _defaultIcon "" - } -} - -# -# Provide a lowercased access method for the dateentry class. -# -proc ::iwidgets::dateentry {pathName args} { - uplevel ::iwidgets::Dateentry $pathName $args -} - -# ------------------------------------------------------------------ -# CONSTRUCTOR -# ------------------------------------------------------------------ -itcl::body iwidgets::Dateentry::constructor {args} { - # - # Create an icon label to act as a button to bring up the - # calendar popup. - # - itk_component add iconbutton { - label $itk_interior.iconbutton -relief raised - } { - keep -borderwidth -cursor -foreground - } - grid $itk_component(iconbutton) -row 0 -column 0 -sticky ns - - # - # Initialize the widget based on the command line options. - # - eval itk_initialize $args -} - -# ------------------------------------------------------------------ -# OPTIONS -# ------------------------------------------------------------------ - -# ------------------------------------------------------------------ -# OPTION: -icon -# -# Specifies the calendar icon image to be used in the date. -# Should one not be provided, then a default pixmap will be used -# if possible, bitmap otherwise. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Dateentry::icon { - if {$itk_option(-icon) == {}} { - $itk_component(iconbutton) configure -image [_getDefaultIcon] - } else { - if {[lsearch [image names] $itk_option(-icon)] == -1} { - error "bad icon option \"$itk_option(-icon)\":\ - should be an existing image" - } else { - $itk_component(iconbutton) configure -image $itk_option(-icon) - } - } -} - -# ------------------------------------------------------------------ -# OPTION: -grab -# -# Specifies the grab level, local or global, to be obtained when -# bringing up the popup calendar. The default is global. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Dateentry::grab { - switch -- $itk_option(-grab) { - "local" - "global" {} - default { - error "bad grab option \"$itk_option(-grab)\":\ - should be local or global" - } - } -} - -# ------------------------------------------------------------------ -# OPTION: -state -# -# Specifies the state of the widget which may be disabled or -# normal. A disabled state prevents selection of the date field -# or date icon button. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Dateentry::state { - switch -- $itk_option(-state) { - normal { - bind $itk_component(iconbutton) [itcl::code $this _popup] - } - disabled { - bind $itk_component(iconbutton) {} - } - } -} - -# ------------------------------------------------------------------ -# METHODS -# ------------------------------------------------------------------ - -# ------------------------------------------------------------------ -# PROTECTED METHOD: _getDefaultIcon -# -# This method is invoked uto retrieve the name of the default icon -# image displayed in the icon button. -# ------------------------------------------------------------------ -itcl::body iwidgets::Dateentry::_getDefaultIcon {} { - if {[lsearch [image types] pixmap] != -1} { - set _defaultIcon [image create pixmap -data { - /* XPM */ - static char *calendar[] = { - /* width height num_colors chars_per_pixel */ - " 25 20 6 1", - /* colors */ - ". c #808080", - "# c #040404", - "a c #848484", - "b c #fc0404", - "c c #fcfcfc", - "d c #c0c0c0", - /* pixels */ - "d##########d###########dd", - "d#ccccccccc##ccccccccca#d", - "##ccccccccc.#ccccccccc..#", - "##cccbbcccca#cccbbbccca.#", - "##cccbbcccc.#ccbbbbbcc..#", - "##cccbbccc####ccccbbcc..#", - "##cccbbcccca#ccccbbbcca.#", - "##cccbbcccc.#cccbbbccc..#", - "##cccbbcccca#ccbbbcccca.#", - "##cccbbbccc.#ccbbbbbcc..#", - "##ccccccccc.#ccccccccc..#", - "##ccccccccca#ccccccccca.#", - "##cc#####c#cd#c#####cc..#", - "##cccccccc####cccccccca.#", - "##cc#####cc.#cc#####cc..#", - "##ccccccccc.#ccccccccc..#", - "##ccccccccc.#ccccccccc..#", - "##..........#...........#", - "###..........#..........#", - "#########################" - }; - }] - } else { - set _defaultIcon [image create bitmap -data { - #define calendr2_width 25 - #define calendr2_height 20 - static char calendr2_bits[] = { - 0xfe,0xf7,0x7f,0xfe,0x02,0x18,0xc0,0xfe,0x03, - 0x18,0x80,0xff,0x63,0x10,0x47,0xff,0x43,0x98, - 0x8a,0xff,0x63,0x3c,0x4c,0xff,0x43,0x10,0x8a, - 0xff,0x63,0x18,0x47,0xff,0x23,0x90,0x81,0xff, - 0xe3,0x98,0x4e,0xff,0x03,0x10,0x80,0xff,0x03, - 0x10,0x40,0xff,0xf3,0xa5,0x8f,0xff,0x03,0x3c, - 0x40,0xff,0xf3,0x99,0x8f,0xff,0x03,0x10,0x40, - 0xff,0x03,0x18,0x80,0xff,0x57,0x55,0x55,0xff, - 0x57,0xb5,0xaa,0xff,0xff,0xff,0xff,0xff}; - }] - } - - # - # Since this image will only need to be created once, we redefine - # this method to just return the image name for subsequent calls. - # - itcl::body ::iwidgets::Dateentry::_getDefaultIcon {} { - return $_defaultIcon - } - - return $_defaultIcon -} - -# ------------------------------------------------------------------ -# PROTECTED METHOD: _popup -# -# This method is invoked upon selection of the icon button. It -# creates a calendar widget within a toplevel popup, calculates -# the position at which to display the calendar, performs a grab -# and displays the calendar. -# ------------------------------------------------------------------ -itcl::body iwidgets::Dateentry::_popup {} { - # - # First, let's nullify the icon binding so that any another - # selections are ignored until were done with this one. Next, - # change the relief of the icon. - # - bind $itk_component(iconbutton) {} - $itk_component(iconbutton) configure -relief sunken - - # - # Create a withdrawn toplevel widget and remove the window - # decoration via override redirect. - # - itk_component add -private popup { - toplevel $itk_interior.popup - } - $itk_component(popup) configure -borderwidth 2 -background black - wm withdraw $itk_component(popup) - wm overrideredirect $itk_component(popup) 1 - - # - # Add a binding to button 1 events in order to detect mouse - # clicks off the calendar in which case we'll release the grab. - # Also add a binding for Escape to always release. - # - bind $itk_component(popup) <1> [itcl::code $this _releaseGrabCheck %X %Y] - bind $itk_component(popup) [itcl::code $this _releaseGrab] - - # - # Create the calendar widget and set its cursor properly. - # - itk_component add calendar { - iwidgets::Calendar $itk_component(popup).calendar \ - -command [itcl::code $this _getPopupDate %d] \ - -int $itk_option(-int) - } { - usual - keep -days -forwardimage -backwardimage -weekdaybackground \ - -weekendbackground -outline -buttonforeground -selectcolor \ - -selectthickness -titlefont -dayfont -datefont \ - -currentdatefont -startday -width -height - } - grid $itk_component(calendar) -row 0 -column 0 - $itk_component(calendar) configure -cursor top_left_arrow - - # - # The icon button will be used as the basis for the position of the - # popup on the screen. We'll always attempt to locate the popup - # off the lower right corner of the button. If that would put - # the popup off the screen, then we'll put above the upper left. - # - set rootx [winfo rootx $itk_component(iconbutton)] - set rooty [winfo rooty $itk_component(iconbutton)] - set popupwidth [winfo reqwidth $itk_component(popup)] - set popupheight [winfo reqheight $itk_component(popup)] - - set popupx [expr {$rootx + 3 + \ - [winfo width $itk_component(iconbutton)]}] - set popupy [expr {$rooty + 3 + \ - [winfo height $itk_component(iconbutton)]}] - - if {(($popupx + $popupwidth) > [winfo screenwidth .]) || \ - (($popupy + $popupheight) > [winfo screenheight .])} { - set popupx [expr {$rootx - 3 - $popupwidth}] - set popupy [expr {$rooty - 3 - $popupheight}] - } - - # - # Get the current date from the datefield widget and both - # show and select it on the calendar. - # - # Added catch for bad dates. Calendar then shows current date. - if [catch "$itk_component(calendar) show [get]" err] { - $itk_component(calendar) show now - $itk_component(calendar) select now - } else { - $itk_component(calendar) select [get] - } - # - # Display the popup at the calculated position. - # - wm geometry $itk_component(popup) +$popupx+$popupy - wm deiconify $itk_component(popup) - tkwait visibility $itk_component(popup) - - # - # Perform either a local or global grab based on the -grab option. - # - if {$itk_option(-grab) == "local"} { - ::grab $itk_component(popup) - } else { - ::grab -global $itk_component(popup) - } - - # - # Make sure the widget is above all others and give it focus. - # - raise $itk_component(popup) - focus $itk_component(calendar) -} - -# ------------------------------------------------------------------ -# PROTECTED METHOD: _popupGetDate -# -# This method is the callback for selection of a date on the -# calendar. It releases the grab and sets the date in the -# datefield widget. -# ------------------------------------------------------------------ -itcl::body iwidgets::Dateentry::_getPopupDate {date} { - _releaseGrab - show $date -} - -# ------------------------------------------------------------------ -# PROTECTED METHOD: _releaseGrabCheck rootx rooty -# -# This method handles mouse button 1 events. If the selection -# occured within the bounds of the calendar, then return normally -# and let the calendar handle the event. Otherwise, we'll drop -# the calendar and release the grab. -# ------------------------------------------------------------------ -itcl::body iwidgets::Dateentry::_releaseGrabCheck {rootx rooty} { - set calx [winfo rootx $itk_component(calendar)] - set caly [winfo rooty $itk_component(calendar)] - set calwidth [winfo reqwidth $itk_component(calendar)] - set calheight [winfo reqheight $itk_component(calendar)] - - if {($rootx < $calx) || ($rootx > ($calx + $calwidth)) || \ - ($rooty < $caly) || ($rooty > ($caly + $calheight))} { - _releaseGrab - return -code break - } -} - -# ------------------------------------------------------------------ -# PROTECTED METHOD: _releaseGrab -# -# This method releases the grab, destroys the popup, changes the -# relief of the button back to raised and reapplies the binding -# to the icon button that engages the popup action. -# ------------------------------------------------------------------ -itcl::body iwidgets::Dateentry::_releaseGrab {} { - ::grab release $itk_component(popup) - $itk_component(iconbutton) configure -relief raised - destroy $itk_component(popup) - bind $itk_component(iconbutton) [itcl::code $this _popup] -} diff --git a/iwidgets/library/datefield.itk b/iwidgets/library/datefield.itk deleted file mode 100644 index f3f9a9e..0000000 --- a/iwidgets/library/datefield.itk +++ /dev/null @@ -1,1020 +0,0 @@ -# -# Datefield -# ---------------------------------------------------------------------- -# Implements a date entry field with adjustable built-in intelligence -# levels. -# ---------------------------------------------------------------------- -# AUTHOR: Mark L. Ulferts E-mail: mulferts@austin.dsccc.com -# -# @(#) $Id: datefield.itk,v 1.6 2007/06/10 19:18:14 hobbs Exp $ -# ---------------------------------------------------------------------- -# Copyright (c) 1997 DSC Technologies Corporation -# ====================================================================== -# -# Permission to use, copy, modify, distribute and license this software -# and its documentation for any purpose, and without fee or written -# agreement with DSC, is hereby granted, provided that the above copyright -# notice appears in all copies and that both the copyright notice and -# warranty disclaimer below appear in supporting documentation, and that -# the names of DSC Technologies Corporation or DSC Communications -# Corporation not be used in advertising or publicity pertaining to the -# software without specific, written prior permission. -# -# DSC DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING -# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, 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. IN NO EVENT SHALL -# DSC BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR -# ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, -# WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION, -# ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS -# SOFTWARE. -# ====================================================================== - -# -# Usual options. -# -itk::usual Datefield { - keep -background -borderwidth -cursor -foreground -highlightcolor \ - -highlightthickness -labelfont -textbackground -textfont -} - -# ------------------------------------------------------------------ -# DATEFIELD -# ------------------------------------------------------------------ -itcl::class iwidgets::Datefield { - inherit iwidgets::Labeledwidget - - constructor {args} {} - - itk_option define -childsitepos childSitePos Position e - itk_option define -command command Command {} - itk_option define -iq iq Iq high - itk_option define -gmt gmt GMT no - itk_option define -int int DateFormat no - - public method get {{format "-string"}} - public method isvalid {} - public method show {{date now}} - - protected method _backward {} - protected method _focusIn {} - protected method _forward {} - protected method _keyPress {char sym state} - protected method _lastDay {month year} - protected method _moveField {direction} - protected method _setField {field} - protected method _whichField {} - - protected variable _cfield "month" - protected variable _fields {month day year} -} - - -# -# Provide a lowercased access method for the datefield class. -# -proc ::iwidgets::datefield {pathName args} { - uplevel ::iwidgets::Datefield $pathName $args -} - -# -# Use option database to override default resources of base classes. -# -option add *Datefield.justify center widgetDefault - -# ------------------------------------------------------------------ -# CONSTRUCTOR -# ------------------------------------------------------------------ -itcl::body iwidgets::Datefield::constructor {args} { - component hull configure -borderwidth 0 - - # - # Create an entry field for entering the date. - # - itk_component add date { - entry $itk_interior.date -width 10 - } { - keep -borderwidth -cursor -exportselection \ - -foreground -highlightcolor -highlightthickness \ - -insertbackground -justify -relief -state - - rename -font -textfont textFont Font - rename -highlightbackground -background background Background - rename -background -textbackground textBackground Background - } - - # - # Create the child site widget. - # - itk_component add -protected dfchildsite { - frame $itk_interior.dfchildsite - } - set itk_interior $itk_component(dfchildsite) - - # - # Add datefield event bindings for focus in and keypress events. - # - bind $itk_component(date) [itcl::code $this _focusIn] - bind $itk_component(date) [itcl::code $this _keyPress %A %K %s] - - # - # Disable some mouse button event bindings: - # Button Motion - # Double-Clicks - # Triple-Clicks - # Button2 - # - bind $itk_component(date) break - bind $itk_component(date) break - bind $itk_component(date) break - bind $itk_component(date) break - bind $itk_component(date) <2> break - - # - # Initialize the widget based on the command line options. - # - eval itk_initialize $args - - # - # Initialize the date to the current date. - # - $itk_component(date) delete 0 end - - show now -} - -# ------------------------------------------------------------------ -# OPTIONS -# ------------------------------------------------------------------ - -# ------------------------------------------------------------------ -# OPTION: -childsitepos -# -# Specifies the position of the child site in the widget. Valid -# locations are n, s, e, and w. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Datefield::childsitepos { - set parent [winfo parent $itk_component(date)] - - switch $itk_option(-childsitepos) { - n { - grid $itk_component(dfchildsite) -row 0 -column 0 -sticky ew - grid $itk_component(date) -row 1 -column 0 -sticky nsew - - grid rowconfigure $parent 0 -weight 0 - grid rowconfigure $parent 1 -weight 1 - grid columnconfigure $parent 0 -weight 1 - grid columnconfigure $parent 1 -weight 0 - } - - e { - grid $itk_component(dfchildsite) -row 0 -column 1 -sticky ns - grid $itk_component(date) -row 0 -column 0 -sticky nsew - - grid rowconfigure $parent 0 -weight 1 - grid rowconfigure $parent 1 -weight 0 - grid columnconfigure $parent 0 -weight 1 - grid columnconfigure $parent 1 -weight 0 - } - - s { - grid $itk_component(dfchildsite) -row 1 -column 0 -sticky ew - grid $itk_component(date) -row 0 -column 0 -sticky nsew - - grid rowconfigure $parent 0 -weight 1 - grid rowconfigure $parent 1 -weight 0 - grid columnconfigure $parent 0 -weight 1 - grid columnconfigure $parent 1 -weight 0 - } - - w { - grid $itk_component(dfchildsite) -row 0 -column 0 -sticky ns - grid $itk_component(date) -row 0 -column 1 -sticky nsew - - grid rowconfigure $parent 0 -weight 1 - grid rowconfigure $parent 1 -weight 0 - grid columnconfigure $parent 0 -weight 0 - grid columnconfigure $parent 1 -weight 1 - } - - default { - error "bad childsite option\ - \"$itk_option(-childsitepos)\":\ - should be n, e, s, or w" - } - } -} - -# ------------------------------------------------------------------ -# OPTION: -command -# -# Command invoked upon detection of return key press event. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Datefield::command {} - -# ------------------------------------------------------------------ -# OPTION: -iq -# -# Specifies the level of intelligence to be shown in the actions -# taken by the date field during the processing of keypress events. -# Valid settings include high, average, and low. With a high iq, -# the date prevents the user from typing in an invalid date. For -# example, if the current date is 05/31/1997 and the user changes -# the month to 04, then the day will be instantly modified for them -# to be 30. In addition, leap years are fully taken into account. -# With average iq, the month is limited to the values of 01-12, but -# it is possible to type in an invalid day. A setting of low iq -# instructs the widget to do no validity checking at all during -# date entry. With both average and low iq levels, it is assumed -# that the validity will be determined at a later time using the -# date's isvalid command. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Datefield::iq { - switch $itk_option(-iq) { - high - average - low { - } - default { - error "bad iq option \"$itk_option(-iq)\":\ - should be high, average or low" - } - } -} - -# ------------------------------------------------------------------ -# OPTION: -int -# -# Added by Mark Alston 2001/10/21 -# -# Allows for the use of dates in "international" format: YYYY-MM-DD. -# It must be a boolean value. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Datefield::int { - switch $itk_option(-int) { - 1 - yes - true - on { - set _cfield "year" - set _fields {year month day} - } - 0 - no - false - off { } - default { - error "bad int option \"$itk_option(-int)\": should be boolean" - } - } - show [get] -} - -# ------------------------------------------------------------------ -# OPTION: -gmt -# -# This option is used for GMT time. Must be a boolean value. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Datefield::gmt { - switch $itk_option(-gmt) { - 0 - no - false - off { } - 1 - yes - true - on { } - default { - error "bad gmt option \"$itk_option(-gmt)\": should be boolean" - } - } -} - -# ------------------------------------------------------------------ -# METHODS -# ------------------------------------------------------------------ - -# ------------------------------------------------------------------ -# PUBLIC METHOD: get ?format? -# -# Return the current contents of the datefield in one of two formats -# string or as an integer clock value using the -string and -clicks -# options respectively. The default is by string. Reference the -# clock command for more information on obtaining dates and their -# formats. -# ------------------------------------------------------------------ -itcl::body iwidgets::Datefield::get {{format "-string"}} { - set datestr [$itk_component(date) get] - - switch -- $format { - "-string" { - return $datestr - } - "-clicks" { - return [clock scan $datestr] - } - default { - error "bad format option \"$format\":\ - should be -string or -clicks" - } - } -} - -# ------------------------------------------------------------------ -# PUBLIC METHOD: show date -# -# Changes the currently displayed date to be that of the date -# argument. The date may be specified either as a string or an -# integer clock value. Reference the clock command for more -# information on obtaining dates and their formats. -# ------------------------------------------------------------------ -itcl::body iwidgets::Datefield::show {{date "now"}} { - $itk_component(date) delete 0 end - if {$itk_option(-int)} { - set format {%Y-%m-%d} - } else { - set format {%m/%d/%Y} - } - - if {$date == "now"} { - set seconds [::clock seconds] - $itk_component(date) insert end \ - [clock format $seconds -format "$format" -gmt $itk_option(-gmt)] - - } elseif { $itk_option(-iq) != "low" } { - if {[catch {::clock format $date}] == 0} { - set seconds $date - } elseif {[catch {set seconds [::clock scan $date -gmt \ - $itk_option(-gmt)]}] != 0} { - error "bad date: \"$date\", must be a valid date\ - string, clock clicks value or the keyword now" - } - $itk_component(date) insert end \ - [clock format $seconds -format "$format" -gmt $itk_option(-gmt)] - } else { - # Note that it doesn't matter what -int is set to. - $itk_component(date) insert end $date - } - - if {$itk_option(-int)} { - _setField year - } else { - _setField month - } - - return -} - -# ------------------------------------------------------------------ -# PUBLIC METHOD: isvalid -# -# Returns a boolean indication of the validity of the currently -# displayed date value. For example, 3/3/1960 is valid whereas -# 02/29/1997 is invalid. -# ------------------------------------------------------------------ -itcl::body iwidgets::Datefield::isvalid {} { - if {[catch {clock scan [$itk_component(date) get]}] != 0} { - return 0 - } else { - return 1 - } -} - -# ------------------------------------------------------------------ -# PROTECTED METHOD: _focusIn -# -# This method is bound to the event. It resets the -# insert cursor and field settings to be back to their last known -# positions. -# ------------------------------------------------------------------ -itcl::body iwidgets::Datefield::_focusIn {} { - _setField $_cfield -} - -# ------------------------------------------------------------------ -# PROTECTED METHOD: _keyPress -# -# This method is the workhorse of the class. It is bound to the -# event and controls the processing of all key strokes. -# ------------------------------------------------------------------ -itcl::body iwidgets::Datefield::_keyPress {char sym state} { - # - # Determine which field we are in currently. This is needed - # since the user may have moved to this position via a mouse - # selection and so it would not be in the position we last - # knew it to be. - # - _whichField - - # - # If we are using an international date the split char is "-" - # otherwise it is "/". - # - if {$itk_option(-int)} { - set split_char "-" - } else { - set split_char "/" - } - - - # - # Set up a few basic variables we'll be needing throughout the - # rest of the method such as the position of the insert cursor - # and the currently displayed day, month, and year. - # - set icursor [$itk_component(date) index insert] - set splist [split [$itk_component(date) get] "$split_char"] - - - # A bunch of added variables to allow for the use of int dates - if {$itk_option(-int)} { - set order {year month day} - set year [lindex $splist 0] - set month [lindex $splist 1] - set day [lindex $splist 2] - set year_start_pos 0 - set year_second_pos 1 - set year_third_pos 2 - set year_fourth_pos 3 - set year_end_pos 4 - set month_start_pos 5 - set month_second_pos 6 - set month_end_pos 7 - set day_start_pos 8 - set day_second_pos 9 - set day_end_pos 10 - } else { - set order {month day year} - set month [lindex $splist 0] - set day [lindex $splist 1] - set year [lindex $splist 2] - set month_start_pos 0 - set month_second_pos 1 - set month_end_pos 2 - set day_start_pos 3 - set day_second_pos 4 - set day_end_pos 5 - set year_start_pos 6 - set year_second_pos 7 - set year_third_pos 8 - set year_fourth_pos 9 - set year_end_pos 10 - } - - - # - # Process numeric keystrokes. This involes a fair amount of - # processing with step one being to check and make sure we - # aren't attempting to insert more that 10 characters. If - # so ring the bell and break. - # - if {[string match {[0-9]} $char]} { - if {[$itk_component(date) index insert] == 10} { - bell - return -code break - } - - # - # If we are currently in the month field then we process the - # number entered based on the cursor position. If we are at - # at the first position and our iq is low, then accept any - # input. - # - if {$_cfield == "month"} { - - if {[$itk_component(date) index insert] == $month_start_pos} { - if {$itk_option(-iq) == "low"} { - $itk_component(date) delete $month_start_pos - $itk_component(date) insert $month_start_pos $char - } else { - # - # Otherwise, we're slightly smarter. If the number - # is less than two insert it at position zero. If - # this makes the month greater than twelve, set the - # number at position one to zero which makes in - # effect puts the month back in range. - # - regsub {([0-9])([0-9])} $month "$char\\2" month2b - - if {$char < 2} { - $itk_component(date) delete $month_start_pos - $itk_component(date) insert $month_start_pos $char - - if {$month2b > 12} { - $itk_component(date) delete $month_second_pos - $itk_component(date) insert $month_second_pos 0 - $itk_component(date) icursor $month_second_pos - } elseif {$month2b == "00"} { - $itk_component(date) delete $month_second_pos - $itk_component(date) insert $month_second_pos 1 - $itk_component(date) icursor $month_second_pos - } - - # - # Finally, if the number is greater than one we'll - # assume that they really mean to be entering a zero - # followed by their number, do so for them, and - # proceed to skip to the next field which is the - # day field. - # - } else { - $itk_component(date) delete $month_start_pos $month_end_pos - $itk_component(date) insert $month_start_pos 0$char - _setField day - } - } - - # - # Else, we're at the second month position. Again, if we aren't - # too smart, let them enter anything. Otherwise, if the - # number makes the month exceed twelve, set the month to - # zero followed by their number to get it back into range. - # - } else { - regsub {([0-9])([0-9])} $month "\\1$char" month2b - - if {$itk_option(-iq) == "low"} { - $itk_component(date) delete $month_second_pos - $itk_component(date) insert $month_second_pos $char - } else { - if {$month2b > 12} { - $itk_component(date) delete $month_start_pos $month_end_pos - $itk_component(date) insert $month_start_pos 0$char - } elseif {$month2b == "00"} { - bell - return -code break - } else { - $itk_component(date) delete $month_second_pos - $itk_component(date) insert $month_second_pos $char - } - } - _setField day - } - - # - # Now, the month processing is complete and if we're of a - # high level of intelligence, then we'll make sure that the - # current value for the day is valid for this month. If - # it is beyond the last day for this month, change it to - # be the last day of the new month. - # - if {$itk_option(-iq) == "high"} { - set splist [split [$itk_component(date) get] "$split_char"] - set month [lindex $splist [lsearch $order month]] - if {$day > [set endday [_lastDay $month $year]]} { - set icursor [$itk_component(date) index insert] - $itk_component(date) delete $day_start_pos $day_end_pos - $itk_component(date) insert $day_start_pos $endday - $itk_component(date) icursor $icursor - } - } - - # - # Finally, return with a code of break to stop any normal - # processing in that we've done all that is necessary. - # - return -code break - } - - # - # This next block of code is for processing of the day field - # which is quite similar is strategy to that of the month. - # - if {$_cfield == "day"} { - if {$itk_option(-iq) == "high"} { - set endofMonth [_lastDay $month $year] - } else { - set endofMonth 31 - } - - # - # If we are at the first cursor position for the day - # we are processing - # the first character of the day field. If we have an iq - # of low accept any input. - # - if {[$itk_component(date) index insert] == $day_start_pos} { - if {$itk_option(-iq) == "low"} { - $itk_component(date) delete $day_start_pos - $itk_component(date) insert $day_start_pos $char - - } else { - - # - # If the day to be is double zero, then make the - # day be the first. - # - regsub {([0-9])([0-9])} $day "$char\\2" day2b - - if {$day2b == "00"} { - $itk_component(date) delete $day_start_pos $day_end_pos - $itk_component(date) insert $day_start_pos 01 - $itk_component(date) icursor $day_second_pos - # - # Otherwise, if the character is less than four - # and the month is not Feburary, insert the number - # and if this makes the day be beyond the valid - # range for this month, than set to be back in - # range. - # - } elseif {($char < 4) && ($month != "02")} { - $itk_component(date) delete $day_start_pos - $itk_component(date) insert $day_start_pos $char - - if {$day2b > $endofMonth} { - $itk_component(date) delete $day_second_pos - $itk_component(date) insert $day_second_pos 0 - $itk_component(date) icursor $day_second_pos - } - - # - # For Feburary with a number to be entered of - # less than three, make sure the number doesn't - # make the day be greater than the correct range - # and if so adjust the input. - # - } elseif {$char < 3} { - $itk_component(date) delete $day_start_pos - $itk_component(date) insert $day_start_pos $char - if {$day2b > $endofMonth} { - $itk_component(date) delete $day_start_pos $day_end_pos - $itk_component(date) insert $day_start_pos $endofMonth - $itk_component(date) icursor $day_second_pos - } - - # - # Finally, if the number is greater than three, - # set the day to be zero followed by the number - # entered and proceed to the year field or end. - # - } else { - $itk_component(date) delete $day_start_pos $day_end_pos - $itk_component(date) insert $day_start_pos 0$char - $itk_component(date) icursor $day_end_pos - if {!$itk_option(-int)} { - _setField year - } - } - } - # - # Else, we're dealing with the second number in the day - # field. If we're not too bright accept anything, otherwise - # if the day is beyond the range for this month or equal to - # zero then ring the bell. - # - } else { - regsub {([0-9])([0-9])} $day "\\1$char" day2b - - if {($itk_option(-iq) != "low") && \ - (($day2b > $endofMonth) || ($day2b == "00"))} { - bell - } else { - $itk_component(date) delete $day_second_pos - $itk_component(date) insert $day_second_pos $char - $itk_component(date) icursor $day_end_pos - if {!$itk_option(-int)} { - _setField year - } - } - } - - # - # Return with a code of break to prevent normal processing. - # - return -code break - } - - # - # This month and day we're tough, the code for the year is - # comparitively simple. Accept any input and if we are really - # sharp, then make sure the day is correct for the month - # given the year. In short, handle leap years. - # - if {$_cfield == "year"} { - if {$itk_option(-iq) == "low"} { - $itk_component(date) delete $icursor - $itk_component(date) insert $icursor $char - } else { - set prevdate [get] - if {[$itk_component(date) index insert] == $year_start_pos} { - set yrdgt [lindex [split [lindex \ - [split $prevdate "$split_char"] [lsearch $order year]] ""] 0] - if {$char != $yrdgt} { - if {$char == 1} { - $itk_component(date) delete $icursor $year_end_pos - $itk_component(date) insert $icursor 1999 - } elseif {$char == 2} { - $itk_component(date) delete $icursor $year_end_pos - $itk_component(date) insert $icursor 2000 - } else { - bell - return -code break - } - } - - $itk_component(date) icursor $year_second_pos - return -code break - } - - $itk_component(date) delete $icursor - $itk_component(date) insert $icursor $char - - - if {[catch {clock scan [get]}] != 0} { - $itk_component(date) delete $year_start_pos $year_end_pos - $itk_component(date) insert $year_start_pos \ - [lindex [split $prevdate "$split_char"] [lsearch $order year]] - $itk_component(date) icursor $icursor - - bell - return -code break - } - - if {$itk_option(-iq) == "high"} { - set splist [split [$itk_component(date) get] "$split_char"] - set year [lindex $splist [lsearch $order year]] - - if {$day > [set endday [_lastDay $month $year]]} { - set icursor [$itk_component(date) index insert] - $itk_component(date) delete $day_start_pos $day_end_pos - $itk_component(date) insert $day_start_pos $endday - $itk_component(date) icursor $icursor - } - } - } - if {$itk_option(-int)} { - if {$icursor == $year_fourth_pos } { - _setField month - } - } - return -code break - } - - # - # Process the plus and the up arrow keys. They both yeild the same - # effect, they increment the day by one. - # - } elseif {($sym == "plus") || ($sym == "Up")} { - if {[catch {show [clock scan "1 day" -base [get -clicks]]}] != 0} { - bell - } - return -code break - - # - # Process the minus and the down arrow keys which decrement the day. - # - } elseif {($sym == "minus") || ($sym == "Down")} { - if {[catch {show [clock scan "-1 day" -base [get -clicks]]}] != 0} { - bell - } - return -code break - - # - # A tab key moves the day/month/year (or year/month/day) field - # forward by one unless - # the current field is the last field. In that case we'll let tab - # do what is supposed to and pass the focus onto the next widget. - # - } elseif {($sym == "Tab") && ($state == 0)} { - if {$_cfield != "[lindex $order 2]"} { - _moveField forward - return -code break - } else { - _setField "[lindex $order 0]" - return -code continue - } - - # - # A ctrl-tab key moves the day/month/year field backwards by one - # unless the current field is the the first field. In that case we'll - # let tab take the focus to a previous widget. - # - } elseif {($sym == "Tab") && ($state == 4)} { - if {$_cfield != "[lindex $order 0]"} { - _moveField backward - return -code break - } else { - set _cfield "[lindex $order 0]" - return -code continue - } - - # - # A right arrow key moves the insert cursor to the right one. - # - } elseif {$sym == "Right"} { - _forward - return -code break - - # - # A left arrow, backspace, or delete key moves the insert cursor - # to the left one. This is what you expect for the left arrow - # and since the whole widget always operates in overstrike mode, - # it makes the most sense for backspace and delete to do the same. - # - } elseif {$sym == "Left" || $sym == "BackSpace" || $sym == "Delete"} { - _backward - return -code break - - } elseif {($sym == "Control_L") || ($sym == "Shift_L") || \ - ($sym == "Control_R") || ($sym == "Shift_R")} { - return -code break - - # - # A Return key invokes the optionally specified command option. - # - } elseif {$sym == "Return"} { - uplevel #0 $itk_option(-command) - return -code break - } else { - bell - return -code break - } -} - -# ------------------------------------------------------------------ -# PROTECTED METHOD: _setField field -# -# Internal method which adjusts the field to be that of the -# argument, setting the insert cursor appropriately. -# ------------------------------------------------------------------ -itcl::body iwidgets::Datefield::_setField {field} { - set _cfield $field - - if {$itk_option(-int)} { - set year_pos 2 - set month_pos 5 - set day_pos 8 - } else { - set month_pos 0 - set day_pos 3 - set year_pos 8 - } - - switch $field { - "month" { - $itk_component(date) icursor $month_pos - } - "day" { - $itk_component(date) icursor $day_pos - } - "year" { - $itk_component(date) icursor $year_pos - } - default { - error "bad field: \"$field\", must be month, day or year" - } - } -} - -# ------------------------------------------------------------------ -# PROTECTED METHOD: _moveField -# -# Internal method for moving the field forward or backward by one. -# ------------------------------------------------------------------ -itcl::body iwidgets::Datefield::_moveField {direction} { - - set index [lsearch $_fields $_cfield] - - if {$direction == "forward"} { - set newIndex [expr {$index + 1}] - } else { - set newIndex [expr {$index - 1}] - } - - if {$newIndex == [llength $_fields]} { - set newIndex 0 - } - if {$newIndex < 0} { - set newIndex [expr {[llength $_fields] - 1}] - } - - _setField [lindex $_fields $newIndex] - - return -} - -# ------------------------------------------------------------------ -# PROTECTED METHOD: _whichField -# -# Internal method which returns the current field that the cursor -# is currently within. -# ------------------------------------------------------------------ -itcl::body iwidgets::Datefield::_whichField {} { - set icursor [$itk_component(date) index insert] - - if {$itk_option(-int)} { - switch $icursor { - 0 - 1 - 2 - 3 { - set _cfield "year" - } - 5 - 6 { - set _cfield "month" - } - 8 - 9 { - set _cfield "day" - } - } - } else { - switch $icursor { - 0 - 1 { - set _cfield "month" - } - 3 - 4 { - set _cfield "day" - } - 6 - 7 - 8 - 9 { - set _cfield "year" - } - } - } -} - -# ------------------------------------------------------------------ -# PROTECTED METHOD: _forward -# -# Internal method which moves the cursor forward by one character -# jumping over the slashes and wrapping. -# ------------------------------------------------------------------ -itcl::body iwidgets::Datefield::_forward {} { - set icursor [$itk_component(date) index insert] - - if {$itk_option(-int)} { - switch $icursor { - 3 { - _setField month - } - 6 { - _setField day - } - 9 - 10 { - _setField year - } - default { - $itk_component(date) icursor [expr {$icursor + 1}] - } - } - } else { - switch $icursor { - 1 { - _setField day - } - 4 { - _setField year - } - 9 - 10 { - _setField month - } - default { - $itk_component(date) icursor [expr {$icursor + 1}] - } - } - } -} - -# ------------------------------------------------------------------ -# PROTECTED METHOD: _backward -# -# Internal method which moves the cursor backward by one character -# jumping over the slashes and wrapping. -# ------------------------------------------------------------------ -itcl::body iwidgets::Datefield::_backward {} { - set icursor [$itk_component(date) index insert] - if {$itk_option(-int)} { - switch $icursor { - 8 { - _setField month - } - 5 { - _setField year - } - 0 { - _setField day - } - default { - $itk_component(date) icursor [expr {$icursor -1}] - } - } - } else { - switch $icursor { - 6 { - _setField day - } - 3 { - _setField month - } - 0 { - _setField year - } - default { - $itk_component(date) icursor [expr {$icursor -1}] - } - } - } -} - -# ------------------------------------------------------------------ -# PROTECTED METHOD: _lastDay month year -# -# Internal method which determines the last day of the month for -# the given month and year. We start at 28 and go forward till -# we fail. Crude but effective. -# ------------------------------------------------------------------ -itcl::body iwidgets::Datefield::_lastDay {month year} { - set lastone 28 - - for {set lastone 28} {$lastone < 32} {incr lastone} { - set nextone [expr $lastone + 1] - if {[catch {clock scan $month/$nextone/$year}] != 0} { - return $lastone - } - } -} diff --git a/iwidgets/library/dialog.itk b/iwidgets/library/dialog.itk deleted file mode 100644 index f2a2bfe..0000000 --- a/iwidgets/library/dialog.itk +++ /dev/null @@ -1,92 +0,0 @@ -# -# Dialog -# ---------------------------------------------------------------------- -# Implements a standard dialog box providing standard buttons and a -# child site for use in derived classes. The buttons include ok, apply, -# cancel, and help. Options exist to configure the buttons. -# -# ---------------------------------------------------------------------- -# AUTHOR: Mark L. Ulferts EMAIL: mulferts@austin.dsccc.com -# -# @(#) $Id: dialog.itk,v 1.2 2001/08/07 19:56:47 smithc Exp $ -# ---------------------------------------------------------------------- -# Copyright (c) 1995 DSC Technologies Corporation -# ====================================================================== -# Permission to use, copy, modify, distribute and license this software -# and its documentation for any purpose, and without fee or written -# agreement with DSC, is hereby granted, provided that the above copyright -# notice appears in all copies and that both the copyright notice and -# warranty disclaimer below appear in supporting documentation, and that -# the names of DSC Technologies Corporation or DSC Communications -# Corporation not be used in advertising or publicity pertaining to the -# software without specific, written prior permission. -# -# DSC DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING -# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, 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. IN NO EVENT SHALL -# DSC BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR -# ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, -# WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION, -# ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS -# SOFTWARE. -# ====================================================================== - -# -# Usual options. -# -itk::usual Dialog { - keep -background -cursor -foreground -modality -} - -# ------------------------------------------------------------------ -# DIALOG -# ------------------------------------------------------------------ -itcl::class iwidgets::Dialog { - inherit iwidgets::Dialogshell - - constructor {args} {} -} - -# -# Provide a lowercased access method for the Dialog class. -# -proc ::iwidgets::dialog {pathName args} { - uplevel ::iwidgets::Dialog $pathName $args -} - -# -# Use option database to override default resources of base classes. -# -option add *Dialog.master "." widgetDefault - -# ------------------------------------------------------------------ -# CONSTRUCTOR -# ------------------------------------------------------------------ -itcl::body iwidgets::Dialog::constructor {args} { - # - # Add the standard buttons: OK, Apply, Cancel, and Help, making - # OK be the default button. - # - add OK -text OK -command [itcl::code $this deactivate 1] - add Apply -text Apply - add Cancel -text Cancel -command [itcl::code $this deactivate 0] - add Help -text Help - - default OK - - # - # Bind the window manager delete protocol to invocation of the - # cancel button. This can be overridden by the user via the - # execution of a similar command outside the class. - # - wm protocol $itk_component(hull) WM_DELETE_WINDOW \ - [itcl::code $this invoke Cancel] - - # - # Initialize the widget based on the command line options. - # - eval itk_initialize $args -} - diff --git a/iwidgets/library/dialogshell.itk b/iwidgets/library/dialogshell.itk deleted file mode 100644 index 7f9fb6b..0000000 --- a/iwidgets/library/dialogshell.itk +++ /dev/null @@ -1,350 +0,0 @@ -# Dialogshell -# ---------------------------------------------------------------------- -# This class is implements a dialog shell which is a top level widget -# composed of a button box, separator, and child site area. The class -# also has methods to control button construction. -# -# ---------------------------------------------------------------------- -# AUTHOR: Mark L. Ulferts EMAIL: mulferts@austin.dsccc.com -# -# @(#) $Id: dialogshell.itk,v 1.3 2001/08/15 18:32:02 smithc Exp $ -# ---------------------------------------------------------------------- -# Copyright (c) 1995 DSC Technologies Corporation -# ====================================================================== -# Permission to use, copy, modify, distribute and license this software -# and its documentation for any purpose, and without fee or written -# agreement with DSC, is hereby granted, provided that the above copyright -# notice appears in all copies and that both the copyright notice and -# warranty disclaimer below appear in supporting documentation, and that -# the names of DSC Technologies Corporation or DSC Communications -# Corporation not be used in advertising or publicity pertaining to the -# software without specific, written prior permission. -# -# DSC DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING -# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, 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. IN NO EVENT SHALL -# DSC BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR -# ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, -# WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION, -# ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS -# SOFTWARE. -# ====================================================================== - -# -# Usual options. -# -itk::usual Dialogshell { - keep -background -cursor -foreground -modality -} - -# ------------------------------------------------------------------ -# DIALOGSHELL -# ------------------------------------------------------------------ -itcl::class iwidgets::Dialogshell { - inherit iwidgets::Shell - - constructor {args} {} - - itk_option define -thickness thickness Thickness 3 - itk_option define -buttonboxpos buttonBoxPos Position s - itk_option define -separator separator Separator on - itk_option define -padx padX Pad 10 - itk_option define -pady padY Pad 10 - - public method childsite {} - public method index {args} - public method add {args} - public method insert {args} - public method delete {args} - public method hide {args} - public method show {args} - public method default {args} - public method invoke {args} - public method buttonconfigure {args} - public method buttoncget {index option} -} - -# -# Provide a lowercased access method for the Dialogshell class. -# -proc ::iwidgets::dialogshell {pathName args} { - uplevel ::iwidgets::Dialogshell $pathName $args -} - -# -# Use option database to override default resources of base classes. -# -option add *Dialogshell.master "." widgetDefault - -# ------------------------------------------------------------------ -# CONSTRUCTOR -# ------------------------------------------------------------------ -itcl::body iwidgets::Dialogshell::constructor {args} { - itk_option remove iwidgets::Shell::padx iwidgets::Shell::pady - - # - # Create the user child site, separator, and button box, - # - itk_component add -protected dschildsite { - frame $itk_interior.dschildsite - } - - itk_component add separator { - frame $itk_interior.separator -relief sunken - } - - itk_component add bbox { - iwidgets::Buttonbox $itk_interior.bbox - } { - usual - - rename -padx -buttonboxpadx buttonBoxPadX Pad - rename -pady -buttonboxpady buttonBoxPadY Pad - } - - # - # Set the itk_interior variable to be the childsite for derived - # classes. - # - set itk_interior $itk_component(dschildsite) - - # - # Set up the default button so that if is pressed in - # any widget, it will invoke the default button. - # - bind $itk_component(hull) [itcl::code $this invoke] - - # - # Initialize the widget based on the command line options. - # - eval itk_initialize $args -} - -# ------------------------------------------------------------------ -# OPTIONS -# ------------------------------------------------------------------ - -# ------------------------------------------------------------------ -# OPTION: -thickness -# -# Specifies the thickness of the separator. It sets the width and -# height of the separator to the thickness value and the borderwidth -# to half the thickness. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Dialogshell::thickness { - $itk_component(separator) config -height $itk_option(-thickness) - $itk_component(separator) config -width $itk_option(-thickness) - $itk_component(separator) config \ - -borderwidth [expr {$itk_option(-thickness) / 2}] -} - -# ------------------------------------------------------------------ -# OPTION: -buttonboxpos -# -# Specifies the position of the button box relative to the child site. -# The separator appears between the child site and button box. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Dialogshell::buttonboxpos { - set parent [winfo parent $itk_component(bbox)] - - switch $itk_option(-buttonboxpos) { - n { - $itk_component(bbox) configure -orient horizontal - - grid $itk_component(bbox) -row 0 -column 0 -sticky ew - grid $itk_component(separator) -row 1 -column 0 -sticky ew - grid $itk_component(dschildsite) -row 2 -column 0 -sticky nsew - - grid rowconfigure $parent 0 -weight 0 - grid rowconfigure $parent 1 -weight 0 - grid rowconfigure $parent 2 -weight 1 - grid columnconfigure $parent 0 -weight 1 - grid columnconfigure $parent 1 -weight 0 - grid columnconfigure $parent 2 -weight 0 - } - s { - $itk_component(bbox) configure -orient horizontal - - grid $itk_component(dschildsite) -row 0 -column 0 -sticky nsew - grid $itk_component(separator) -row 1 -column 0 -sticky ew - grid $itk_component(bbox) -row 2 -column 0 -sticky ew - - grid rowconfigure $parent 0 -weight 1 - grid rowconfigure $parent 1 -weight 0 - grid rowconfigure $parent 2 -weight 0 - grid columnconfigure $parent 0 -weight 1 - grid columnconfigure $parent 1 -weight 0 - grid columnconfigure $parent 2 -weight 0 - } - w { - $itk_component(bbox) configure -orient vertical - - grid $itk_component(bbox) -row 0 -column 0 -sticky ns - grid $itk_component(separator) -row 0 -column 1 -sticky ns - grid $itk_component(dschildsite) -row 0 -column 2 -sticky nsew - - grid rowconfigure $parent 0 -weight 1 - grid rowconfigure $parent 1 -weight 0 - grid rowconfigure $parent 2 -weight 0 - grid columnconfigure $parent 0 -weight 0 - grid columnconfigure $parent 1 -weight 0 - grid columnconfigure $parent 2 -weight 1 - } - e { - $itk_component(bbox) configure -orient vertical - - grid $itk_component(dschildsite) -row 0 -column 0 -sticky nsew - grid $itk_component(separator) -row 0 -column 1 -sticky ns - grid $itk_component(bbox) -row 0 -column 2 -sticky ns - - grid rowconfigure $parent 0 -weight 1 - grid rowconfigure $parent 1 -weight 0 - grid rowconfigure $parent 2 -weight 0 - grid columnconfigure $parent 0 -weight 1 - grid columnconfigure $parent 1 -weight 0 - grid columnconfigure $parent 2 -weight 0 - } - default { - error "bad buttonboxpos option\ - \"$itk_option(-buttonboxpos)\": should be n,\ - s, e, or w" - } - } -} - -# ------------------------------------------------------------------ -# OPTION: -separator -# -# Boolean option indicating wheather to display the separator. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Dialogshell::separator { - if {$itk_option(-separator)} { - $itk_component(separator) configure -relief sunken - } else { - $itk_component(separator) configure -relief flat - } -} - -# ------------------------------------------------------------------ -# OPTION: -padx -# -# Specifies a padding distance for the childsite in the X-direction. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Dialogshell::padx { - grid configure $itk_component(dschildsite) -padx $itk_option(-padx) -} - -# ------------------------------------------------------------------ -# OPTION: -pady -# -# Specifies a padding distance for the childsite in the Y-direction. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Dialogshell::pady { - grid configure $itk_component(dschildsite) -pady $itk_option(-pady) -} - -# ------------------------------------------------------------------ -# METHODS -# ------------------------------------------------------------------ - -# ------------------------------------------------------------------ -# METHOD: childsite -# -# Return the pathname of the user accessible area. -# ------------------------------------------------------------------ -itcl::body iwidgets::Dialogshell::childsite {} { - return $itk_component(dschildsite) -} - -# ------------------------------------------------------------------ -# METHOD: index index -# -# Thin wrapper of Buttonbox's index method. -# ------------------------------------------------------------------ -itcl::body iwidgets::Dialogshell::index {args} { - uplevel $itk_component(bbox) index $args -} - -# ------------------------------------------------------------------ -# METHOD: add tag ?option value ...? -# -# Thin wrapper of Buttonbox's add method. -# ------------------------------------------------------------------ -itcl::body iwidgets::Dialogshell::add {args} { - uplevel $itk_component(bbox) add $args -} - -# ------------------------------------------------------------------ -# METHOD: insert index tag ?option value ...? -# -# Thin wrapper of Buttonbox's insert method. -# ------------------------------------------------------------------ -itcl::body iwidgets::Dialogshell::insert {args} { - uplevel $itk_component(bbox) insert $args -} - -# ------------------------------------------------------------------ -# METHOD: delete tag -# -# Thin wrapper of Buttonbox's delete method. -# ------------------------------------------------------------------ -itcl::body iwidgets::Dialogshell::delete {args} { - uplevel $itk_component(bbox) delete $args -} - -# ------------------------------------------------------------------ -# METHOD: hide index -# -# Thin wrapper of Buttonbox's hide method. -# ------------------------------------------------------------------ -itcl::body iwidgets::Dialogshell::hide {args} { - uplevel $itk_component(bbox) hide $args -} - -# ------------------------------------------------------------------ -# METHOD: show index -# -# Thin wrapper of Buttonbox's show method. -# ------------------------------------------------------------------ -itcl::body iwidgets::Dialogshell::show {args} { - uplevel $itk_component(bbox) show $args -} - -# ------------------------------------------------------------------ -# METHOD: default index -# -# Thin wrapper of Buttonbox's default method. -# ------------------------------------------------------------------ -itcl::body iwidgets::Dialogshell::default {args} { - uplevel $itk_component(bbox) default $args -} - -# ------------------------------------------------------------------ -# METHOD: invoke ?index? -# -# Thin wrapper of Buttonbox's invoke method. -# ------------------------------------------------------------------ -itcl::body iwidgets::Dialogshell::invoke {args} { - uplevel $itk_component(bbox) invoke $args -} - -# ------------------------------------------------------------------ -# METHOD: buttonconfigure index ?option? ?value option value ...? -# -# Thin wrapper of Buttonbox's buttonconfigure method. -# ------------------------------------------------------------------ -itcl::body iwidgets::Dialogshell::buttonconfigure {args} { - uplevel $itk_component(bbox) buttonconfigure $args -} - -# ------------------------------------------------------------------ -# METHOD: buttoncget index option -# -# Thin wrapper of Buttonbox's buttoncget method. -# ------------------------------------------------------------------ -itcl::body iwidgets::Dialogshell::buttoncget {index option} { - uplevel $itk_component(bbox) buttoncget [list $index] \ - [list $option] -} diff --git a/iwidgets/library/disjointlistbox.itk b/iwidgets/library/disjointlistbox.itk deleted file mode 100644 index 5d34c67..0000000 --- a/iwidgets/library/disjointlistbox.itk +++ /dev/null @@ -1,533 +0,0 @@ -# -# ::iwidgets::Disjointlistbox -# ---------------------------------------------------------------------- -# Implements a widget which maintains a disjoint relationship between -# the items displayed by two listboxes. The disjointlistbox is composed -# of 2 Scrolledlistboxes, 2 Pushbuttons, and 2 labels. -# -# The disjoint behavior of this widget exists between the two Listboxes, -# That is, a given instance of a ::iwidgets::Disjointlistbox will never -# exist which has Listbox widgets with items in common. -# -# Users may transfer items between the two Listbox widgets using the -# the two Pushbuttons. -# -# The options include the ability to configure the "items" displayed by -# either of the two Listboxes and to control the placement of the insertion -# and removal buttons. -# -# The following depicts the allowable "-buttonplacement" option values -# and their associated layout: -# -# "-buttonplacement" => center -# -# -------------------------- -# |listbox| |listbox| -# | |________| | -# | (LHS) | button | (RHS) | -# | |========| | -# | | button | | -# |_______|--------|_______| -# | count | | count | -# -------------------------- -# -# "-buttonplacement" => bottom -# -# --------------------- -# | listbox | listbox | -# | (LHS) | (RHS) | -# |_________|_________| -# | button | button | -# |---------|---------| -# | count | count | -# --------------------- -# -# ---------------------------------------------------------------------- -# AUTHOR: John A. Tucker EMAIL: jatucker@spd.dsccc.com -# -# ====================================================================== - -# -# Default resources. -# -option add *Disjointlistbox.lhsLabelText Available widgetDefault -option add *Disjointlistbox.rhsLabelText Current widgetDefault -option add *Disjointlistbox.lhsButtonLabel {Insert >>} widgetDefault -option add *Disjointlistbox.rhsButtonLabel {<< Remove} widgetDefault -option add *Disjointlistbox.vscrollMode static widgetDefault -option add *Disjointlistbox.hscrollMode static widgetDefault -option add *Disjointlistbox.selectMode multiple widgetDefault -option add *Disjointlistbox.labelPos nw widgetDefault -option add *Disjointlistbox.buttonPlacement bottom widgetDefault -option add *Disjointlistbox.lhsSortOption increasing widgetDefault -option add *Disjointlistbox.rhsSortOption increasing widgetDefault - - -# -# Usual options. -# -itk::usual Disjointlistbox { - keep -background -textbackground -cursor \ - -foreground -textfont -labelfont -} - - -# ---------------------------------------------------------------------- -# ::iwidgets::Disjointlistbox -# ---------------------------------------------------------------------- -itcl::class ::iwidgets::Disjointlistbox { - - inherit itk::Widget - - # - # options - # - itk_option define -buttonplacement buttonPlacement ButtonPlacement bottom - itk_option define -lhsbuttonlabel lhsButtonLabel LabelText {Insert >>} - itk_option define -rhsbuttonlabel rhsButtonLabel LabelText {<< Remove} - itk_option define -lhssortoption lhsSortOption LhsSortOption increasing - itk_option define -rhssortoption rhsSortOption RhsSortOption increasing - - constructor {args} {} - - # - # PUBLIC - # - public { - method clear {} - method getlhs {{first 0} {last end}} - method getrhs {{first 0} {last end}} - method lhs {args} - method insertlhs {items} - method insertrhs {items} - method setlhs {items} - method setrhs {items} - method rhs {args} - } - - # - # PROTECTED - # - protected { - method insert {theListbox items} - method listboxClick {clickSide otherSide} - method listboxDblClick {clickSide otherSide} - method remove {theListbox items} - method showCount {} - method transfer {} - - variable sourceListbox {} - variable destinationListbox {} - } -} - -# -# Provide a lowercased access method for the ::iwidgets::Disjointlistbox class. -# -proc ::iwidgets::disjointlistbox {pathName args} { - uplevel ::iwidgets::Disjointlistbox $pathName $args -} - -# ------------------------------------------------------------------ -# -# Method: Constructor -# -# Purpose: -# -itcl::body ::iwidgets::Disjointlistbox::constructor {args} { - # - # Create the left-most Listbox - # - itk_component add lhs { - iwidgets::Scrolledlistbox $itk_interior.lhs \ - -selectioncommand [itcl::code $this listboxClick lhs rhs] \ - -dblclickcommand [itcl::code $this listboxDblClick lhs rhs] - } { - usual - keep -selectmode -vscrollmode -hscrollmode - rename -labeltext -lhslabeltext lhsLabelText LabelText - } - - # - # Create the right-most Listbox - # - itk_component add rhs { - iwidgets::Scrolledlistbox $itk_interior.rhs \ - -selectioncommand [itcl::code $this listboxClick rhs lhs] \ - -dblclickcommand [itcl::code $this listboxDblClick rhs lhs] - } { - usual - keep -selectmode -vscrollmode -hscrollmode - rename -labeltext -rhslabeltext rhsLabelText LabelText - } - - # - # Create the left-most item count Label - # - itk_component add lhsCount { - label $itk_interior.lhscount - } { - usual - rename -font -labelfont labelFont Font - } - - # - # Create the right-most item count Label - # - itk_component add rhsCount { - label $itk_interior.rhscount - } { - usual - rename -font -labelfont labelFont Font - } - - set sourceListbox $itk_component(lhs) - set destinationListbox $itk_component(rhs) - - # - # Bind the "showCount" method to the Map event of one of the labels - # to keep the diplayed item count current. - # - bind $itk_component(lhsCount) [itcl::code $this showCount] - - grid $itk_component(lhs) -row 0 -column 0 -sticky nsew - grid $itk_component(rhs) -row 0 -column 2 -sticky nsew - - grid rowconfigure $itk_interior 0 -weight 1 - grid columnconfigure $itk_interior 0 -weight 1 - grid columnconfigure $itk_interior 2 -weight 1 - - eval itk_initialize $args -} - -# ------------------------------------------------------------------ -# Method: listboxClick -# -# Purpose: Evaluate a single click make in the specified Listbox. -# -itcl::body ::iwidgets::Disjointlistbox::listboxClick {clickSide otherSide} { - set button "button" - $itk_component($clickSide$button) configure -state active - $itk_component($otherSide$button) configure -state disabled - set sourceListbox $clickSide - set destinationListbox $otherSide -} - -# ------------------------------------------------------------------ -# Method: listboxDblClick -# -# Purpose: Evaluate a double click in the specified Listbox. -# -itcl::body ::iwidgets::Disjointlistbox::listboxDblClick {clickSide otherSide} { - listboxClick $clickSide $otherSide - transfer -} - -# ------------------------------------------------------------------ -# Method: transfer -# -# Purpose: Transfer source Listbox items to destination Listbox -# -itcl::body ::iwidgets::Disjointlistbox::transfer {} { - - if {[$sourceListbox selecteditemcount] == 0} { - return - } - set selectedindices [lsort -integer -decreasing [$sourceListbox curselection]] - set selecteditems [$sourceListbox getcurselection] - - foreach index $selectedindices { - $sourceListbox delete $index - } - - foreach item $selecteditems { - $destinationListbox insert end $item - } - - if {![string equal $itk_option(-${destinationListbox}sortoption) "none"]} { - $destinationListbox sort $itk_option(-${destinationListbox}sortoption) - } - - showCount -} - -# ------------------------------------------------------------------ -# Method: getlhs -# -# Purpose: Retrieve the items of the left Listbox widget -# -itcl::body ::iwidgets::Disjointlistbox::getlhs {{first 0} {last end}} { - return [lhs get $first $last] -} - -# ------------------------------------------------------------------ -# Method: getrhs -# -# Purpose: Retrieve the items of the right Listbox widget -# -itcl::body ::iwidgets::Disjointlistbox::getrhs {{first 0} {last end}} { - return [rhs get $first $last] -} - -# ------------------------------------------------------------------ -# Method: insertrhs -# -# Purpose: Insert items into the right Listbox widget -# -itcl::body ::iwidgets::Disjointlistbox::insertrhs {items} { - remove $itk_component(lhs) $items - insert rhs $items -} - -# ------------------------------------------------------------------ -# Method: insertlhs -# -# Purpose: Insert items into the left Listbox widget -# -itcl::body ::iwidgets::Disjointlistbox::insertlhs {items} { - remove $itk_component(rhs) $items - insert lhs $items -} - -# ------------------------------------------------------------------ -# Method: clear -# -# Purpose: Remove the items from the Listbox widgets and set the item count -# Labels text to 0 -# -itcl::body ::iwidgets::Disjointlistbox::clear {} { - lhs clear - rhs clear - showCount -} - -# ------------------------------------------------------------------ -# Method: insert -# -# Purpose: Insert the input items into the input Listbox widget while -# maintaining the disjoint property between them. -# -itcl::body ::iwidgets::Disjointlistbox::insert {theListbox items} { - - set curritems [$theListbox get 0 end] - - foreach item $items { - # - # if the item is not already present in the Listbox then insert it - # - if {[lsearch -exact $curritems $item] == -1} { - $theListbox insert end $item - } - } - - if {![string equal $itk_option(-${theListbox}sortoption) "none"]} { - $theListbox sort $itk_option(-${theListbox}sortoption) - } - - showCount -} - -# ------------------------------------------------------------------ -# Method: remove -# -# Purpose: Remove the input items from the input Listbox widget while -# maintaining the disjoint property between them. -# -itcl::body ::iwidgets::Disjointlistbox::remove {theListbox items} { - - set indexes {} - set curritems [$theListbox get 0 end] - - foreach item $items { - # - # if the item is in the listbox then add its index to the index list - # - if {[set index [lsearch -exact $curritems $item]] != -1} { - lappend indexes $index - } - } - - foreach index [lsort -integer -decreasing $indexes] { - $theListbox delete $index - } - showCount -} - -# ------------------------------------------------------------------ -# Method: showCount -# -# Purpose: Set the text of the item count Labels. -# -itcl::body ::iwidgets::Disjointlistbox::showCount {} { - $itk_component(lhsCount) config -text "item count: [lhs size]" - $itk_component(rhsCount) config -text "item count: [rhs size]" -} - -# ------------------------------------------------------------------ -# METHOD: setlhs -# -# Set the items of the left-most Listbox with the input list -# option. Remove all (if any) items from the right-most Listbox -# which exist in the input list option to maintain the disjoint -# property between the two -# -itcl::body ::iwidgets::Disjointlistbox::setlhs {items} { - lhs clear - insertlhs $items -} - -# ------------------------------------------------------------------ -# METHOD: setrhs -# -# Set the items of the right-most Listbox with the input list -# option. Remove all (if any) items from the left-most Listbox -# which exist in the input list option to maintain the disjoint -# property between the two -# -itcl::body ::iwidgets::Disjointlistbox::setrhs {items} { - rhs clear - insertrhs $items -} - -# ------------------------------------------------------------------ -# Method: lhs -# -# Purpose: Evaluates the specified arguments against the lhs Listbox -# -itcl::body ::iwidgets::Disjointlistbox::lhs {args} { - return [eval $itk_component(lhs) $args] -} - -# ------------------------------------------------------------------ -# Method: rhs -# -# Purpose: Evaluates the specified arguments against the rhs Listbox -# -itcl::body ::iwidgets::Disjointlistbox::rhs {args} { - return [eval $itk_component(rhs) $args] -} - -# ------------------------------------------------------------------ -# OPTION: buttonplacement -# -# Configure the placement of the buttons to be either between or below -# the two list boxes. -# -itcl::configbody ::iwidgets::Disjointlistbox::buttonplacement { - if {$itk_option(-buttonplacement) != ""} { - - if { [lsearch [component] lhsbutton] != -1 } { - eval destroy $itk_component(rhsbutton) $itk_component(lhsbutton) - } - - if { [lsearch [component] bbox] != -1 } { - destroy $itk_component(bbox) - } - - set where $itk_option(-buttonplacement) - - switch $where { - - center { - # - # Create the button box frame - # - itk_component add bbox { - frame $itk_interior.bbox - } - - itk_component add lhsbutton { - button $itk_component(bbox).lhsbutton -command [itcl::code \ - $this transfer] - } { - usual - rename -text -lhsbuttonlabel lhsButtonLabel LabelText - rename -font -labelfont labelFont Font - } - - itk_component add rhsbutton { - button $itk_component(bbox).rhsbutton -command [itcl::code \ - $this transfer] - } { - usual - rename -text -rhsbuttonlabel rhsButtonLabel LabelText - rename -font -labelfont labelFont Font - } - - grid configure $itk_component(lhsCount) -row 1 -column 0 \ - -sticky ew - grid configure $itk_component(rhsCount) -row 1 -column 2 \ - -sticky ew - - grid configure $itk_component(bbox) \ - -in $itk_interior -row 0 -column 1 -columnspan 1 \ - -sticky nsew - - # Tk8.5: enforce compatibility to previous versions - # see Tk-ticket 2062394 - catch {grid anchor $itk_component(bbox) center} - - grid configure $itk_component(rhsbutton) \ - -in $itk_component(bbox) -row 0 -column 0 -sticky ew - grid configure $itk_component(lhsbutton) \ - -in $itk_component(bbox) -row 1 -column 0 -sticky ew - } - - bottom { - - itk_component add lhsbutton { - button $itk_interior.lhsbutton -command [itcl::code $this \ - transfer] - } { - usual - rename -text -lhsbuttonlabel lhsButtonLabel LabelText - rename -font -labelfont labelFont Font - } - - itk_component add rhsbutton { - button $itk_interior.rhsbutton -command [itcl::code $this \ - transfer] - } { - usual - rename -text -rhsbuttonlabel rhsButtonLabel LabelText - rename -font -labelfont labelFont Font - } - - grid $itk_component(lhsCount) -row 2 -column 0 -sticky ew - grid $itk_component(rhsCount) -row 2 -column 2 -sticky ew - grid $itk_component(lhsbutton) -row 1 -column 0 -sticky ew - grid $itk_component(rhsbutton) -row 1 -column 2 -sticky ew - } - - default { - error "bad buttonplacement option\"$where\": should be center\ - or bottom" - } - } - } -} - -# ------------------------------------------------------------------ -# OPTION: lhssortoption -# -# Configure the sort option to use for the left side -# -itcl::configbody ::iwidgets::Disjointlistbox::lhssortoption { - - if {![string equal $itk_option(-lhssortoption) "none"]} { - $itk_component(lhs) sort $itk_option(-lhssortoption) - } -} - - -# ------------------------------------------------------------------ -# OPTION: rhssortoption -# -# Configure the sort option to use for the right side -# -itcl::configbody ::iwidgets::Disjointlistbox::rhssortoption { - - if {![string equal $itk_option(-rhssortoption) "none"]} { - $itk_component(rhs) sort $itk_option(-rhssortoption) - } -} diff --git a/iwidgets/library/entryfield.itk b/iwidgets/library/entryfield.itk deleted file mode 100644 index ca4ff1a..0000000 --- a/iwidgets/library/entryfield.itk +++ /dev/null @@ -1,610 +0,0 @@ -# -# Entryfield -# ---------------------------------------------------------------------- -# Implements an enhanced text entry widget. -# -# ---------------------------------------------------------------------- -# AUTHOR: Sue Yockey E-mail: yockey@acm.org -# Mark L. Ulferts E-mail: mulferts@austin.dsccc.com -# -# @(#) $Id: entryfield.itk,v 1.7 2002/09/23 05:10:38 mgbacke Exp $ -# ---------------------------------------------------------------------- -# Copyright (c) 1995 DSC Technologies Corporation -# ====================================================================== -# Permission to use, copy, modify, distribute and license this software -# and its documentation for any purpose, and without fee or written -# agreement with DSC, is hereby granted, provided that the above copyright -# notice appears in all copies and that both the copyright notice and -# warranty disclaimer below appear in supporting documentation, and that -# the names of DSC Technologies Corporation or DSC Communications -# Corporation not be used in advertising or publicity pertaining to the -# software without specific, written prior permission. -# -# DSC DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING -# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, 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. IN NO EVENT SHALL -# DSC BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR -# ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, -# WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION, -# ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS -# SOFTWARE. -# ====================================================================== - -# -# Usual options. -# -itk::usual Entryfield { - keep -background -borderwidth -cursor -foreground -highlightcolor \ - -highlightthickness -insertbackground -insertborderwidth \ - -insertofftime -insertontime -insertwidth -labelfont \ - -selectbackground -selectborderwidth -selectforeground \ - -textbackground -textfont -} - -# ------------------------------------------------------------------ -# ENTRYFIELD -# ------------------------------------------------------------------ -itcl::class iwidgets::Entryfield { - inherit iwidgets::Labeledwidget - - constructor {args} {} - - itk_option define -childsitepos childSitePos Position e - itk_option define -command command Command {} - itk_option define -fixed fixed Fixed 0 - itk_option define -focuscommand focusCommand Command {} - itk_option define -invalid invalid Command {bell} - itk_option define -pasting pasting Behavior 1 - itk_option define -validate validate Command {} - - public { - method childsite {} - method get {} - method delete {args} - method icursor {args} - method index {args} - method insert {args} - method scan {args} - method selection {args} - method xview {args} - method clear {} - } - - proc numeric {char} {} - proc integer {string} {} - proc alphabetic {char} {} - proc alphanumeric {char} {} - proc hexidecimal {string} {} - proc real {string} {} - - protected { - method _focusCommand {} - method _keyPress {char sym state} - } - - private method _peek {char} - private method _checkLength {} -} - -# -# Provide a lowercased access method for the Entryfield class. -# -proc ::iwidgets::entryfield {pathName args} { - uplevel ::iwidgets::Entryfield $pathName $args -} - -# ------------------------------------------------------------------ -# CONSTRUCTOR -# ------------------------------------------------------------------ -itcl::body iwidgets::Entryfield::constructor {args} { - component hull configure -borderwidth 0 - - itk_component add entry { - entry $itk_interior.entry - } { - keep -borderwidth -cursor -exportselection \ - -foreground -highlightcolor \ - -highlightthickness -insertbackground -insertborderwidth \ - -insertofftime -insertontime -insertwidth -justify \ - -relief -selectbackground -selectborderwidth \ - -selectforeground -show -state -textvariable -width - - rename -font -textfont textFont Font - rename -highlightbackground -background background Background - rename -background -textbackground textBackground Background - } - - # - # Create the child site widget. - # - itk_component add -protected efchildsite { - frame $itk_interior.efchildsite - } - set itk_interior $itk_component(efchildsite) - - # - # Entryfield instance bindings. - # - bind $itk_component(entry) [itcl::code $this _keyPress %A %K %s] - bind $itk_component(entry) [itcl::code $this _focusCommand] - - # - # Initialize the widget based on the command line options. - # - eval itk_initialize $args -} - -# ------------------------------------------------------------------ -# OPTIONS -# ------------------------------------------------------------------ - -# ------------------------------------------------------------------ -# OPTION: -command -# -# Command associated upon detection of Return key press event -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Entryfield::command {} - -# ------------------------------------------------------------------ -# OPTION: -focuscommand -# -# Command associated upon detection of focus. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Entryfield::focuscommand {} - -# ------------------------------------------------------------------ -# OPTION: -validate -# -# Specify a command to executed for the validation of Entryfields. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Entryfield::validate { - switch $itk_option(-validate) { - {} { - set itk_option(-validate) {} - } - numeric { - set itk_option(-validate) "::iwidgets::Entryfield::numeric %c" - } - integer { - set itk_option(-validate) "::iwidgets::Entryfield::integer %P" - } - hexidecimal { - set itk_option(-validate) "::iwidgets::Entryfield::hexidecimal %P" - } - real { - set itk_option(-validate) "::iwidgets::Entryfield::real %P" - } - alphabetic { - set itk_option(-validate) "::iwidgets::Entryfield::alphabetic %c" - } - alphanumeric { - set itk_option(-validate) "::iwidgets::Entryfield::alphanumeric %c" - } - } -} - -# ------------------------------------------------------------------ -# OPTION: -invalid -# -# Specify a command to executed should the current Entryfield contents -# be proven invalid. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Entryfield::invalid {} - -# ------------------------------------------------------------------ -# OPTION: -pasting -# -# Allows the developer to enable and disable pasting into the entry -# component of the entryfield. This is done to avoid potential stack -# dumps when using the -validate configuration option. Plus, it's just -# a good idea to have complete control over what you allow the user -# to enter into the entryfield. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Entryfield::pasting { - set oldtags [bindtags $itk_component(entry)] - if {[lindex $oldtags 0] != "pastetag"} { - bindtags $itk_component(entry) [linsert $oldtags 0 pastetag] - } - - if {($itk_option(-pasting))} { - bind pastetag [itcl::code $this _checkLength] - bind pastetag [itcl::code $this _checkLength] - bind pastetag [itcl::code $this _checkLength] - bind pastetag {} - } else { - bind pastetag {break} - bind pastetag {break} - bind pastetag {break} - bind pastetag { - # Disable function keys > F9. - if {[regexp {^F[1,2][0-9]+$} "%K"]} { - break - } - } - } -} - -# ------------------------------------------------------------------ -# OPTION: -fixed -# -# Restrict entry to 0 (unlimited) chars. The value is the maximum -# number of chars the user may type into the field, regardles of -# field width, i.e. the field width may be 20, but the user will -# only be able to type -fixed number of characters into it (or -# unlimited if -fixed = 0). -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Entryfield::fixed { - if {[regexp {[^0-9]} $itk_option(-fixed)] || \ - ($itk_option(-fixed) < 0)} { - error "bad fixed option \"$itk_option(-fixed)\",\ - should be positive integer" - } -} - -# ------------------------------------------------------------------ -# OPTION: -childsitepos -# -# Specifies the position of the child site in the widget. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Entryfield::childsitepos { - set parent [winfo parent $itk_component(entry)] - - switch $itk_option(-childsitepos) { - n { - grid $itk_component(efchildsite) -row 0 -column 0 -sticky ew - grid $itk_component(entry) -row 1 -column 0 -sticky nsew - - grid rowconfigure $parent 0 -weight 0 - grid rowconfigure $parent 1 -weight 1 - grid columnconfigure $parent 0 -weight 1 - grid columnconfigure $parent 1 -weight 0 - } - - e { - grid $itk_component(efchildsite) -row 0 -column 1 -sticky ns - grid $itk_component(entry) -row 0 -column 0 -sticky nsew - - grid rowconfigure $parent 0 -weight 1 - grid rowconfigure $parent 1 -weight 0 - grid columnconfigure $parent 0 -weight 1 - grid columnconfigure $parent 1 -weight 0 - } - - s { - grid $itk_component(efchildsite) -row 1 -column 0 -sticky ew - grid $itk_component(entry) -row 0 -column 0 -sticky nsew - - grid rowconfigure $parent 0 -weight 1 - grid rowconfigure $parent 1 -weight 0 - grid columnconfigure $parent 0 -weight 1 - grid columnconfigure $parent 1 -weight 0 - } - - w { - grid $itk_component(efchildsite) -row 0 -column 0 -sticky ns - grid $itk_component(entry) -row 0 -column 1 -sticky nsew - - grid rowconfigure $parent 0 -weight 1 - grid rowconfigure $parent 1 -weight 0 - grid columnconfigure $parent 0 -weight 0 - grid columnconfigure $parent 1 -weight 1 - } - - default { - error "bad childsite option\ - \"$itk_option(-childsitepos)\":\ - should be n, e, s, or w" - } - } -} - -# ------------------------------------------------------------------ -# METHODS -# ------------------------------------------------------------------ - -# ------------------------------------------------------------------ -# METHOD: childsite -# -# Returns the path name of the child site widget. -# ------------------------------------------------------------------ -itcl::body iwidgets::Entryfield::childsite {} { - return $itk_component(efchildsite) -} - -# ------------------------------------------------------------------ -# METHOD: get -# -# Thin wrap of the standard entry widget get method. -# ------------------------------------------------------------------ -itcl::body iwidgets::Entryfield::get {} { - return [$itk_component(entry) get] -} - -# ------------------------------------------------------------------ -# METHOD: delete -# -# Thin wrap of the standard entry widget delete method. -# ------------------------------------------------------------------ -itcl::body iwidgets::Entryfield::delete {args} { - return [eval $itk_component(entry) delete $args] -} - -# ------------------------------------------------------------------ -# METHOD: icursor -# -# Thin wrap of the standard entry widget icursor method. -# ------------------------------------------------------------------ -itcl::body iwidgets::Entryfield::icursor {args} { - return [eval $itk_component(entry) icursor $args] -} - -# ------------------------------------------------------------------ -# METHOD: index -# -# Thin wrap of the standard entry widget index method. -# ------------------------------------------------------------------ -itcl::body iwidgets::Entryfield::index {args} { - return [eval $itk_component(entry) index $args] -} - -# ------------------------------------------------------------------ -# METHOD: insert -# -# Thin wrap of the standard entry widget index method. -# ------------------------------------------------------------------ -itcl::body iwidgets::Entryfield::insert {args} { - return [eval $itk_component(entry) insert $args] -} - -# ------------------------------------------------------------------ -# METHOD: scan -# -# Thin wrap of the standard entry widget scan method. -# ------------------------------------------------------------------ -itcl::body iwidgets::Entryfield::scan {args} { - return [eval $itk_component(entry) scan $args] -} - -# ------------------------------------------------------------------ -# METHOD: selection -# -# Thin wrap of the standard entry widget selection method. -# ------------------------------------------------------------------ -itcl::body iwidgets::Entryfield::selection {args} { - return [eval $itk_component(entry) selection $args] -} - -# ------------------------------------------------------------------ -# METHOD: xview -# -# Thin wrap of the standard entry widget xview method. -# ------------------------------------------------------------------ -itcl::body iwidgets::Entryfield::xview {args} { - return [eval $itk_component(entry) xview $args] -} - -# ------------------------------------------------------------------ -# METHOD: clear -# -# Delete the current entry contents. -# ------------------------------------------------------------------ -itcl::body iwidgets::Entryfield::clear {} { - $itk_component(entry) delete 0 end - icursor 0 -} - -# ------------------------------------------------------------------ -# PROCEDURE: numeric char -# -# The numeric procedure validates character input for a given -# Entryfield to be numeric and returns the result. -# ------------------------------------------------------------------ -itcl::body iwidgets::Entryfield::numeric {char} { - return [regexp {[0-9]} $char] -} - -# ------------------------------------------------------------------ -# PROCEDURE: integer string -# -# The integer procedure validates character input for a given -# Entryfield to be integer and returns the result. -# ------------------------------------------------------------------ -itcl::body iwidgets::Entryfield::integer {string} { - return [regexp {^[-+]?[0-9]*$} $string] -} - -# ------------------------------------------------------------------ -# PROCEDURE: alphabetic char -# -# The alphabetic procedure validates character input for a given -# Entryfield to be alphabetic and returns the result. -# ------------------------------------------------------------------ -itcl::body iwidgets::Entryfield::alphabetic {char} { - return [regexp -nocase {[a-z]} $char] -} - -# ------------------------------------------------------------------ -# PROCEDURE: alphanumeric char -# -# The alphanumeric procedure validates character input for a given -# Entryfield to be alphanumeric and returns the result. -# ------------------------------------------------------------------ -itcl::body iwidgets::Entryfield::alphanumeric {char} { - return [regexp -nocase {[0-9a-z]} $char] -} - -# ------------------------------------------------------------------ -# PROCEDURE: hexadecimal string -# -# The hexidecimal procedure validates character input for a given -# Entryfield to be hexidecimal and returns the result. -# ------------------------------------------------------------------ -itcl::body iwidgets::Entryfield::hexidecimal {string} { - return [regexp {^(0x)?[0-9a-fA-F]*$} $string] -} - -# ------------------------------------------------------------------ -# PROCEDURE: real string -# -# The real procedure validates character input for a given Entryfield -# to be real and returns the result. -# ------------------------------------------------------------------ -itcl::body iwidgets::Entryfield::real {string} { - return [regexp {^[-+]?[0-9]*\.?[0-9]*([0-9]\.?[eE][-+]?[0-9]*)?$} $string] -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _peek char -# -# The peek procedure returns the value of the Entryfield with the -# char inserted at the insert position. -# ------------------------------------------------------------------ -itcl::body iwidgets::Entryfield::_peek {char} { - set str [get] - - set insertPos [index insert] - set firstPart [string range $str 0 [expr {$insertPos - 1}]] - set lastPart [string range $str $insertPos end] - - regsub -all {\\} "$char" {\\\\} char - append rtnVal $firstPart $char $lastPart - return $rtnVal -} - -# ------------------------------------------------------------------ -# PROTECTED METHOD: _focusCommand -# -# Method bound to focus event which evaluates the current command -# specified in the focuscommand option -# ------------------------------------------------------------------ -itcl::body iwidgets::Entryfield::_focusCommand {} { - uplevel #0 $itk_option(-focuscommand) -} - -# ------------------------------------------------------------------ -# PROTECTED METHOD: _keyPress -# -# Monitor the key press event checking for return keys, fixed width -# specification, and optional validation procedures. -# ------------------------------------------------------------------ -itcl::body iwidgets::Entryfield::_keyPress {char sym state} { - # - # A Return key invokes the optionally specified command option. - # - if {$sym == "Return"} { - if {$itk_option(-command) == ""} { - # - # Allow to propagate to parent if the -command option - # isn't defined. - # - return -code continue 1 - } - uplevel #0 $itk_option(-command) - return -code break 1 - } - - # - # Tabs, BackSpace, and Delete are passed on for other bindings. - # - if {($sym == "Tab") || ($sym == "BackSpace") || ($sym == "Delete")} { - return -code continue 1 - } - - # - # Character is not printable or the state is greater than one which - # means a modifier was used such as a control, meta key, or control - # or meta key with numlock down. - # - #----------------------------------------------------------- - # BUG FIX: csmith (Chad Smith: csmith@adc.com), 3/15/99 - #----------------------------------------------------------- - # The following conditional used to hardcode specific state values, such - # as "4" and "8". These values are used to detect , , etc. - # key combinations. On the windows platform, the key is state - # 16, and on the unix platform, the key is state 8. All - # and combinations should be masked out, regardless of the - # or status, and regardless of platform. - #----------------------------------------------------------- - set CTRL 4 - global tcl_platform - if {$tcl_platform(platform) == "unix"} { - set ALT 8 - } elseif {$tcl_platform(platform) == "windows"} { - set ALT 16 - } else { - # This is something other than UNIX or WINDOWS. Default to the - # old behavior (UNIX). - set ALT 8 - } - # Thanks to Rolf Schroedter for the following elegant conditional. This - # masks out all and key combinations. - if {($char == "") || ($state & ($CTRL | $ALT))} { - return -code continue 1 - } - - # - # If the fixed length option is not zero, then verify that the - # current length plus one will not exceed the limit. If so then - # invoke the invalid command procedure. - # - if {$itk_option(-fixed) != 0} { - if {[string length [get]] >= $itk_option(-fixed)} { - uplevel #0 $itk_option(-invalid) - return -code break 0 - } - } - - # - # The validate option may contain a keyword (numeric, alphabetic), - # the name of a procedure, or nothing. The numeric and alphabetic - # keywords engage typical base level checks. If a command procedure - # is specified, then invoke it with the object and character passed - # as arguments. If the validate procedure returns false, then the - # invalid procedure is called. - # - if {$itk_option(-validate) != {}} { - set cmd $itk_option(-validate) - - regsub -all "%W" "$cmd" $itk_component(hull) cmd - regsub -all "%P" "$cmd" [list [_peek $char]] cmd - regsub -all "%S" "$cmd" [list [get]] cmd - regsub -all "%c" "$cmd" [list $char] cmd - regsub -all {\\} "$cmd" {\\\\} cmd - - set valid [uplevel #0 $cmd] - - if {($valid == "") || ([regexp 0|false|off|no $valid])} { - uplevel #0 $itk_option(-invalid) - return -code break 0 - } - } - - return -code continue 1 -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _checkLength -# -# This method was added by csmith for SF ticket 227912. We need to -# to check the clipboard content before allowing any pasting into -# the entryfield to disallow text that is longer than the value -# specified by the -fixed option. -# ------------------------------------------------------------------ -itcl::body iwidgets::Entryfield::_checkLength {} { - if {$itk_option(-fixed) != 0} { - if {[catch {::selection get -selection CLIPBOARD} pending]} { - # Nothing in the clipboard. Check the primary selection. - if {[catch {::selection get -selection PRIMARY} pending]} { - # Nothing here either. Goodbye. - return - } - } - set len [expr {[string length $pending] + [string length [get]]}] - if {$len > $itk_option(-fixed)} { - uplevel #0 $itk_option(-invalid) - return -code break 0 - } - } -} diff --git a/iwidgets/library/extbutton.itk b/iwidgets/library/extbutton.itk deleted file mode 100644 index a898130..0000000 --- a/iwidgets/library/extbutton.itk +++ /dev/null @@ -1,439 +0,0 @@ -#------------------------------------------------------------------------------- -# Extbutton -#------------------------------------------------------------------------------- -# This [incr Widget] is pretty simple - it just extends the behavior of -# the Tk button by allowing the user to add a bitmap or an image, which -# can be placed at various locations relative to the text via the -imagepos -# configuration option. -# -#------------------------------------------------------------------------------- -# IMPORTANT NOTE: This [incr Widget] will only work with Tk 8.4 or later. -# -#------------------------------------------------------------------------------- -# AUTHOR: Chad Smith E-mail: csmith@adc.com, itclguy@yahoo.com -#------------------------------------------------------------------------------- -# Permission to use, copy, modify, distribute, and license this software -# and its documentation for any purpose is hereby granted as long as this -# comment block remains intact. -#------------------------------------------------------------------------------- - -# -# Default resources -# -option add *Extbutton.borderwidth 2 widgetDefault -option add *Extbutton.relief raised widgetDefault - -# -# Usual options -# -itk::usual Extbutton { - keep -cursor -font -} - -itcl::class iwidgets::Extbutton { - inherit itk::Widget - - constructor {args} {} - - itk_option define -activebackground activeBackground Foreground #ececec - itk_option define -bd borderwidth BorderWidth 2 - itk_option define -bitmap bitmap Bitmap {} - itk_option define -command command Command {} - itk_option define -defaultring defaultring DefaultRing 0 - itk_option define -defaultringpad defaultringpad Pad 4 - itk_option define -image image Image {} - itk_option define -imagepos imagePos Position w - itk_option define -relief relief Relief raised - itk_option define -state state State normal - itk_option define -text text Text {} - - public method invoke {} {eval $itk_option(-command)} - public method flash {} - - private method changeColor {event_} - private method sink {} - private method raise {} {configure -relief $_oldValues(-relief)} - - private variable _oldValues -} - - -# -# Provide the usual lowercase access command. -# -proc iwidgets::extbutton {path_ args} { - uplevel iwidgets::Extbutton $path_ $args -} - - -#------------------------------------------------------------------------------- -# OPTION: -bd -# -# DESCRIPTION: This isn't a new option. Similar to -image, we just need to -# repack the frame when the borderwidth changes. This option is kept by -# the private reliefframe component. -#------------------------------------------------------------------------------- -itcl::configbody iwidgets::Extbutton::bd { - pack $itk_component(frame) -padx 4 -pady 4 -} - - -#------------------------------------------------------------------------------- -# OPTION: -bitmap -# -# DESCRIPTION: This isn't a new option - we just need to reset the -image option -# so that the user can toggle back and forth between images and bitmaps. -# Otherwise, the image will take precedence and the user will be unable to -# change to a bitmap without manually setting the label component's -image to -# an empty string. This option is kept by the image component. -#------------------------------------------------------------------------------- -itcl::configbody iwidgets::Extbutton::bitmap { - if {$itk_option(-bitmap) == ""} { - return - } - if {$itk_option(-image) != ""} { - configure -image {} - } - pack $itk_component(frame) -padx 4 -pady 4 -} - - -#------------------------------------------------------------------------------- -# OPTION: -command -# -# DESCRIPTION: Invoke the given command to simulate the Tk button's -command -# option. The command is invoked on events only or by -# direct calls to the public invoke() method. -#------------------------------------------------------------------------------- -itcl::configbody iwidgets::Extbutton::command { - if {$itk_option(-command) == ""} { - return - } - - # Only create the tag binding if the button is operable. - if {$itk_option(-state) == "normal"} { - bind $this-commandtag [itcl::code $this invoke] - } - - # Associate the tag with each component if it's not already done. - if {[lsearch [bindtags $itk_interior] $this-commandtag] == -1} { - foreach component [component] { - bindtags [component $component] \ - [linsert [bindtags [component $component]] end $this-commandtag] - } - } -} - - -#------------------------------------------------------------------------------- -# OPTION: -defaultring -# -# DESCRIPTION: Controls display of the sunken frame surrounding the button. -# This option simulates the pushbutton iwidget -defaultring option. -#------------------------------------------------------------------------------- -itcl::configbody iwidgets::Extbutton::defaultring { - switch -- $itk_option(-defaultring) { - 1 {set ring 1} - 0 {set ring 0} - default { - error "Invalid option for -defaultring: \"$itk_option(-defaultring)\". \ - Should be 1 or 0." - } - } - - if ($ring) { - $itk_component(ring) configure -borderwidth 2 - pack $itk_component(reliefframe) -padx $itk_option(-defaultringpad) \ - -pady $itk_option(-defaultringpad) - } else { - $itk_component(ring) configure -borderwidth 0 - pack $itk_component(reliefframe) -padx 0 -pady 0 - } -} - - -#------------------------------------------------------------------------------- -# OPTION: -defaultringpad -# -# DESCRIPTION: The pad distance between the ring and the button. -#------------------------------------------------------------------------------- -itcl::configbody iwidgets::Extbutton::defaultringpad { - # Must be an integer. - if ![string is integer $itk_option(-defaultringpad)] { - error "Invalid value specified for -defaultringpad:\ - \"$itk_option(-defaultringpad)\". Must be an integer." - } - - # Let's go ahead and make the maximum padding 20 pixels. Surely no one - # will want more than that. - if {$itk_option(-defaultringpad) < 0 || $itk_option(-defaultringpad) > 20} { - error "Value for -defaultringpad must be between 0 and 20." - } - - # If the ring is displayed, repack it according to the new padding amount. - if {$itk_option(-defaultring)} { - pack $itk_component(reliefframe) -padx $itk_option(-defaultringpad) \ - -pady $itk_option(-defaultringpad) - } -} - - -#------------------------------------------------------------------------------- -# OPTION: -image -# -# DESCRIPTION: This isn't a new option - we just need to repack the frame after -# the image is changed in case the size is different than the previous one. -# This option is kept by the image component. -#------------------------------------------------------------------------------- -itcl::configbody iwidgets::Extbutton::image { - pack $itk_component(frame) -padx 4 -pady 4 -} - - -#------------------------------------------------------------------------------- -# OPTION: -imagepos -# -# DESCRIPTION: Allows the user to move the image to different locations areound -# the text. Valid options are n, nw, ne, s, sw, se e, en, es, w, wn or ws. -#------------------------------------------------------------------------------- -itcl::configbody iwidgets::Extbutton::imagepos { - switch -- $itk_option(-imagepos) { - n {set side top; set anchor center} - ne {set side top; set anchor e} - nw {set side top; set anchor w} - - s {set side bottom; set anchor center} - se {set side bottom; set anchor e} - sw {set side bottom; set anchor w} - - w {set side left; set anchor center} - wn {set side left; set anchor n} - ws {set side left; set anchor s} - - e {set side right; set anchor center} - en {set side right; set anchor n} - es {set side right; set anchor s} - - default { - error "Invalid option: \"$itk_option(-imagepos)\". \ - Must be n, nw, ne, s, sw, se e, en, es, w, wn or ws." - } - } - - pack $itk_component(image) -side $side -anchor $anchor - pack $itk_component(frame) -padx 4 -pady 4 -} - - -#------------------------------------------------------------------------------- -# OPTION: -relief -# -# DESCRIPTION: Move the frame component according to the relief to simulate -# the text in a Tk button when its relief is changed. -#------------------------------------------------------------------------------- -itcl::configbody iwidgets::Extbutton::relief { - update idletasks - switch -- $itk_option(-relief) { - flat - ridge - groove { - place $itk_component(frame) -x 5 -y 5 - } - - raised { - place $itk_component(frame) -x 4 -y 4 - } - - sunken { - place $itk_component(frame) -x 6 -y 6 - } - - default { - error "Invalid option: \"$itk_option(-relief)\". \ - Must be flat, ridge, groove, raised, or sunken." - } - } -} - - -#------------------------------------------------------------------------------- -# OPTION: -state -# -# DESCRIPTION: Simulate the button's -state option. -#------------------------------------------------------------------------------- -itcl::configbody iwidgets::Extbutton::state { - switch -- $itk_option(-state) { - disabled { - bind $itk_interior { } - bind $itk_interior { } - bind $this-sunkentag <1> { } - bind $this-raisedtag { } - bind $this-commandtag { } - set _oldValues(-fg) [cget -foreground] - set _oldValues(-cursor) [cget -cursor] - configure -foreground $itk_option(-disabledforeground) - configure -cursor "X_cursor red black" - } - - normal { - bind $itk_interior [itcl::code $this changeColor enter] - bind $itk_interior [itcl::code $this changeColor leave] - bind $this-sunkentag <1> [itcl::code $this sink] - bind $this-raisedtag [itcl::code $this raise] - bind $this-commandtag [itcl::code $this invoke] - configure -foreground $_oldValues(-fg) - configure -cursor $_oldValues(-cursor) - } - - default { - error "Bad option for -state: \"$itk_option(-state)\". Should be\ - normal or disabled." - } - } -} - - -#------------------------------------------------------------------------------- -# OPTION: -text -# -# DESCRIPTION: This isn't a new option. Similar to -image, we just need to -# repack the frame when the text changes. -#------------------------------------------------------------------------------- -itcl::configbody iwidgets::Extbutton::text { - pack $itk_component(frame) -padx 4 -pady 4 -} - - - -#------------------------------------------------------------------------------- -# CONSTRUCTOR -#------------------------------------------------------------------------------- -itcl::body iwidgets::Extbutton::constructor {args} { - # Extbutton will not work with versions of Tk less than 8.4 (the - # -activeforeground option was added to the Tk label widget in 8.4, for - # example). So disallow its use unless the right wish is being used. - if {$::tk_version < 8.4} { - error "The extbutton \[incr Widget\] can only be used with versions of\ - Tk greater than 8.3.\nYou're currently using version $::tk_version." - } - - # This frame is optionally displayed as a "default ring" around the button. - itk_component add ring { - frame $itk_interior.ring -relief sunken - } { - rename -background -ringbackground ringBackground Background - } - - # Add an outer frame for the widget's relief. Ideally we could just keep - # the hull's -relief, but it's too tricky to handle relief changes. - itk_component add -private reliefframe { - frame $itk_component(ring).f - } { - rename -borderwidth -bd borderwidth BorderWidth - keep -relief - usual - } - - # This frame contains the image and text. It will be moved slightly to - # simulate the text in a Tk button when the button is depressed/raised. - itk_component add frame { - frame $itk_component(reliefframe).f -borderwidth 0 - } - - itk_component add image { - label $itk_component(frame).img -borderwidth 0 - } { - keep -bitmap -background -image - rename -foreground -bitmapforeground foreground Foreground - } - - itk_component add label { - label $itk_component(frame).txt -borderwidth 0 - } { - keep -activeforeground -background -disabledforeground - keep -font -foreground -justify -text - } - - pack $itk_component(image) $itk_component(label) -side left -padx 6 -pady 4 - pack $itk_component(frame) -padx 4 -pady 4 - pack $itk_component(reliefframe) -fill both - pack $itk_component(ring) -fill both - - # Create a couple of binding tags for handling relief changes. Then - # add these tags to each component. - foreach component [component] { - bindtags [component $component] \ - [linsert [bindtags [component $component]] end $this-sunkentag] - bindtags [component $component] \ - [linsert [bindtags [component $component]] end $this-raisedtag] - } - - set _oldValues(-fg) [cget -foreground] - set _oldValues(-cursor) [cget -cursor] - - eval itk_initialize $args -} - - -#------------------------------------------------------------------------------- -# METHOD: flash -# -# ACCESS: public -# -# DESCRIPTION: Simulate the Tk button flash command. -# -# ARGUMENTS: none -#------------------------------------------------------------------------------- -itcl::body iwidgets::Extbutton::flash {} { - set oldbg [cget -background] - config -background $itk_option(-activebackground) - update idletasks - - after 50; config -background $oldbg; update idletasks - after 50; config -background $itk_option(-activebackground); update idletasks - after 50; config -background $oldbg -} - - -#------------------------------------------------------------------------------- -# METHOD: changeColor -# -# ACCESS: private -# -# DESCRIPTION: This method is invoked by and events to change -# the background and foreground colors of the widget. -# -# ARGUMENTS: event_ --> either "enter" or "leave" -#------------------------------------------------------------------------------- -itcl::body iwidgets::Extbutton::changeColor {event_} { - switch -- $event_ { - enter { - set _oldValues(-bg) [cget -background] - set _oldValues(-fg) [cget -foreground] - configure -background $itk_option(-activebackground) - configure -foreground $itk_option(-activeforeground) - } - leave { - configure -background $_oldValues(-bg) - configure -foreground $_oldValues(-fg) - } - } -} - - -#------------------------------------------------------------------------------- -# METHOD: sink -# -# ACCESS: private -# -# DESCRIPTION: This method is invoked on <1> mouse events. It saves the -# current relief for later restoral and configures the relief to sunken if -# it isn't already sunken. -# -# ARGUMENTS: none -#------------------------------------------------------------------------------- -itcl::body iwidgets::Extbutton::sink {} { - set _oldValues(-relief) [cget -relief] - if {$_oldValues(-relief) == "sunken"} { - return - } - configure -relief sunken -} diff --git a/iwidgets/library/extfileselectionbox.itk b/iwidgets/library/extfileselectionbox.itk deleted file mode 100644 index bf2d95d..0000000 --- a/iwidgets/library/extfileselectionbox.itk +++ /dev/null @@ -1,1187 +0,0 @@ -# -# Extfileselectionbox -# ---------------------------------------------------------------------- -# Implements a file selection box that is a slightly extended version -# of the OSF/Motif standard XmExtfileselectionbox composite widget. -# The Extfileselectionbox differs from the Motif standard in that the -# filter and selection fields are comboboxes and the files and directory -# lists are in a paned window. -# -# ---------------------------------------------------------------------- -# AUTHOR: Mark L. Ulferts EMAIL: mulferts@spd.dsccc.com -# Anthony L. Parent tony.parent@symbios.com -# -# @(#) $Id: extfileselectionbox.itk,v 1.6 2006/04/11 19:50:38 hobbs Exp $ -# ---------------------------------------------------------------------- -# Copyright (c) 1997 DSC Technologies Corporation -# ====================================================================== -# Permission to use, copy, modify, distribute and license this software -# and its documentation for any purpose, and without fee or written -# agreement with DSC, is hereby granted, provided that the above copyright -# notice appears in all copies and that both the copyright notice and -# warranty disclaimer below appear in supporting documentation, and that -# the names of DSC Technologies Corporation or DSC Communications -# Corporation not be used in advertising or publicity pertaining to the -# software without specific, written prior permission. -# -# DSC DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING -# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, 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. IN NO EVENT SHALL -# DSC BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR -# ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, -# WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION, -# ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS -# SOFTWARE. -# ====================================================================== - -# -# Usual options. -# -itk::usual Extfileselectionbox { - keep -activebackground -activerelief -background -borderwidth -cursor \ - -elementborderwidth -foreground -highlightcolor -highlightthickness \ - -insertbackground -insertborderwidth -insertofftime -insertontime \ - -insertwidth -jump -labelfont -selectbackground -selectborderwidth \ - -textbackground -textfont -troughcolor -} - -# ------------------------------------------------------------------ -# EXTFILESELECTIONBOX -# ------------------------------------------------------------------ -itcl::class iwidgets::Extfileselectionbox { - inherit itk::Widget - - constructor {args} {} - destructor {} - - itk_option define -childsitepos childSitePos Position s - itk_option define -fileson filesOn FilesOn true - itk_option define -dirson dirsOn DirsOn true - itk_option define -selectionon selectionOn SelectionOn true - itk_option define -filteron filterOn FilterOn true - itk_option define -mask mask Mask {*} - itk_option define -directory directory Directory {} - itk_option define -automount automount Automount {} - itk_option define -nomatchstring noMatchString NoMatchString {} - itk_option define -dirsearchcommand dirSearchCommand Command {} - itk_option define -filesearchcommand fileSearchCommand Command {} - itk_option define -selectioncommand selectionCommand Command {} - itk_option define -filtercommand filterCommand Command {} - itk_option define -selectdircommand selectDirCommand Command {} - itk_option define -selectfilecommand selectFileCommand Command {} - itk_option define -invalid invalid Command {bell} - itk_option define -filetype fileType FileType {regular} - itk_option define -width width Width 350 - itk_option define -height height Height 300 - - public { - method childsite {} - method get {} - method filter {} - } - - protected { - method _packComponents {{when later}} - method _updateLists {{when later}} - } - - private { - method _selectDir {} - method _dblSelectDir {} - method _selectFile {} - method _selectSelection {} - method _selectFilter {} - method _setFilter {} - method _setSelection {} - method _setDirList {} - method _setFileList {} - - method _nPos {} - method _sPos {} - method _ePos {} - method _wPos {} - method _topPos {} - method _bottomPos {} - - variable _packToken "" ;# non-null => _packComponents pending - variable _updateToken "" ;# non-null => _updateLists pending - variable _pwd "." ;# present working dir - variable _interior ;# original interior setting - } -} - -# -# Provide a lowercased access method for the Extfileselectionbox class. -# -proc ::iwidgets::extfileselectionbox {pathName args} { - uplevel ::iwidgets::Extfileselectionbox $pathName $args -} - -# -# Use option database to override default resources of base classes. -# -option add *Extfileselectionbox.borderWidth 2 widgetDefault - -option add *Extfileselectionbox.filterLabel Filter widgetDefault -option add *Extfileselectionbox.dirsLabel Directories widgetDefault -option add *Extfileselectionbox.filesLabel Files widgetDefault -option add *Extfileselectionbox.selectionLabel Selection widgetDefault - -option add *Extfileselectionbox.width 350 widgetDefault -option add *Extfileselectionbox.height 300 widgetDefault - -# ------------------------------------------------------------------ -# CONSTRUCTOR -# ------------------------------------------------------------------ -itcl::body iwidgets::Extfileselectionbox::constructor {args} { - # - # Add back to the hull width and height options and make the - # borderwidth zero since we don't need it. - # - itk_option add hull.width hull.height - component hull configure -borderwidth 0 - - set _interior $itk_interior - - # - # Create the filter entry. - # - itk_component add filter { - iwidgets::Combobox $itk_interior.filter -unique true \ - -command [itcl::code $this _selectFilter] -exportselection 0 \ - -labelpos nw -completion 0 - - } { - usual - - rename -labeltext -filterlabel filterLabel Text - } - - set cmd [$itk_component(filter) cget -command] - set cmd "$cmd;[itcl::code $this _selectFilter]" - $itk_component(filter) configure -command "$cmd" -selectioncommand "$cmd"; - - # - # Create a paned window for the directory and file lists. - # - itk_component add listpane { - iwidgets::Panedwindow $itk_interior.listpane -orient vertical - } - - $itk_component(listpane) add dirs -margin 5 - $itk_component(listpane) add files -margin 5 - - # - # Create the directory list. - # - itk_component add dirs { - iwidgets::Scrolledlistbox [$itk_component(listpane) childsite dirs].dirs \ - -selectioncommand [itcl::code $this _selectDir] \ - -selectmode single -exportselection 0 \ - -visibleitems 1x1 -labelpos nw \ - -hscrollmode static -vscrollmode static \ - -dblclickcommand [itcl::code $this _dblSelectDir] - } { - usual - - rename -labeltext -dirslabel dirsLabel Text - } - grid $itk_component(dirs) -sticky nsew - grid rowconfigure [$itk_component(listpane) childsite dirs] 0 -weight 1 - grid columnconfigure [$itk_component(listpane) childsite dirs] 0 -weight 1 - - # - # Create the files list. - # - itk_component add files { - iwidgets::Scrolledlistbox [$itk_component(listpane) childsite files].files \ - -selectioncommand [itcl::code $this _selectFile] \ - -selectmode single -exportselection 0 \ - -visibleitems 1x1 -labelpos nw \ - -hscrollmode static -vscrollmode static - } { - usual - - rename -labeltext -fileslabel filesLabel Text - } - grid $itk_component(files) -sticky nsew - grid rowconfigure [$itk_component(listpane) childsite files] 0 -weight 1 - grid columnconfigure [$itk_component(listpane) childsite files] 0 -weight 1 - - # - # Create the selection entry. - # - itk_component add selection { - iwidgets::Combobox $itk_interior.selection -unique true \ - -command [itcl::code $this _selectSelection] -exportselection 0 \ - -labelpos nw -completion 0 - } { - usual - - rename -labeltext -selectionlabel selectionLabel Text - } - - # - # Create the child site widget. - # - itk_component add -protected childsite { - frame $itk_interior.fsbchildsite - } - - # - # Set the interior variable to the childsite for derived classes. - # - set itk_interior $itk_component(childsite) - - # - # Explicitly handle configs that may have been ignored earlier. - # - eval itk_initialize $args - - # - # When idle, pack the childsite and update the lists. - # - _packComponents - _updateLists -} - -# ------------------------------------------------------------------ -# DESTRUCTOR -# ------------------------------------------------------------------ -itcl::body iwidgets::Extfileselectionbox::destructor {} { - if {$_packToken != ""} {after cancel $_packToken} - if {$_updateToken != ""} {after cancel $_updateToken} -} - -# ------------------------------------------------------------------ -# OPTIONS -# ------------------------------------------------------------------ - -# ------------------------------------------------------------------ -# OPTION: -childsitepos -# -# Specifies the position of the child site in the selection box. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Extfileselectionbox::childsitepos { - _packComponents -} - -# ------------------------------------------------------------------ -# OPTION: -fileson -# -# Specifies whether or not to display the files list. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Extfileselectionbox::fileson { - if {$itk_option(-fileson)} { - $itk_component(listpane) show files - - _updateLists - - } else { - $itk_component(listpane) hide files - } -} - -# ------------------------------------------------------------------ -# OPTION: -dirson -# -# Specifies whether or not to display the dirs list. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Extfileselectionbox::dirson { - if {$itk_option(-dirson)} { - $itk_component(listpane) show dirs - - _updateLists - - } else { - $itk_component(listpane) hide dirs - } -} - -# ------------------------------------------------------------------ -# OPTION: -selectionon -# -# Specifies whether or not to display the selection entry widget. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Extfileselectionbox::selectionon { - _packComponents -} - -# ------------------------------------------------------------------ -# OPTION: -filteron -# -# Specifies whether or not to display the filter entry widget. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Extfileselectionbox::filteron { - _packComponents -} - -# ------------------------------------------------------------------ -# OPTION: -mask -# -# Specifies the initial file mask string. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Extfileselectionbox::mask { - global tcl_platform - set prefix $_pwd - - # - # Remove automounter paths. - # - if {$tcl_platform(platform) == "unix"} { - if {$itk_option(-automount) != {}} { - foreach autoDir $itk_option(-automount) { - # Use catch because we can't be sure exactly what strings - # were passed into the -automount option - catch { - if {[regsub ^/$autoDir $prefix {} prefix] != 0} { - break - } - } - } - } - } - - set curFilter $itk_option(-mask); - $itk_component(filter) delete entry 0 end - $itk_component(filter) insert entry 0 [file join "$_pwd" $itk_option(-mask)] - - # - # Make sure the right most text is visable. - # - [$itk_component(filter) component entry] xview moveto 1 -} - -# ------------------------------------------------------------------ -# OPTION: -directory -# -# Specifies the initial default directory. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Extfileselectionbox::directory { - if {$itk_option(-directory) != {}} { - if {! [file exists $itk_option(-directory)]} { - error "bad directory option \"$itk_option(-directory)\":\ - directory does not exist" - } - - set olddir [pwd] - cd $itk_option(-directory) - set _pwd [pwd] - cd $olddir - - configure -mask $itk_option(-mask) - _selectFilter - } -} - -# ------------------------------------------------------------------ -# OPTION: -automount -# -# Specifies list of directory prefixes to ignore. Typically, this -# option would be used with values such as: -# -automount {export tmp_mnt} -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Extfileselectionbox::automount { -} - -# ------------------------------------------------------------------ -# OPTION: -nomatchstring -# -# Specifies the string to be displayed in the files list should -# not regular files exist in the directory. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Extfileselectionbox::nomatchstring { -} - -# ------------------------------------------------------------------ -# OPTION: -dirsearchcommand -# -# Specifies a command to be executed to perform a directory search. -# The command will receive the current working directory and filter -# mask as arguments. The command should return a list of files which -# will be placed into the directory list. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Extfileselectionbox::dirsearchcommand { -} - -# ------------------------------------------------------------------ -# OPTION: -filesearchcommand -# -# Specifies a command to be executed to perform a file search. -# The command will receive the current working directory and filter -# mask as arguments. The command should return a list of files which -# will be placed into the file list. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Extfileselectionbox::filesearchcommand { -} - -# ------------------------------------------------------------------ -# OPTION: -selectioncommand -# -# Specifies a command to be executed upon pressing return in the -# selection entry widget. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Extfileselectionbox::selectioncommand { -} - -# ------------------------------------------------------------------ -# OPTION: -filtercommand -# -# Specifies a command to be executed upon pressing return in the -# filter entry widget. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Extfileselectionbox::filtercommand { -} - -# ------------------------------------------------------------------ -# OPTION: -selectdircommand -# -# Specifies a command to be executed following selection of a -# directory in the directory list. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Extfileselectionbox::selectdircommand { -} - -# ------------------------------------------------------------------ -# OPTION: -selectfilecommand -# -# Specifies a command to be executed following selection of a -# file in the files list. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Extfileselectionbox::selectfilecommand { -} - -# ------------------------------------------------------------------ -# OPTION: -invalid -# -# Specify a command to executed should the filter contents be -# proven invalid. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Extfileselectionbox::invalid { -} - -# ------------------------------------------------------------------ -# OPTION: -filetype -# -# Specify the type of files which may appear in the file list. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Extfileselectionbox::filetype { - switch $itk_option(-filetype) { - regular - - directory - - any { - } - default { - error "bad filetype option \"$itk_option(-filetype)\":\ - should be regular, directory, or any" - } - } - - _updateLists -} - -# ------------------------------------------------------------------ -# OPTION: -width -# -# Specifies the width of the file selection box. The value may be -# specified in any of the forms acceptable to Tk_GetPixels. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Extfileselectionbox::width { - # - # The width option was added to the hull in the constructor. - # So, any width value given is passed automatically to the - # hull. All we have to do is play with the propagation. - # - if {$itk_option(-width) != 0} { - set propagate 0 - } else { - set propagate 1 - } - - # - # Due to a bug in the tk4.2 grid, we have to check the - # propagation before setting it. Setting it to the same - # value it already is will cause it to toggle. - # - if {[grid propagate $itk_component(hull)] != $propagate} { - grid propagate $itk_component(hull) $propagate - } -} - -# ------------------------------------------------------------------ -# OPTION: -height -# -# Specifies the height of the file selection box. The value may be -# specified in any of the forms acceptable to Tk_GetPixels. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Extfileselectionbox::height { - # - # The height option was added to the hull in the constructor. - # So, any height value given is passed automatically to the - # hull. All we have to do is play with the propagation. - # - if {$itk_option(-height) != 0} { - set propagate 0 - } else { - set propagate 1 - } - - # - # Due to a bug in the tk4.2 grid, we have to check the - # propagation before setting it. Setting it to the same - # value it already is will cause it to toggle. - # - if {[grid propagate $itk_component(hull)] != $propagate} { - grid propagate $itk_component(hull) $propagate - } -} - -# ------------------------------------------------------------------ -# METHODS -# ------------------------------------------------------------------ - -# ------------------------------------------------------------------ -# METHOD: childsite -# -# Returns the path name of the child site widget. -# ------------------------------------------------------------------ -itcl::body iwidgets::Extfileselectionbox::childsite {} { - return $itk_component(childsite) -} - -# ------------------------------------------------------------------ -# METHOD: get -# -# Returns the current selection. -# ------------------------------------------------------------------ -itcl::body iwidgets::Extfileselectionbox::get {} { - return [$itk_component(selection) get] -} - -# ------------------------------------------------------------------ -# METHOD: filter -# -# The user has pressed Return in the filter. Make sure the contents -# contain a valid directory before setting default to directory. -# Use the invalid option to warn the user of any problems. -# ------------------------------------------------------------------ -itcl::body iwidgets::Extfileselectionbox::filter {} { - set newdir [file dirname [$itk_component(filter) get]] - - if {! [file exists $newdir]} { - uplevel #0 "$itk_option(-invalid)" - return - } - - set _pwd $newdir; - if {$_pwd == "."} {set _pwd [pwd]}; - - _updateLists -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _updateLists ?now? -# -# Updates the contents of both the file and directory lists, as well -# resets the positions of the filter, and lists. -# ------------------------------------------------------------------ -itcl::body iwidgets::Extfileselectionbox::_updateLists {{when "later"}} { - switch -- $when { - later { - if {$_updateToken == ""} { - set _updateToken [after idle [itcl::code $this _updateLists now]] - } - } - now { - if {$itk_option(-dirson)} {_setDirList} - if {$itk_option(-fileson)} {_setFileList} - - if {$itk_option(-filteron)} { - _setFilter - } - if {$itk_option(-selectionon)} { - $itk_component(selection) icursor end - } - if {$itk_option(-dirson)} { - $itk_component(dirs) justify left - } - if {$itk_option(-fileson)} { - $itk_component(files) justify left - } - set _updateToken "" - } - default { - error "bad option \"$when\": should be later or now" - } - } -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _setFilter -# -# Set the filter to the current selection in the directory list plus -# any existing mask in the filter. Translate the two special cases -# of '.', and '..' directory names to full path names.. -# ------------------------------------------------------------------ -itcl::body iwidgets::Extfileselectionbox::_setFilter {} { - global tcl_platform - set prefix [$itk_component(dirs) getcurselection] - set curFilter [file tail [$itk_component(filter) get]] - - while {[regexp {\.$} $prefix]} { - if {[file tail $prefix] == "."} { - if {$prefix == "."} { - if {$_pwd == "."} { - set _pwd [pwd] - } elseif {$_pwd == ".."} { - set _pwd [file dirname [pwd]] - } - set prefix $_pwd - } else { - set prefix [file dirname $prefix] - } - } elseif {[file tail $prefix] == ".."} { - if {$prefix != ".."} { - set prefix [file dirname [file dirname $prefix]] - } else { - if {$_pwd == "."} { - set _pwd [pwd] - } elseif {$_pwd == ".."} { - set _pwd [file dirname [pwd]] - } - set prefix [file dirname "$_pwd"] - } - } else { - break - } - } - - if { [file pathtype $prefix] != "absolute" } { - set prefix [file join "$_pwd" $prefix] - } - - # - # Remove automounter paths. - # - if {$tcl_platform(platform) == "unix"} { - if {$itk_option(-automount) != {}} { - foreach autoDir $itk_option(-automount) { - # Use catch because we can't be sure exactly what strings - # were passed into the -automount option - catch { - if {[regsub ^/$autoDir $prefix {} prefix] != 0} { - break - } - } - } - } - } - - $itk_component(filter) delete entry 0 end - $itk_component(filter) insert entry 0 [file join $prefix $curFilter] - - if {[info level -1] != "_selectDir"} { - $itk_component(filter) insert list 0 [file join $prefix $curFilter] - } - - # - # Make sure insertion cursor is at the end. - # - $itk_component(filter) icursor end - - # - # Make sure the right most text is visable. - # - [$itk_component(filter) component entry] xview moveto 1 -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _setSelection -# -# Set the contents of the selection entry to either the current -# selection of the file or directory list dependent on which lists -# are currently mapped. For the file list, avoid seleciton of the -# no match string. As for the directory list, translate file names. -# ------------------------------------------------------------------ -itcl::body iwidgets::Extfileselectionbox::_setSelection {} { - global tcl_platform - $itk_component(selection) delete entry 0 end - - if {$itk_option(-fileson)} { - set selection [$itk_component(files) getcurselection] - - if {$selection != $itk_option(-nomatchstring)} { - if {[file pathtype $selection] != "absolute"} { - set selection [file join "$_pwd" $selection] - } - - # - # Remove automounter paths. - # - if {$tcl_platform(platform) == "unix"} { - if {$itk_option(-automount) != {}} { - foreach autoDir $itk_option(-automount) { - # Use catch because we can't be sure exactly what strings - # were passed into the -automount option - catch { - if {[regsub ^/$autoDir $selection {} selection] != 0} { - break - } - } - } - } - } - - $itk_component(selection) insert entry 0 $selection - } else { - $itk_component(files) selection clear 0 end - } - - } else { - set selection [$itk_component(dirs) getcurselection] - - if {[file tail $selection] == "."} { - if {$selection != "."} { - set selection [file dirname $selection] - } else { - set selection "$_pwd" - } - } elseif {[file tail $selection] == ".."} { - if {$selection != ".."} { - set selection [file dirname [file dirname $selection]] - } else { - set selection [file join "$_pwd" ..] - } - } else { - set selection [file join "$_pwd" $selection] - } - - # - # Remove automounter paths. - # - if {$tcl_platform(platform) == "unix"} { - if {$itk_option(-automount) != {}} { - foreach autoDir $itk_option(-automount) { - # Use catch because we can't be sure exactly what strings - # were passed into the -automount option - catch { - if {[regsub ^/$autoDir $selection {} selection] != 0} { - break - } - } - } - } - } - - $itk_component(selection) insert entry 0 $selection - } - - $itk_component(selection) insert list 0 $selection - $itk_component(selection) icursor end - - # - # Make sure the right most text is visable. - # - [$itk_component(selection) component entry] xview moveto 1 -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _setDirList -# -# Clear the directory list and dependent on whether the user has -# defined their own search procedure or not fill the list with their -# results or those of a glob. Select the first element if it exists. -# ------------------------------------------------------------------ -itcl::body iwidgets::Extfileselectionbox::_setDirList {} { - $itk_component(dirs) clear - - set currentIndex "" - if {$itk_option(-dirsearchcommand) == {}} { - set cwd "$_pwd" - - set counter 0 - foreach i [lsort [glob -nocomplain \ - [file join $cwd .*] [file join $cwd *]]] { - if {[file isdirectory $i]} { - set insert "[file tail $i]" - if {$insert == "."} { - set currentIndex $counter - } - $itk_component(dirs) insert end "$insert" - incr counter - } - } - - } else { - set mask [file tail [$itk_component(filter) get]] - - foreach file [uplevel #0 $itk_option(-dirsearchcommand) "$_pwd" $mask] { - $itk_component(dirs) insert end $file - } - } - - if {[$itk_component(dirs) size]} { - $itk_component(dirs) selection clear 0 end - if {$currentIndex != ""} { - $itk_component(dirs) selection set $currentIndex - } else { - $itk_component(dirs) selection set 0 - } - } -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _setFileList -# -# Clear the file list and dependent on whether the user has defined -# their own search procedure or not fill the list with their results -# or those of a 'glob'. If the files list has no contents, then set -# the files list to the 'nomatchstring'. Clear all selections. -# ------------------------------------------------------------------ -itcl::body iwidgets::Extfileselectionbox::_setFileList {} { - $itk_component(files) clear - set mask [file tail [$itk_component(filter) get]] - - if {$itk_option(-filesearchcommand) == {}} { - if {$mask == "*"} { - set files [lsort [glob -nocomplain \ - [file join "$_pwd" .*] [file join "$_pwd" *]]] - } else { - set files [lsort [glob -nocomplain [file join "$_pwd" $mask]]] - } - - foreach i $files { - if {($itk_option(-filetype) == "regular" && \ - ! [file isdirectory $i]) || \ - ($itk_option(-filetype) == "directory" && \ - [file isdirectory $i]) || \ - ($itk_option(-filetype) == "any")} { - set insert "[file tail $i]" - $itk_component(files) insert end "$insert" - } - } - - } else { - foreach file [uplevel #0 $itk_option(-filesearchcommand) "$_pwd" $mask] { - $itk_component(files) insert end $file - } - } - - if {[$itk_component(files) size] == 0} { - if {$itk_option(-nomatchstring) != {}} { - $itk_component(files) insert end $itk_option(-nomatchstring) - } - } - - $itk_component(files) selection clear 0 end -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _selectDir -# -# For a selection in the directory list, set the filter and possibly -# the selection entry based on the fileson option. -# ------------------------------------------------------------------ -itcl::body iwidgets::Extfileselectionbox::_selectDir {} { - _setFilter - - if {$itk_option(-fileson)} {} { - _setSelection - } - - if {$itk_option(-selectdircommand) != {}} { - uplevel #0 $itk_option(-selectdircommand) - } -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _dblSelectDir -# -# For a double click event in the directory list, select the -# directory, set the default to the selection, and update both the -# file and directory lists. -# ------------------------------------------------------------------ -itcl::body iwidgets::Extfileselectionbox::_dblSelectDir {} { - filter -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _selectFile -# -# The user has selected a file. Put the current selection in the -# file list in the selection entry widget. -# ------------------------------------------------------------------ -itcl::body iwidgets::Extfileselectionbox::_selectFile {} { - _setSelection - - if {$itk_option(-selectfilecommand) != {}} { - uplevel #0 $itk_option(-selectfilecommand) - } -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _selectSelection -# -# The user has pressed Return in the selection entry widget. Call -# the defined selection command if it exists. -# ------------------------------------------------------------------ -itcl::body iwidgets::Extfileselectionbox::_selectSelection {} { - if {$itk_option(-selectioncommand) != {}} { - uplevel #0 $itk_option(-selectioncommand) - } -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _selectFilter -# -# The user has pressed Return in the filter entry widget. Call the -# defined selection command if it exists, otherwise just filter. -# ------------------------------------------------------------------ -itcl::body iwidgets::Extfileselectionbox::_selectFilter {} { - if {$itk_option(-filtercommand) != {}} { - uplevel #0 $itk_option(-filtercommand) - } else { - filter - } -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _packComponents -# -# Pack the selection, items, and child site widgets based on options. -# Using the -in option of pack, put the childsite around the frame -# in the hull for n, s, e, and w positions. Make sure and raise -# the child site since using the 'in' option may obscure the site. -# ------------------------------------------------------------------ -itcl::body iwidgets::Extfileselectionbox::_packComponents {{when "later"}} { - if {$when == "later"} { - if {$_packToken == ""} { - set _packToken [after idle [itcl::code $this _packComponents now]] - } - return - } elseif {$when != "now"} { - error "bad option \"$when\": should be now or later" - } - - set _packToken "" - - # - # Forget about any previous placements via the grid and - # reset all the possible minsizes and weights for all - # the rows and columns. - # - foreach component {childsite listpane filter selection} { - grid forget $itk_component($component) - } - - for {set row 0} {$row < 6} {incr row} { - grid rowconfigure $_interior $row -minsize 0 -weight 0 - } - - for {set col 0} {$col < 3} {incr col} { - grid columnconfigure $_interior $col -minsize 0 -weight 0 - } - - # - # Place all the components based on the childsite poisition - # option. - # - switch $itk_option(-childsitepos) { - n { _nPos } - - w { _wPos } - - s { _sPos } - - e { _ePos } - - top { _topPos } - - bottom { _bottomPos } - - default { - error "bad childsitepos option \"$itk_option(-childsitepos)\":\ - should be n, e, s, w, top, or bottom" - } - } -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _nPos -# -# Position the childsite to the north and all the other components -# appropriately based on the individual "on" options. -# ------------------------------------------------------------------ -itcl::body iwidgets::Extfileselectionbox::_nPos {} { - grid $itk_component(childsite) -row 0 -column 0 \ - -columnspan 1 -rowspan 1 -sticky nsew -padx 5 - - if {$itk_option(-filteron)} { - grid $itk_component(filter) -row 1 -column 0 \ - -columnspan 1 -sticky ew -padx 5 - grid rowconfigure $_interior 2 -minsize 7 - } - - grid $itk_component(listpane) -row 3 -column 0 \ - -columnspan 1 -sticky nsew - - grid rowconfigure $_interior 3 -weight 1 - - if {$itk_option(-selectionon)} { - grid rowconfigure $_interior 4 -minsize 7 - grid $itk_component(selection) -row 5 -column 0 \ - -columnspan 1 -sticky ew -padx 5 - } - - grid columnconfigure $_interior 0 -weight 1 -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _sPos -# -# Position the childsite to the south and all the other components -# appropriately based on the individual "on" options. -# ------------------------------------------------------------------ -itcl::body iwidgets::Extfileselectionbox::_sPos {} { - if {$itk_option(-filteron)} { - grid $itk_component(filter) -row 0 -column 0 \ - -columnspan 1 -sticky ew -padx 5 - grid rowconfigure $_interior 1 -minsize 7 - } - - grid $itk_component(listpane) -row 2 -column 0 \ - -columnspan 1 -sticky nsew - - grid rowconfigure $_interior 2 -weight 1 - - if {$itk_option(-selectionon)} { - grid rowconfigure $_interior 3 -minsize 7 - grid $itk_component(selection) -row 4 -column 0 \ - -columnspan 1 -sticky ew -padx 5 - } - - grid $itk_component(childsite) -row 5 -column 0 \ - -columnspan 1 -rowspan 1 -sticky nsew -padx 5 - - grid columnconfigure $_interior 0 -weight 1 -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _ePos -# -# Position the childsite to the east and all the other components -# appropriately based on the individual "on" options. -# ------------------------------------------------------------------ -itcl::body iwidgets::Extfileselectionbox::_ePos {} { - if {$itk_option(-filteron)} { - grid $itk_component(filter) -row 0 -column 0 \ - -columnspan 1 -sticky ew -padx 5 - grid rowconfigure $_interior 1 -minsize 7 - } - - grid $itk_component(listpane) -row 2 -column 0 \ - -columnspan 1 -sticky nsew - - grid rowconfigure $_interior 2 -weight 1 - - if {$itk_option(-selectionon)} { - grid rowconfigure $_interior 3 -minsize 7 - grid $itk_component(selection) -row 4 -column 0 \ - -columnspan 1 -sticky ew -padx 5 - } - - grid $itk_component(childsite) -row 0 -column 1 \ - -rowspan 5 -columnspan 1 -sticky nsew - - grid columnconfigure $_interior 0 -weight 1 -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _wPos -# -# Position the childsite to the west and all the other components -# appropriately based on the individual "on" options. -# ------------------------------------------------------------------ -itcl::body iwidgets::Extfileselectionbox::_wPos {} { - grid $itk_component(childsite) -row 0 -column 0 \ - -rowspan 5 -columnspan 1 -sticky nsew - - if {$itk_option(-filteron)} { - grid $itk_component(filter) -row 0 -column 1 \ - -columnspan 1 -sticky ew -padx 5 - grid rowconfigure $_interior 1 -minsize 7 - } - - grid $itk_component(listpane) -row 2 -column 1 \ - -columnspan 1 -sticky nsew - - grid rowconfigure $_interior 2 -weight 1 - - if {$itk_option(-selectionon)} { - grid rowconfigure $_interior 3 -minsize 7 - grid $itk_component(selection) -row 4 -column 1 \ - -columnspan 1 -sticky ew -padx 5 - } - - grid columnconfigure $_interior 1 -weight 1 -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _topPos -# -# Position the childsite below the filter but above the lists and -# all the other components appropriately based on the individual -# "on" options. -# ------------------------------------------------------------------ -itcl::body iwidgets::Extfileselectionbox::_topPos {} { - if {$itk_option(-filteron)} { - grid $itk_component(filter) -row 0 -column 0 \ - -columnspan 1 -sticky ew -padx 5 - } - - grid $itk_component(childsite) -row 1 -column 0 \ - -columnspan 1 -rowspan 1 -sticky nsew -padx 5 - - grid $itk_component(listpane) -row 2 -column 0 -sticky nsew - - grid rowconfigure $_interior 2 -weight 1 - - if {$itk_option(-selectionon)} { - grid rowconfigure $_interior 3 -minsize 7 - grid $itk_component(selection) -row 4 -column 0 \ - -columnspan 1 -sticky ew -padx 5 - } - - grid columnconfigure $_interior 0 -weight 1 -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _bottomPos -# -# Position the childsite below the lists and above the selection -# and all the other components appropriately based on the individual -# "on" options. -# ------------------------------------------------------------------ -itcl::body iwidgets::Extfileselectionbox::_bottomPos {} { - if {$itk_option(-filteron)} { - grid $itk_component(filter) -row 0 -column 0 \ - -columnspan 1 -sticky ew -padx 5 - grid rowconfigure $_interior 1 -minsize 7 - } - - grid $itk_component(listpane) -row 2 -column 0 -sticky nsew - - grid rowconfigure $_interior 2 -weight 1 - - grid $itk_component(childsite) -row 3 -column 0 \ - -columnspan 1 -rowspan 1 -sticky nsew -padx 5 - - if {$itk_option(-selectionon)} { - grid $itk_component(selection) -row 4 -column 0 \ - -columnspan 1 -sticky ew -padx 5 - } - - grid columnconfigure $_interior 0 -weight 1 -} diff --git a/iwidgets/library/extfileselectiondialog.itk b/iwidgets/library/extfileselectiondialog.itk deleted file mode 100644 index 387986c..0000000 --- a/iwidgets/library/extfileselectiondialog.itk +++ /dev/null @@ -1,182 +0,0 @@ -# -# Extfileselectiondialog -# ---------------------------------------------------------------------- -# Implements a file selection dialog that is a slightly extended version -# of the OSF/Motif standard composite widget. The Extfileselectionbox -# differs from the Motif standard in that the filter and selection -# fields are comboboxes and the files and directory lists are in a -# paned window. -# -# ---------------------------------------------------------------------- -# AUTHOR: Mark L. Ulferts EMAIL: mulferts@spd.dsccc.com -# -# @(#) $Id: extfileselectiondialog.itk,v 1.3 2002/02/27 06:45:10 mgbacke Exp $ -# ---------------------------------------------------------------------- -# Copyright (c) 1997 DSC Technologies Corporation -# ====================================================================== -# Permission to use, copy, modify, distribute and license this software -# and its documentation for any purpose, and without fee or written -# agreement with DSC, is hereby granted, provided that the above copyright -# notice appears in all copies and that both the copyright notice and -# warranty disclaimer below appear in supporting documentation, and that -# the names of DSC Technologies Corporation or DSC Communications -# Corporation not be used in advertising or publicity pertaining to the -# software without specific, written prior permission. -# -# DSC DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING -# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, 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. IN NO EVENT SHALL -# DSC BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR -# ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, -# WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION, -# ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS -# SOFTWARE. -# ====================================================================== - -# -# Usual options. -# -itk::usual Extfileselectiondialog { - keep -activebackground -activerelief -background -borderwidth -cursor \ - -elementborderwidth -foreground -highlightcolor -highlightthickness \ - -insertbackground -insertborderwidth -insertofftime -insertontime \ - -insertwidth -jump -labelfont -modality -selectbackground \ - -selectborderwidth -textbackground -textfont -} - -# ------------------------------------------------------------------ -# EXTFILESELECTIONDIALOG -# ------------------------------------------------------------------ -itcl::class iwidgets::Extfileselectiondialog { - inherit iwidgets::Dialog - - constructor {args} {} - - public { - method childsite {} - method get {} - method filter {} - } - - protected method _dbldir {} -} - -# -# Provide a lowercased access method for the Extfileselectiondialog class. -# -proc ::iwidgets::extfileselectiondialog {pathName args} { - uplevel ::iwidgets::Extfileselectiondialog $pathName $args -} - -# -# Use option database to override default resources of base classes. -# -option add *Extfileselectiondialog.borderWidth 2 widgetDefault - -option add *Extfileselectiondialog.title "File Selection Dialog" widgetDefault - -option add *Extfileselectiondialog.width 350 widgetDefault -option add *Extfileselectiondialog.height 400 widgetDefault - -option add *Extfileselectiondialog.master "." widgetDefault - -# ------------------------------------------------------------------ -# CONSTRUCTOR -# ------------------------------------------------------------------ -itcl::body iwidgets::Extfileselectiondialog::constructor {args} { - component hull configure -borderwidth 0 - itk_option add hull.width hull.height - - # - # Turn off pack propagation for the hull widget so the width - # and height options become active. - # - pack propagate $itk_component(hull) no - - # - # Instantiate a file selection box widget. - # - itk_component add fsb { - iwidgets::Extfileselectionbox $itk_interior.fsb -width 150 -height 150 \ - -selectioncommand [itcl::code $this invoke] \ - -selectdircommand [itcl::code $this default Apply] \ - -selectfilecommand [itcl::code $this default OK] - } { - usual - - keep -labelfont -childsitepos -directory -dirslabel \ - -dirsearchcommand -dirson -fileslabel -fileson \ - -filesearchcommand -filterlabel -filteron \ - -filetype -invalid -mask -nomatchstring \ - -selectionlabel -selectionon -sashcursor - } - grid $itk_component(fsb) -sticky nsew - grid rowconfigure $itk_interior 0 -weight 1 - grid columnconfigure $itk_interior 0 -weight 1 - - $itk_component(fsb) component filter configure \ - -focuscommand [itcl::code $this default Apply] - $itk_component(fsb) component selection configure \ - -focuscommand [itcl::code $this default OK] - $itk_component(fsb) component dirs configure \ - -dblclickcommand [itcl::code $this _dbldir] - $itk_component(fsb) component files configure \ - -dblclickcommand [itcl::code $this invoke] - - buttonconfigure Apply -text "Filter" \ - -command [itcl::code $itk_component(fsb) filter] - - set itk_interior [$itk_component(fsb) childsite] - - hide Help - - eval itk_initialize $args -} - -# ------------------------------------------------------------------ -# METHODS -# ------------------------------------------------------------------ - -# ------------------------------------------------------------------ -# METHOD: childsite -# -# Thinwrapped method of file selection box class. -# ------------------------------------------------------------------ -itcl::body iwidgets::Extfileselectiondialog::childsite {} { - return [$itk_component(fsb) childsite] -} - -# ------------------------------------------------------------------ -# METHOD: get -# -# Thinwrapped method of file selection box class. -# ------------------------------------------------------------------ -itcl::body iwidgets::Extfileselectiondialog::get {} { - return [$itk_component(fsb) get] -} - -# ------------------------------------------------------------------ -# METHOD: filter -# -# Thinwrapped method of file selection box class. -# ------------------------------------------------------------------ -itcl::body iwidgets::Extfileselectiondialog::filter {} { - return [$itk_component(fsb) filter] -} - -# ------------------------------------------------------------------ -# PROTECTED METHOD: _dbldir -# -# Double select in directory list. If the files list is on then -# make the default button the filter and invoke. If not, just invoke. -# ------------------------------------------------------------------ -itcl::body iwidgets::Extfileselectiondialog::_dbldir {} { - if {$itk_option(-fileson)} { - default Apply - } - - invoke -} - diff --git a/iwidgets/library/feedback.itk b/iwidgets/library/feedback.itk deleted file mode 100644 index d78be7f..0000000 --- a/iwidgets/library/feedback.itk +++ /dev/null @@ -1,212 +0,0 @@ -# -# Feedback -# ---------------------------------------------------------------------- -# Implements a Feedback widget, to display feedback on the status of an -# process to the user. Display is given as a percentage and as a -# thermometer type bar. Options exist for adding a label and controlling its -# position. -# -# ---------------------------------------------------------------------- -# AUTHOR: Kris Raney EMAIL: kraney@spd.dsccc.com -# -# @(#) $Id: feedback.itk,v 1.5 2001/08/15 18:32:18 smithc Exp $ -# ---------------------------------------------------------------------- -# Copyright (c) 1996 DSC Technologies Corporation -# ====================================================================== -# Permission to use, copy, modify, distribute and license this software -# and its documentation for any purpose, and without fee or written -# agreement with DSC, is hereby granted, provided that the above copyright -# notice appears in all copies and that both the copyright notice and -# warranty disclaimer below appear in supporting documentation, and that -# the names of DSC Technologies Corporation or DSC Communications -# Corporation not be used in advertising or publicity pertaining to the -# software without specific, written prior permission. -# -# DSC DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING -# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, 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. IN NO EVENT SHALL -# DSC BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR -# ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, -# WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION, -# ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS -# SOFTWARE. -# ====================================================================== - -# Acknowledgements: -# -# Special thanks go to Sam Shen(SLShen@lbl.gov), as this code is based on his -# feedback.tcl code from tk inspect. The original code is copyright 1995 -# Lawrence Berkeley Laboratory. -# -# This software is copyright (C) 1994 by the Lawrence Berkeley Laboratory. -# -# Redistribution and use in source and binary forms, with or without -# modification, are permitted provided that: (1) source code distributions -# retain the above copyright notice and this paragraph in its entirety, (2) -# distributions including binary code include the above copyright notice and -# this paragraph in its entirety in the documentation or other materials -# provided with the distribution, and (3) all advertising materials mentioning -# features or use of this software display the following acknowledgement: -# ``This product includes software developed by the University of California, -# Lawrence Berkeley Laboratory and its contributors.'' Neither the name of -# the University nor the names of its contributors may be used to endorse -# or promote products derived from this software without specific prior -# written permission. -# -# THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR IMPLIED -# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF -# MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. - -# -# Default resources. -# -option add *Feedback.borderWidth 2 widgetDefault -option add *Feedback.labelPos n widgetDefault -option add *Feedback.barHeight 20 widgetDefault -option add *Feedback.troughColor White widgetDefault -option add *Feedback.barColor Blue widgetDefault - -# -# Usual options. -# -itk::usual Feedback { - keep -background -cursor -foreground -} - -# ------------------------------------------------------------------ -# FEEDBACK -# ------------------------------------------------------------------ -itcl::class iwidgets::Feedback { - inherit iwidgets::Labeledwidget - - constructor {args} {} - destructor {} - - itk_option define -steps steps Steps 10 - - public { - method reset {} - method step {{inc 1}} - } - - private { - method _display - - variable _barwidth 0 - variable _stepval 0 - } -} - -# -# Provide a lowercased access method for the Dialogshell class. -# -proc ::iwidgets::feedback {pathName args} { - uplevel ::iwidgets::Feedback $pathName $args -} - -# ------------------------------------------------------------------ -# CONSTRUCTOR -# ------------------------------------------------------------------ -itcl::body iwidgets::Feedback::constructor {args} { - itk_component add trough { - frame $itk_interior.trough -relief sunken - } { - usual - keep -borderwidth - rename -background -troughcolor troughColor TroughColor - rename -height -barheight barHeight Height - } - - itk_component add bar { - frame $itk_component(trough).bar -relief raised - } { - usual - keep -borderwidth - rename -background -barcolor barColor BarColor - rename -height -barheight barHeight Height - } - pack $itk_component(bar) -side left -fill y -anchor w - - itk_component add percentage { - label $itk_interior.percentage -text "0%" - } - grid $itk_component(trough) -row 1 -column 0 -sticky sew -padx 2 -pady 2 - grid $itk_component(percentage) -row 2 -column 0 -sticky nsew -padx 2 -pady 2 - grid rowconfigure $itk_interior 0 -weight 1 - grid rowconfigure $itk_interior 1 -weight 1 - grid columnconfigure $itk_interior 0 -weight 1 - - bind $itk_component(hull) [itcl::code $this _display] - - eval itk_initialize $args -} - -# ------------------------------------------------------------------ -# DESTRUCTOR -# ------------------------------------------------------------------ -itcl::body iwidgets::Feedback::destructor {} { -} - -# ------------------------------------------------------------------ -# OPTIONS -# ------------------------------------------------------------------ - -# ------------------------------------------------------------------ -# OPTION: -steps -# -# Set the total number of steps. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Feedback::steps { - step 0 -} - -# ------------------------------------------------------------------ -# METHODS -# ------------------------------------------------------------------ - -# ----------------------------------------------------------------------------- -# PROTECTED METHOD: _display -# -# Displays the bar in the trough with the width set using the current number -# of steps. -# ----------------------------------------------------------------------------- -itcl::body iwidgets::Feedback::_display {} { - update idletasks - set troughwidth [winfo width $itk_component(trough)] - set _barwidth [expr { - (1.0*$troughwidth-(2.0*[$itk_component(trough) cget -borderwidth])) / - $itk_option(-steps)}] - set fraction [expr {int((1.0*$_stepval)/$itk_option(-steps)*100.0)}] - - $itk_component(percentage) config -text "$fraction%" - $itk_component(bar) config -width [expr {$_barwidth*$_stepval}] - - update -} - -# ------------------------------------------------------------------ -# METHOD: reset -# -# Resets the status bar to 0 -# ------------------------------------------------------------------ -itcl::body iwidgets::Feedback::reset {} { - set _stepval 0 - _display -} - -# ------------------------------------------------------------------ -# METHOD: step ?inc? -# -# Increase the value of the status bar by inc. Default to 1 -# ------------------------------------------------------------------ -itcl::body iwidgets::Feedback::step {{inc 1}} { - - if {$_stepval >= $itk_option(-steps)} { - return - } - - incr _stepval $inc - _display -} diff --git a/iwidgets/library/fileselectionbox.itk b/iwidgets/library/fileselectionbox.itk deleted file mode 100644 index b69da34..0000000 --- a/iwidgets/library/fileselectionbox.itk +++ /dev/null @@ -1,1296 +0,0 @@ -# -# Fileselectionbox -# ---------------------------------------------------------------------- -# Implements a file selection box in a style similar to the OSF/Motif -# standard XmFileselectionbox composite widget. The Fileselectionbox -# is composed of directory and file scrolled lists as well as filter -# and selection entry fields. -# -# ---------------------------------------------------------------------- -# AUTHOR: Mark L. Ulferts EMAIL: mulferts@spd.dsccc.com -# -# @(#) $Id: fileselectionbox.itk,v 1.3 2001/08/07 19:56:48 smithc Exp $ -# ---------------------------------------------------------------------- -# Copyright (c) 1997 DSC Technologies Corporation -# ====================================================================== -# Permission to use, copy, modify, distribute and license this software -# and its documentation for any purpose, and without fee or written -# agreement with DSC, is hereby granted, provided that the above copyright -# notice appears in all copies and that both the copyright notice and -# warranty disclaimer below appear in supporting documentation, and that -# the names of DSC Technologies Corporation or DSC Communications -# Corporation not be used in advertising or publicity pertaining to the -# software without specific, written prior permission. -# -# DSC DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING -# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, 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. IN NO EVENT SHALL -# DSC BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR -# ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, -# WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION, -# ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS -# SOFTWARE. -# ====================================================================== - -# -# Usual options. -# -itk::usual Fileselectionbox { - keep -activebackground -activerelief -background -borderwidth -cursor \ - -elementborderwidth -foreground -highlightcolor -highlightthickness \ - -insertbackground -insertborderwidth -insertofftime -insertontime \ - -insertwidth -jump -labelfont -selectbackground -selectborderwidth \ - -textbackground -textfont -troughcolor -} - -# ------------------------------------------------------------------ -# FILESELECTIONBOX -# ------------------------------------------------------------------ -itcl::class iwidgets::Fileselectionbox { - inherit itk::Widget - - constructor {args} {} - destructor {} - - itk_option define -childsitepos childSitePos Position s - itk_option define -fileson filesOn FilesOn true - itk_option define -dirson dirsOn DirsOn true - itk_option define -selectionon selectionOn SelectionOn true - itk_option define -filteron filterOn FilterOn true - itk_option define -mask mask Mask {*} - itk_option define -directory directory Directory {} - itk_option define -automount automount Automount {} - itk_option define -nomatchstring noMatchString NoMatchString {} - itk_option define -dirsearchcommand dirSearchCommand Command {} - itk_option define -filesearchcommand fileSearchCommand Command {} - itk_option define -selectioncommand selectionCommand Command {} - itk_option define -filtercommand filterCommand Command {} - itk_option define -selectdircommand selectDirCommand Command {} - itk_option define -selectfilecommand selectFileCommand Command {} - itk_option define -invalid invalid Command {bell} - itk_option define -filetype fileType FileType {regular} - itk_option define -width width Width 350 - itk_option define -height height Height 300 - - public { - method childsite {} - method get {} - method filter {} - } - - public { - method _selectDir {} - method _dblSelectDir {} - method _selectFile {} - method _selectSelection {} - method _selectFilter {} - } - - protected { - method _packComponents {{when later}} - method _updateLists {{when later}} - } - - private { - method _setFilter {} - method _setSelection {} - method _setDirList {} - method _setFileList {} - - method _nPos {} - method _sPos {} - method _ePos {} - method _wPos {} - method _topPos {} - method _centerPos {} - method _bottomPos {} - - variable _packToken "" ;# non-null => _packComponents pending - variable _updateToken "" ;# non-null => _updateLists pending - variable _pwd "." ;# present working dir - variable _interior ;# original interior setting - } -} - -# -# Provide a lowercased access method for the Fileselectionbox class. -# -proc ::iwidgets::fileselectionbox {pathName args} { - uplevel ::iwidgets::Fileselectionbox $pathName $args -} - -# -# Use option database to override default resources of base classes. -# -option add *Fileselectionbox.borderWidth 2 widgetDefault - -option add *Fileselectionbox.filterLabel Filter widgetDefault -option add *Fileselectionbox.dirsLabel Directories widgetDefault -option add *Fileselectionbox.filesLabel Files widgetDefault -option add *Fileselectionbox.selectionLabel Selection widgetDefault - -option add *Fileselectionbox.width 350 widgetDefault -option add *Fileselectionbox.height 300 widgetDefault - -# ------------------------------------------------------------------ -# CONSTRUCTOR -# ------------------------------------------------------------------ -itcl::body iwidgets::Fileselectionbox::constructor {args} { - # - # Add back to the hull width and height options and make the - # borderwidth zero since we don't need it. - # - itk_option add hull.width hull.height - component hull configure -borderwidth 0 - - set _interior $itk_interior - - # - # Create the filter entry. - # - itk_component add filter { - iwidgets::Entryfield $itk_interior.filter -labelpos nw \ - -command [itcl::code $this _selectFilter] -exportselection 0 - } { - usual - - rename -labeltext -filterlabel filterLabel Text - } - - # - # Create the directory list. - # - itk_component add dirs { - iwidgets::Scrolledlistbox $itk_interior.dirs \ - -selectioncommand [itcl::code $this _selectDir] \ - -selectmode single -exportselection 0 \ - -visibleitems 1x1 -labelpos nw \ - -hscrollmode static -vscrollmode static \ - -dblclickcommand [itcl::code $this _dblSelectDir] - } { - usual - - rename -labeltext -dirslabel dirsLabel Text - } - - # - # Create the files list. - # - itk_component add files { - iwidgets::Scrolledlistbox $itk_interior.files \ - -selectioncommand [itcl::code $this _selectFile] \ - -selectmode single -exportselection 0 \ - -visibleitems 1x1 -labelpos nw \ - -hscrollmode static -vscrollmode static - } { - usual - - rename -labeltext -fileslabel filesLabel Text - } - - # - # Create the selection entry. - # - itk_component add selection { - iwidgets::Entryfield $itk_interior.selection -labelpos nw \ - -command [itcl::code $this _selectSelection] -exportselection 0 - } { - usual - - rename -labeltext -selectionlabel selectionLabel Text - } - - # - # Create the child site widget. - # - itk_component add -protected childsite { - frame $itk_interior.fsbchildsite - } - - # - # Set the interior variable to the childsite for derived classes. - # - set itk_interior $itk_component(childsite) - - # - # Explicitly handle configs that may have been ignored earlier. - # - eval itk_initialize $args - - # - # When idle, pack the childsite and update the lists. - # - _packComponents - _updateLists -} - -# ------------------------------------------------------------------ -# DESTRUCTOR -# ------------------------------------------------------------------ -itcl::body iwidgets::Fileselectionbox::destructor {} { - if {$_packToken != ""} {after cancel $_packToken} - if {$_updateToken != ""} {after cancel $_updateToken} -} - -# ------------------------------------------------------------------ -# OPTIONS -# ------------------------------------------------------------------ - -# ------------------------------------------------------------------ -# OPTION: -childsitepos -# -# Specifies the position of the child site in the selection box. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Fileselectionbox::childsitepos { - _packComponents -} - -# ------------------------------------------------------------------ -# OPTION: -fileson -# -# Specifies whether or not to display the files list. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Fileselectionbox::fileson { - _packComponents -} - -# ------------------------------------------------------------------ -# OPTION: -dirson -# -# Specifies whether or not to display the dirs list. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Fileselectionbox::dirson { - _packComponents -} - -# ------------------------------------------------------------------ -# OPTION: -selectionon -# -# Specifies whether or not to display the selection entry widget. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Fileselectionbox::selectionon { - _packComponents -} - -# ------------------------------------------------------------------ -# OPTION: -filteron -# -# Specifies whether or not to display the filter entry widget. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Fileselectionbox::filteron { - _packComponents -} - -# ------------------------------------------------------------------ -# OPTION: -mask -# -# Specifies the initial file mask string. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Fileselectionbox::mask { - global tcl_platform - set prefix $_pwd - - # - # Remove automounter paths. - # - if {$tcl_platform(platform) == "unix"} { - if {$itk_option(-automount) != {}} { - foreach autoDir $itk_option(-automount) { - # Use catch because we can't be sure exactly what strings - # were passed into the -automount option - catch { - if {[regsub ^/$autoDir $prefix {} prefix] != 0} { - break - } - } - } - } - } - - set curFilter $itk_option(-mask); - $itk_component(filter) delete 0 end - $itk_component(filter) insert 0 [file join $_pwd $itk_option(-mask)] - - # - # Make sure the right most text is visable. - # - $itk_component(filter) xview moveto 1 -} - -# ------------------------------------------------------------------ -# OPTION: -directory -# -# Specifies the initial default directory. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Fileselectionbox::directory { - if {$itk_option(-directory) != {}} { - if {! [file exists $itk_option(-directory)]} { - error "bad directory option \"$itk_option(-directory)\":\ - directory does not exist" - } - - set olddir [pwd] - cd $itk_option(-directory) - set _pwd [pwd] - cd $olddir - - configure -mask $itk_option(-mask) - _selectFilter - } -} - -# ------------------------------------------------------------------ -# OPTION: -automount -# -# Specifies list of directory prefixes to ignore. Typically, this -# option would be used with values such as: -# -automount {export tmp_mnt} -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Fileselectionbox::automount { -} - -# ------------------------------------------------------------------ -# OPTION: -nomatchstring -# -# Specifies the string to be displayed in the files list should -# not regular files exist in the directory. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Fileselectionbox::nomatchstring { -} - -# ------------------------------------------------------------------ -# OPTION: -dirsearchcommand -# -# Specifies a command to be executed to perform a directory search. -# The command will receive the current working directory and filter -# mask as arguments. The command should return a list of files which -# will be placed into the directory list. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Fileselectionbox::dirsearchcommand { -} - -# ------------------------------------------------------------------ -# OPTION: -filesearchcommand -# -# Specifies a command to be executed to perform a file search. -# The command will receive the current working directory and filter -# mask as arguments. The command should return a list of files which -# will be placed into the file list. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Fileselectionbox::filesearchcommand { -} - -# ------------------------------------------------------------------ -# OPTION: -selectioncommand -# -# Specifies a command to be executed upon pressing return in the -# selection entry widget. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Fileselectionbox::selectioncommand { -} - -# ------------------------------------------------------------------ -# OPTION: -filtercommand -# -# Specifies a command to be executed upon pressing return in the -# filter entry widget. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Fileselectionbox::filtercommand { -} - -# ------------------------------------------------------------------ -# OPTION: -selectdircommand -# -# Specifies a command to be executed following selection of a -# directory in the directory list. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Fileselectionbox::selectdircommand { -} - -# ------------------------------------------------------------------ -# OPTION: -selectfilecommand -# -# Specifies a command to be executed following selection of a -# file in the files list. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Fileselectionbox::selectfilecommand { -} - -# ------------------------------------------------------------------ -# OPTION: -invalid -# -# Specify a command to executed should the filter contents be -# proven invalid. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Fileselectionbox::invalid { -} - -# ------------------------------------------------------------------ -# OPTION: -filetype -# -# Specify the type of files which may appear in the file list. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Fileselectionbox::filetype { - switch $itk_option(-filetype) { - regular - - directory - - any { - } - default { - error "bad filetype option \"$itk_option(-filetype)\":\ - should be regular, directory, or any" - } - } - - _updateLists -} - -# ------------------------------------------------------------------ -# OPTION: -width -# -# Specifies the width of the file selection box. The value may be -# specified in any of the forms acceptable to Tk_GetPixels. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Fileselectionbox::width { - # - # The width option was added to the hull in the constructor. - # So, any width value given is passed automatically to the - # hull. All we have to do is play with the propagation. - # - if {$itk_option(-width) != 0} { - set propagate 0 - } else { - set propagate 1 - } - - # - # Due to a bug in the tk4.2 grid, we have to check the - # propagation before setting it. Setting it to the same - # value it already is will cause it to toggle. - # - if {[grid propagate $itk_component(hull)] != $propagate} { - grid propagate $itk_component(hull) $propagate - } -} - -# ------------------------------------------------------------------ -# OPTION: -height -# -# Specifies the height of the file selection box. The value may be -# specified in any of the forms acceptable to Tk_GetPixels. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Fileselectionbox::height { - # - # The height option was added to the hull in the constructor. - # So, any height value given is passed automatically to the - # hull. All we have to do is play with the propagation. - # - if {$itk_option(-height) != 0} { - set propagate 0 - } else { - set propagate 1 - } - - # - # Due to a bug in the tk4.2 grid, we have to check the - # propagation before setting it. Setting it to the same - # value it already is will cause it to toggle. - # - if {[grid propagate $itk_component(hull)] != $propagate} { - grid propagate $itk_component(hull) $propagate - } -} - -# ------------------------------------------------------------------ -# METHODS -# ------------------------------------------------------------------ - -# ------------------------------------------------------------------ -# METHOD: childsite -# -# Returns the path name of the child site widget. -# ------------------------------------------------------------------ -itcl::body iwidgets::Fileselectionbox::childsite {} { - return $itk_component(childsite) -} - -# ------------------------------------------------------------------ -# METHOD: get -# -# Returns the current selection. -# ------------------------------------------------------------------ -itcl::body iwidgets::Fileselectionbox::get {} { - return [$itk_component(selection) get] -} - -# ------------------------------------------------------------------ -# METHOD: filter -# -# The user has pressed Return in the filter. Make sure the contents -# contain a valid directory before setting default to directory. -# Use the invalid option to warn the user of any problems. -# ------------------------------------------------------------------ -itcl::body iwidgets::Fileselectionbox::filter {} { - set newdir [file dirname [$itk_component(filter) get]] - - if {! [file exists $newdir]} { - uplevel #0 "$itk_option(-invalid)" - return - } - - set _pwd $newdir; - if {$_pwd == "."} {set _pwd [pwd]}; - - _updateLists -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _updateLists ?now? -# -# Updates the contents of both the file and directory lists, as well -# resets the positions of the filter, and lists. -# ------------------------------------------------------------------ -itcl::body iwidgets::Fileselectionbox::_updateLists {{when "later"}} { - switch -- $when { - later { - if {$_updateToken == ""} { - set _updateToken [after idle [itcl::code $this _updateLists now]] - } - } - now { - if {$itk_option(-dirson)} {_setDirList} - if {$itk_option(-fileson)} {_setFileList} - - if {$itk_option(-filteron)} { - _setFilter - } - if {$itk_option(-selectionon)} { - $itk_component(selection) icursor end - } - if {$itk_option(-dirson)} { - $itk_component(dirs) justify left - } - if {$itk_option(-fileson)} { - $itk_component(files) justify left - } - set _updateToken "" - } - default { - error "bad option \"$when\": should be later or now" - } - } -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _setFilter -# -# Set the filter to the current selection in the directory list plus -# any existing mask in the filter. Translate the two special cases -# of '.', and '..' directory names to full path names.. -# ------------------------------------------------------------------ -itcl::body iwidgets::Fileselectionbox::_setFilter {} { - global tcl_platform - set prefix [$itk_component(dirs) getcurselection] - set curFilter [file tail [$itk_component(filter) get]] - - while {[regexp {\.$} $prefix]} { - if {[file tail $prefix] == "."} { - if {$prefix == "."} { - if {$_pwd == "."} { - set _pwd [pwd] - } elseif {$_pwd == ".."} { - set _pwd [file dirname [pwd]] - } - set prefix $_pwd - } else { - set prefix [file dirname $prefix] - } - } elseif {[file tail $prefix] == ".."} { - if {$prefix != ".."} { - set prefix [file dirname [file dirname $prefix]] - } else { - if {$_pwd == "."} { - set _pwd [pwd] - } elseif {$_pwd == ".."} { - set _pwd [file dirname [pwd]] - } - set prefix [file dirname $_pwd] - } - } else { - break - } - } - - if { [file pathtype $prefix] != "absolute" } { - set prefix [file join $_pwd $prefix] - } - - # - # Remove automounter paths. - # - if {$tcl_platform(platform) == "unix"} { - if {$itk_option(-automount) != {}} { - foreach autoDir $itk_option(-automount) { - # Use catch because we can't be sure exactly what strings - # were passed into the -automount option - catch { - if {[regsub ^/$autoDir $prefix {} prefix] != 0} { - break - } - } - } - } - } - - $itk_component(filter) delete 0 end - $itk_component(filter) insert 0 [file join $prefix $curFilter] - - # - # Make sure insertion cursor is at the end. - # - $itk_component(filter) icursor end - - # - # Make sure the right most text is visable. - # - $itk_component(filter) xview moveto 1 -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _setSelection -# -# Set the contents of the selection entry to either the current -# selection of the file or directory list dependent on which lists -# are currently mapped. For the file list, avoid seleciton of the -# no match string. As for the directory list, translate file names. -# ------------------------------------------------------------------ -itcl::body iwidgets::Fileselectionbox::_setSelection {} { - global tcl_platform - $itk_component(selection) delete 0 end - - if {$itk_option(-fileson)} { - set selection [$itk_component(files) getcurselection] - - if {$selection != $itk_option(-nomatchstring)} { - if {[file pathtype $selection] != "absolute"} { - set selection [file join $_pwd $selection] - } - - # - # Remove automounter paths. - # - if {$tcl_platform(platform) == "unix"} { - if {$itk_option(-automount) != {}} { - foreach autoDir $itk_option(-automount) { - # Use catch because we can't be sure exactly what strings - # were passed into the -automount option - catch { - if {[regsub ^/$autoDir $selection {} selection] != 0} { - break - } - } - } - } - } - - $itk_component(selection) insert 0 $selection - } else { - $itk_component(files) selection clear 0 end - } - - } else { - set selection [$itk_component(dirs) getcurselection] - - if {[file tail $selection] == "."} { - if {$selection != "."} { - set selection [file dirname $selection] - } else { - set selection $_pwd - } - } elseif {[file tail $selection] == ".."} { - if {$selection != ".."} { - set selection [file dirname [file dirname $selection]] - } else { - set selection [file join $_pwd ..] - } - } else { - set selection [file join $_pwd $selection] - } - - # - # Remove automounter paths. - # - if {$tcl_platform(platform) == "unix"} { - if {$itk_option(-automount) != {}} { - foreach autoDir $itk_option(-automount) { - # Use catch because we can't be sure exactly what strings - # were passed into the -automount option - catch { - if {[regsub ^/$autoDir $selection {} selection] != 0} { - break - } - } - } - } - } - - $itk_component(selection) delete 0 end - $itk_component(selection) insert 0 $selection - } - - $itk_component(selection) icursor end - - # - # Make sure the right most text is visable. - # - $itk_component(selection) xview moveto 1 -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _setDirList -# -# Clear the directory list and dependent on whether the user has -# defined their own search procedure or not fill the list with their -# results or those of a glob. Select the first element if it exists. -# ------------------------------------------------------------------ -itcl::body iwidgets::Fileselectionbox::_setDirList {} { - $itk_component(dirs) clear - - if {$itk_option(-dirsearchcommand) == {}} { - foreach i [lsort [glob -nocomplain \ - [file join $_pwd .*] [file join $_pwd *]]] { - if {[file isdirectory $i]} { - $itk_component(dirs) insert end [file tail "$i"] - } - } - - } else { - set mask [file tail [$itk_component(filter) get]] - - foreach file [uplevel #0 $itk_option(-dirsearchcommand) $_pwd $mask] { - $itk_component(dirs) insert end $file - } - } - - if {[$itk_component(dirs) size]} { - $itk_component(dirs) selection clear 0 end - $itk_component(dirs) selection set 0 - } -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _setFileList -# -# Clear the file list and dependent on whether the user has defined -# their own search procedure or not fill the list with their results -# or those of a 'glob'. If the files list has no contents, then set -# the files list to the 'nomatchstring'. Clear all selections. -# ------------------------------------------------------------------ -itcl::body iwidgets::Fileselectionbox::_setFileList {} { - $itk_component(files) clear - set mask [file tail [$itk_component(filter) get]] - - if {$itk_option(-filesearchcommand) == {}} { - if {$mask == "*"} { - set files [lsort [glob -nocomplain \ - [file join $_pwd .*] [file join $_pwd *]]] - } else { - set files [lsort [glob -nocomplain [file join $_pwd $mask]]] - } - - foreach i $files { - if {($itk_option(-filetype) == "regular" && \ - ! [file isdirectory $i]) || \ - ($itk_option(-filetype) == "directory" && \ - [file isdirectory $i]) || \ - ($itk_option(-filetype) == "any")} { - $itk_component(files) insert end [file tail "$i"] - } - } - - } else { - foreach file [uplevel #0 $itk_option(-filesearchcommand) $_pwd $mask] { - $itk_component(files) insert end $file - } - } - - if {[$itk_component(files) size] == 0} { - if {$itk_option(-nomatchstring) != {}} { - $itk_component(files) insert end $itk_option(-nomatchstring) - } - } - - $itk_component(files) selection clear 0 end -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _selectDir -# -# For a selection in the directory list, set the filter and possibly -# the selection entry based on the fileson option. -# ------------------------------------------------------------------ -itcl::body iwidgets::Fileselectionbox::_selectDir {} { - _setFilter - - if {$itk_option(-fileson)} {} { - _setSelection - } - - if {$itk_option(-selectdircommand) != {}} { - uplevel #0 $itk_option(-selectdircommand) - } -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _dblSelectDir -# -# For a double click event in the directory list, select the -# directory, set the default to the selection, and update both the -# file and directory lists. -# ------------------------------------------------------------------ -itcl::body iwidgets::Fileselectionbox::_dblSelectDir {} { - filter -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _selectFile -# -# The user has selected a file. Put the current selection in the -# file list in the selection entry widget. -# ------------------------------------------------------------------ -itcl::body iwidgets::Fileselectionbox::_selectFile {} { - _setSelection - - if {$itk_option(-selectfilecommand) != {}} { - uplevel #0 $itk_option(-selectfilecommand) - } -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _selectSelection -# -# The user has pressed Return in the selection entry widget. Call -# the defined selection command if it exists. -# ------------------------------------------------------------------ -itcl::body iwidgets::Fileselectionbox::_selectSelection {} { - if {$itk_option(-selectioncommand) != {}} { - uplevel #0 $itk_option(-selectioncommand) - } -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _selectFilter -# -# The user has pressed Return in the filter entry widget. Call the -# defined selection command if it exists, otherwise just filter. -# ------------------------------------------------------------------ -itcl::body iwidgets::Fileselectionbox::_selectFilter {} { - if {$itk_option(-filtercommand) != {}} { - uplevel #0 $itk_option(-filtercommand) - } else { - filter - } -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _packComponents -# -# Pack the selection, items, and child site widgets based on options. -# Using the -in option of pack, put the childsite around the frame -# in the hull for n, s, e, and w positions. Make sure and raise -# the child site since using the 'in' option may obscure the site. -# ------------------------------------------------------------------ -itcl::body iwidgets::Fileselectionbox::_packComponents {{when "later"}} { - if {$when == "later"} { - if {$_packToken == ""} { - set _packToken [after idle [itcl::code $this _packComponents now]] - } - return - } elseif {$when != "now"} { - error "bad option \"$when\": should be now or later" - } - - set _packToken "" - - # - # Forget about any previous placements via the grid and - # reset all the possible minsizes and weights for all - # the rows and columns. - # - foreach component {childsite filter dirs files selection} { - grid forget $itk_component($component) - } - - for {set row 0} {$row < 6} {incr row} { - grid rowconfigure $_interior $row -minsize 0 -weight 0 - } - - for {set col 0} {$col < 4} {incr col} { - grid columnconfigure $_interior $col -minsize 0 -weight 0 - } - - # - # Place all the components based on the childsite poisition - # option. - # - switch $itk_option(-childsitepos) { - n { _nPos } - - w { _wPos } - - s { _sPos } - - e { _ePos } - - center { _centerPos } - - top { _topPos } - - bottom { _bottomPos } - - default { - error "bad childsitepos option \"$itk_option(-childsitepos)\":\ - should be n, e, s, w, center, top, or bottom" - } - } -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _nPos -# -# Position the childsite to the north and all the other components -# appropriately based on the individual "on" options. -# ------------------------------------------------------------------ -itcl::body iwidgets::Fileselectionbox::_nPos {} { - grid $itk_component(childsite) -row 0 -column 0 \ - -columnspan 3 -rowspan 1 -sticky nsew - - if {$itk_option(-filteron)} { - grid $itk_component(filter) -row 1 -column 0 \ - -columnspan 3 -sticky ew - grid rowconfigure $_interior 2 -minsize 7 - } - - if {$itk_option(-dirson)} { - grid $itk_component(dirs) -row 3 -column 0 \ - -columnspan 1 -sticky nsew - } - if {$itk_option(-fileson)} { - grid $itk_component(files) -row 3 -column 2 \ - -columnspan 1 -sticky nsew - } - if {$itk_option(-dirson)} { - if {$itk_option(-fileson)} { - grid columnconfigure $_interior 1 -minsize 7 - } else { - grid configure $itk_component(dirs) -columnspan 3 -column 0 - } - } else { - if {$itk_option(-fileson)} { - grid configure $itk_component(files) -columnspan 3 -column 0 - } - } - - grid rowconfigure $_interior 3 -weight 1 - - if {$itk_option(-selectionon)} { - grid rowconfigure $_interior 4 -minsize 7 - grid $itk_component(selection) -row 5 -column 0 \ - -columnspan 3 -sticky ew - } - - grid columnconfigure $_interior 0 -weight 1 - grid columnconfigure $_interior 2 -weight 1 -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _sPos -# -# Position the childsite to the south and all the other components -# appropriately based on the individual "on" options. -# ------------------------------------------------------------------ -itcl::body iwidgets::Fileselectionbox::_sPos {} { - if {$itk_option(-filteron)} { - grid $itk_component(filter) -row 0 -column 0 \ - -columnspan 3 -sticky ew - grid rowconfigure $_interior 1 -minsize 7 - } - - if {$itk_option(-dirson)} { - grid $itk_component(dirs) -row 2 -column 0 \ - -columnspan 1 -sticky nsew - } - if {$itk_option(-fileson)} { - grid $itk_component(files) -row 2 -column 2 \ - -columnspan 1 -sticky nsew - } - if {$itk_option(-dirson)} { - if {$itk_option(-fileson)} { - grid columnconfigure $_interior 1 -minsize 7 - } else { - grid configure $itk_component(dirs) -columnspan 3 -column 0 - } - } else { - if {$itk_option(-fileson)} { - grid configure $itk_component(files) -columnspan 3 -column 0 - } - } - - grid rowconfigure $_interior 2 -weight 1 - - if {$itk_option(-selectionon)} { - grid rowconfigure $_interior 3 -minsize 7 - grid $itk_component(selection) -row 4 -column 0 \ - -columnspan 3 -sticky ew - } - - grid $itk_component(childsite) -row 5 -column 0 \ - -columnspan 3 -rowspan 1 -sticky nsew - grid columnconfigure $_interior 0 -weight 1 - grid columnconfigure $_interior 2 -weight 1 -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _ePos -# -# Position the childsite to the east and all the other components -# appropriately based on the individual "on" options. -# ------------------------------------------------------------------ -itcl::body iwidgets::Fileselectionbox::_ePos {} { - if {$itk_option(-filteron)} { - grid $itk_component(filter) -row 0 -column 0 \ - -columnspan 3 -sticky ew - grid rowconfigure $_interior 1 -minsize 7 - } - - if {$itk_option(-dirson)} { - grid $itk_component(dirs) -row 2 -column 0 \ - -columnspan 1 -sticky nsew - } - if {$itk_option(-fileson)} { - grid $itk_component(files) -row 2 -column 2 \ - -columnspan 1 -sticky nsew - } - if {$itk_option(-dirson)} { - if {$itk_option(-fileson)} { - grid columnconfigure $_interior 1 -minsize 7 - } else { - grid configure $itk_component(dirs) -columnspan 3 -column 0 - } - } else { - if {$itk_option(-fileson)} { - grid configure $itk_component(files) -columnspan 3 -column 0 - } - } - - grid rowconfigure $_interior 2 -weight 1 - - if {$itk_option(-selectionon)} { - grid rowconfigure $_interior 3 -minsize 7 - grid $itk_component(selection) -row 4 -column 0 \ - -columnspan 3 -sticky ew - } - - grid $itk_component(childsite) -row 0 -column 3 \ - -rowspan 5 -columnspan 1 -sticky nsew - grid columnconfigure $_interior 0 -weight 1 - grid columnconfigure $_interior 2 -weight 1 -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _wPos -# -# Position the childsite to the west and all the other components -# appropriately based on the individual "on" options. -# ------------------------------------------------------------------ -itcl::body iwidgets::Fileselectionbox::_wPos {} { - grid $itk_component(childsite) -row 0 -column 0 \ - -rowspan 5 -columnspan 1 -sticky nsew - - if {$itk_option(-filteron)} { - grid $itk_component(filter) -row 0 -column 1 \ - -columnspan 3 -sticky ew - grid rowconfigure $_interior 1 -minsize 7 - } - - if {$itk_option(-dirson)} { - grid $itk_component(dirs) -row 2 -column 1 \ - -columnspan 1 -sticky nsew - } - if {$itk_option(-fileson)} { - grid $itk_component(files) -row 2 -column 3 \ - -columnspan 1 -sticky nsew - } - if {$itk_option(-dirson)} { - if {$itk_option(-fileson)} { - grid columnconfigure $_interior 2 -minsize 7 - } else { - grid configure $itk_component(dirs) -columnspan 3 -column 1 - } - } else { - if {$itk_option(-fileson)} { - grid configure $itk_component(files) -columnspan 3 -column 1 - } - } - - grid rowconfigure $_interior 2 -weight 1 - - if {$itk_option(-selectionon)} { - grid rowconfigure $_interior 3 -minsize 7 - grid $itk_component(selection) -row 4 -column 1 \ - -columnspan 3 -sticky ew - } - - grid columnconfigure $_interior 1 -weight 1 - grid columnconfigure $_interior 3 -weight 1 -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _topPos -# -# Position the childsite below the filter but above the lists and -# all the other components appropriately based on the individual -# "on" options. -# ------------------------------------------------------------------ -itcl::body iwidgets::Fileselectionbox::_topPos {} { - if {$itk_option(-filteron)} { - grid $itk_component(filter) -row 0 -column 0 \ - -columnspan 3 -sticky ew - } - - grid $itk_component(childsite) -row 1 -column 0 \ - -columnspan 3 -rowspan 1 -sticky nsew - - if {$itk_option(-dirson)} { - grid $itk_component(dirs) -row 2 -column 0 -sticky nsew - } - if {$itk_option(-fileson)} { - grid $itk_component(files) -row 2 -column 2 -sticky nsew - } - if {$itk_option(-dirson)} { - if {$itk_option(-fileson)} { - grid columnconfigure $_interior 1 -minsize 7 - } else { - grid configure $itk_component(dirs) -columnspan 3 -column 0 - } - } else { - if {$itk_option(-fileson)} { - grid configure $itk_component(files) -columnspan 3 -column 0 - } - } - - grid rowconfigure $_interior 2 -weight 1 - - if {$itk_option(-selectionon)} { - grid rowconfigure $_interior 3 -minsize 7 - grid $itk_component(selection) -row 4 -column 0 \ - -columnspan 3 -sticky ew - } - - grid columnconfigure $_interior 0 -weight 1 - grid columnconfigure $_interior 2 -weight 1 -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _centerPos -# -# Position the childsite between the lists and all the other -# components appropriately based on the individual "on" options. -# ------------------------------------------------------------------ -itcl::body iwidgets::Fileselectionbox::_centerPos {} { - if {$itk_option(-filteron)} { - grid $itk_component(filter) -row 0 -column 0 \ - -columnspan 3 -sticky ew - grid rowconfigure $_interior 1 -minsize 7 - } - - if {$itk_option(-dirson)} { - grid $itk_component(dirs) -row 2 -column 0 \ - -columnspan 1 -sticky nsew - } - if {$itk_option(-fileson)} { - grid $itk_component(files) -row 2 -column 2 \ - -columnspan 1 -sticky nsew - } - grid $itk_component(childsite) -row 2 \ - -columnspan 1 -rowspan 1 -sticky nsew - - if {$itk_option(-dirson)} { - if {$itk_option(-fileson)} { - grid configure $itk_component(childsite) -column 1 - grid columnconfigure $_interior 0 -weight 1 - grid columnconfigure $_interior 2 -weight 1 - - } else { - grid configure $itk_component(dirs) -columnspan 2 -column 0 - grid configure $itk_component(childsite) -column 2 - grid columnconfigure $_interior 0 -weight 1 - grid columnconfigure $_interior 1 -weight 1 - } - } else { - grid configure $itk_component(childsite) -column 0 - if {$itk_option(-fileson)} { - grid configure $itk_component(files) -columnspan 2 \ - -column 1 - grid columnconfigure $_interior 1 -weight 1 - grid columnconfigure $_interior 2 -weight 1 - } else { - grid columnconfigure $_interior 0 -weight 1 - } - } - - grid rowconfigure $_interior 2 -weight 1 - - if {$itk_option(-selectionon)} { - grid rowconfigure $_interior 3 -minsize 7 - grid $itk_component(selection) -row 4 -column 0 \ - -columnspan 3 -sticky ew - } -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _bottomPos -# -# Position the childsite below the lists and above the selection -# and all the other components appropriately based on the individual -# "on" options. -# ------------------------------------------------------------------ -itcl::body iwidgets::Fileselectionbox::_bottomPos {} { - if {$itk_option(-filteron)} { - grid $itk_component(filter) -row 0 -column 0 \ - -columnspan 3 -sticky ew - grid rowconfigure $_interior 1 -minsize 7 - } - - if {$itk_option(-dirson)} { - grid $itk_component(dirs) -row 2 -column 0 -sticky nsew - } - if {$itk_option(-fileson)} { - grid $itk_component(files) -row 2 -column 2 -sticky nsew - } - if {$itk_option(-dirson)} { - if {$itk_option(-fileson)} { - grid columnconfigure $_interior 1 -minsize 7 - } else { - grid configure $itk_component(dirs) -columnspan 3 -column 0 - } - } else { - if {$itk_option(-fileson)} { - grid configure $itk_component(files) -columnspan 3 -column 0 - } - } - grid rowconfigure $_interior 2 -weight 1 - - grid $itk_component(childsite) -row 3 -column 0 \ - -columnspan 3 -rowspan 1 -sticky nsew - - if {$itk_option(-selectionon)} { - grid $itk_component(selection) -row 4 -column 0 \ - -columnspan 3 -sticky ew - } - - grid columnconfigure $_interior 0 -weight 1 - grid columnconfigure $_interior 2 -weight 1 -} diff --git a/iwidgets/library/fileselectiondialog.itk b/iwidgets/library/fileselectiondialog.itk deleted file mode 100644 index 614f649..0000000 --- a/iwidgets/library/fileselectiondialog.itk +++ /dev/null @@ -1,181 +0,0 @@ -# -# Fileselectiondialog -# ---------------------------------------------------------------------- -# Implements a file selection box similar to the OSF/Motif standard -# file selection dialog composite widget. The Fileselectiondialog is -# derived from the Dialog class and is composed of a FileSelectionBox -# with attributes set to manipulate the dialog buttons. -# -# ---------------------------------------------------------------------- -# AUTHOR: Mark L. Ulferts EMAIL: mulferts@spd.dsccc.com -# -# @(#) $Id: fileselectiondialog.itk,v 1.2 2001/08/07 19:56:48 smithc Exp $ -# ---------------------------------------------------------------------- -# Copyright (c) 1995 DSC Technologies Corporation -# ====================================================================== -# Permission to use, copy, modify, distribute and license this software -# and its documentation for any purpose, and without fee or written -# agreement with DSC, is hereby granted, provided that the above copyright -# notice appears in all copies and that both the copyright notice and -# warranty disclaimer below appear in supporting documentation, and that -# the names of DSC Technologies Corporation or DSC Communications -# Corporation not be used in advertising or publicity pertaining to the -# software without specific, written prior permission. -# -# DSC DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING -# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, 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. IN NO EVENT SHALL -# DSC BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR -# ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, -# WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION, -# ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS -# SOFTWARE. -# ====================================================================== - -# -# Usual options. -# -itk::usual Fileselectiondialog { - keep -activebackground -activerelief -background -borderwidth -cursor \ - -elementborderwidth -foreground -highlightcolor -highlightthickness \ - -insertbackground -insertborderwidth -insertofftime -insertontime \ - -insertwidth -jump -labelfont -modality -selectbackground \ - -selectborderwidth -textbackground -textfont -} - -# ------------------------------------------------------------------ -# FILESELECTIONDIALOG -# ------------------------------------------------------------------ -itcl::class iwidgets::Fileselectiondialog { - inherit iwidgets::Dialog - - constructor {args} {} - - public { - method childsite {} - method get {} - method filter {} - } - - protected method _dbldir {} -} - -# -# Provide a lowercased access method for the Fileselectiondialog class. -# -proc ::iwidgets::fileselectiondialog {pathName args} { - uplevel ::iwidgets::Fileselectiondialog $pathName $args -} - -# -# Use option database to override default resources of base classes. -# -option add *Fileselectiondialog.borderWidth 2 widgetDefault - -option add *Fileselectiondialog.title "File Selection Dialog" widgetDefault - -option add *Fileselectiondialog.width 350 widgetDefault -option add *Fileselectiondialog.height 400 widgetDefault - -option add *Fileselectiondialog.master "." widgetDefault - -# ------------------------------------------------------------------ -# CONSTRUCTOR -# ------------------------------------------------------------------ -itcl::body iwidgets::Fileselectiondialog::constructor {args} { - component hull configure -borderwidth 0 - itk_option add hull.width hull.height - - # - # Turn off pack propagation for the hull widget so the width - # and height options become active. - # - pack propagate $itk_component(hull) no - - # - # Instantiate a file selection box widget. - # - itk_component add fsb { - iwidgets::Fileselectionbox $itk_interior.fsb -width 150 -height 150 \ - -selectioncommand [itcl::code $this invoke] \ - -selectdircommand [itcl::code $this default Apply] \ - -selectfilecommand [itcl::code $this default OK] - } { - usual - - keep -labelfont -childsitepos -directory -dirslabel \ - -dirsearchcommand -dirson -fileslabel -fileson \ - -filesearchcommand -filterlabel -filteron \ - -filetype -invalid -mask -nomatchstring \ - -selectionlabel -selectionon - } - grid $itk_component(fsb) -sticky nsew - grid rowconfigure $itk_interior 0 -weight 1 - grid columnconfigure $itk_interior 0 -weight 1 - - $itk_component(fsb) component filter configure \ - -focuscommand [itcl::code $this default Apply] - $itk_component(fsb) component selection configure \ - -focuscommand [itcl::code $this default OK] - $itk_component(fsb) component dirs configure \ - -dblclickcommand [itcl::code $this _dbldir] - $itk_component(fsb) component files configure \ - -dblclickcommand [itcl::code $this invoke] - - buttonconfigure Apply -text "Filter" \ - -command [itcl::code $itk_component(fsb) filter] - - set itk_interior [$itk_component(fsb) childsite] - - hide Help - - eval itk_initialize $args -} - -# ------------------------------------------------------------------ -# METHODS -# ------------------------------------------------------------------ - -# ------------------------------------------------------------------ -# METHOD: childsite -# -# Thinwrapped method of file selection box class. -# ------------------------------------------------------------------ -itcl::body iwidgets::Fileselectiondialog::childsite {} { - return [$itk_component(fsb) childsite] -} - -# ------------------------------------------------------------------ -# METHOD: get -# -# Thinwrapped method of file selection box class. -# ------------------------------------------------------------------ -itcl::body iwidgets::Fileselectiondialog::get {} { - return [$itk_component(fsb) get] -} - -# ------------------------------------------------------------------ -# METHOD: filter -# -# Thinwrapped method of file selection box class. -# ------------------------------------------------------------------ -itcl::body iwidgets::Fileselectiondialog::filter {} { - return [$itk_component(fsb) filter] -} - -# ------------------------------------------------------------------ -# PROTECTED METHOD: _dbldir -# -# Double select in directory list. If the files list is on then -# make the default button the filter and invoke. If not, just invoke. -# ------------------------------------------------------------------ -itcl::body iwidgets::Fileselectiondialog::_dbldir {} { - if {$itk_option(-fileson)} { - default Apply - } - - invoke -} - diff --git a/iwidgets/library/finddialog.itk b/iwidgets/library/finddialog.itk deleted file mode 100644 index 093023b..0000000 --- a/iwidgets/library/finddialog.itk +++ /dev/null @@ -1,488 +0,0 @@ -# -# Finddialog -# ---------------------------------------------------------------------- -# This class implements a dialog for searching text. It prompts the -# user for a search string and the method of searching which includes -# case sensitive, regular expressions, backwards, and all. -# -# ---------------------------------------------------------------------- -# AUTHOR: Mark L. Ulferts EMAIL: mulferts@austin.dsccc.com -# -# @(#) RCS: $Id: finddialog.itk,v 1.3 2001/08/07 19:56:48 smithc Exp $ -# ---------------------------------------------------------------------- -# Copyright (c) 1996 DSC Technologies Corporation -# ====================================================================== -# Permission to use, copy, modify, distribute and license this software -# and its documentation for any purpose, and without fee or written -# agreement with DSC, is hereby granted, provided that the above copyright -# notice appears in all copies and that both the copyright notice and -# warranty disclaimer below appear in supporting documentation, and that -# the names of DSC Technologies Corporation or DSC Communications -# Corporation not be used in advertising or publicity pertaining to the -# software without specific, written prior permission. -# -# DSC DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING -# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, 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. IN NO EVENT SHALL -# DSC BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR -# ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, -# WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION, -# ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS -# SOFTWARE. -# ====================================================================== - -# -# Usual options. -# -itk::usual Finddialog { - keep -background -cursor -foreground -selectcolor -} - -# ------------------------------------------------------------------ -# IPRFINDDIALOG -# ------------------------------------------------------------------ -itcl::class ::iwidgets::Finddialog { - inherit iwidgets::Dialogshell - - constructor {args} {} - - itk_option define -selectcolor selectColor Background {} - itk_option define -clearcommand clearCommand Command {} - itk_option define -matchcommand matchCommand Command {} - itk_option define -patternbackground patternBackground Background \#707070 - itk_option define -patternforeground patternForeground Foreground White - itk_option define -searchbackground searchBackground Background \#c4c4c4 - itk_option define -searchforeground searchForeground Foreground Black - itk_option define -textwidget textWidget TextWidget {} - - public { - method clear {} - method find {} - } - - protected { - method _get {setting} - method _textExists {} - - common _optionValues ;# Current settings of check buttons. - common _searchPoint ;# Starting location for searches - common _matchLen ;# Matching pattern string length - } -} - -# -# Provide a lowercased access method for the ::finddialog class. -# -proc ::iwidgets::finddialog {pathName args} { - uplevel ::iwidgets::Finddialog $pathName $args -} - -# -# Use option database to override default resources of base classes. -# -option add *Finddialog.title "Find" widgetDefault - -# ------------------------------------------------------------------ -# CONSTRUCTOR -# ------------------------------------------------------------------ -itcl::body ::iwidgets::Finddialog::constructor {args} { - # - # Add the find pattern entryfield. - # - itk_component add pattern { - iwidgets::Entryfield $itk_interior.pattern -labeltext "Find:" - } - bind [$itk_component(pattern) component entry] \ - "[itcl::code $this invoke]; break" - - # - # Add the find all checkbutton. - # - itk_component add all { - checkbutton $itk_interior.all \ - -variable [itcl::scope _optionValues($this-all)] \ - -text "All" - } - - # - # Add the case consideration checkbutton. - # - itk_component add case { - checkbutton $itk_interior.case \ - -variable [itcl::scope _optionValues($this-case)] \ - -text "Consider Case" - } - - # - # Add the regular expression checkbutton. - # - itk_component add regexp { - checkbutton $itk_interior.regexp \ - -variable [itcl::scope _optionValues($this-regexp)] \ - -text "Use Regular Expression" - } - - # - # Add the find backwards checkbutton. - # - itk_component add backwards { - checkbutton $itk_interior.backwards \ - -variable [itcl::scope _optionValues($this-backwards)] \ - -text "Find Backwards" - } - - # - # Add the find, clear, and close buttons, making find be the default. - # - add Find -text Find -command [itcl::code $this find] - add Clear -text Clear -command [itcl::code $this clear] - add Close -text Close -command [itcl::code $this deactivate 0] - - default Find - - # - # Use the grid to layout the components. - # - grid $itk_component(pattern) -row 0 -column 0 \ - -padx 10 -pady 10 -columnspan 4 -sticky ew - grid $itk_component(all) -row 1 -column 0 - grid $itk_component(case) -row 1 -column 1 - grid $itk_component(regexp) -row 1 -column 2 - grid $itk_component(backwards) -row 1 -column 3 - - grid columnconfigure $itk_interior 0 -weight 1 - grid columnconfigure $itk_interior 1 -weight 1 - grid columnconfigure $itk_interior 2 -weight 1 - grid columnconfigure $itk_interior 3 -weight 1 - - # - # Initialize all the configuration options. - # - eval itk_initialize $args -} - -# ------------------------------------------------------------------ -# OPTIONS -# ------------------------------------------------------------------ - -# ------------------------------------------------------------------ -# OPTION: -clearcommand -# -# Specifies a command to be invoked following a clear operation. -# The command is meant to be a means of notification that the -# clear has taken place and allow other actions to take place such -# as disabling a find again menu. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Finddialog::clearcommand {} - -# ------------------------------------------------------------------ -# OPTION: -matchcommand -# -# Specifies a command to be invoked following a find operation. -# The command is called with a match point as an argument. Should -# a match not be found the match point is {}. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Finddialog::matchcommand {} - -# ------------------------------------------------------------------ -# OPTION: -patternbackground -# -# Specifies the background color of the text matching the search -# pattern. It may have any of the forms accepted by Tk_GetColor. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Finddialog::patternbackground {} - -# ------------------------------------------------------------------ -# OPTION: -patternforeground -# -# Specifies the foreground color of the pattern matching a search -# operation. It may have any of the forms accepted by Tk_GetColor. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Finddialog::patternforeground {} - -# ------------------------------------------------------------------ -# OPTION: -searchforeground -# -# Specifies the foreground color of the line containing the matching -# pattern from a search operation. It may have any of the forms -# accepted by Tk_GetColor. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Finddialog::searchforeground {} - -# ------------------------------------------------------------------ -# OPTION: -searchbackground -# -# Specifies the background color of the line containing the matching -# pattern from a search operation. It may have any of the forms -# accepted by Tk_GetColor. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Finddialog::searchbackground {} - -# ------------------------------------------------------------------ -# OPTION: -textwidget -# -# Specifies the scrolledtext or text widget to be searched. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Finddialog::textwidget { - if {$itk_option(-textwidget) != {}} { - set _searchPoint($itk_option(-textwidget)) 1.0 - } -} - -# ------------------------------------------------------------------ -# METHODS -# ------------------------------------------------------------------ - -# ------------------------------------------------------------------ -# PUBLIC METHOD: clear -# -# Clear the pattern entryfield and the indicators. -# ------------------------------------------------------------------ -itcl::body ::iwidgets::Finddialog::clear {} { - $itk_component(pattern) clear - - if {[_textExists]} { - set _searchPoint($itk_option(-textwidget)) 1.0 - - $itk_option(-textwidget) tag remove search-line 1.0 end - $itk_option(-textwidget) tag remove search-pattern 1.0 end - } - - if {$itk_option(-clearcommand) != {}} { - eval $itk_option(-clearcommand) - } -} - -# ------------------------------------------------------------------ -# PUBLIC METHOD: find -# -# Search for a specific text string in the text widget given by -# the -textwidget option. Should this option not be set to an -# existing widget, then a quick exit is made. -# ------------------------------------------------------------------ -itcl::body ::iwidgets::Finddialog::find {} { - if {! [_textExists]} { - return - } - - # - # Clear any existing indicators in the text widget. - # - $itk_option(-textwidget) tag remove search-line 1.0 end - $itk_option(-textwidget) tag remove search-pattern 1.0 end - - # - # Make sure the search pattern isn't just blank. If so, skip this. - # - set pattern [_get pattern] - - if {[string trim $pattern] == ""} { - return - } - - # - # After clearing out any old highlight indicators from a previous - # search, we'll be building our search command piece-meal based on - # the current settings of the checkbuttons in the find dialog. The - # first we'll add is a variable to catch the count of the length - # of the string matching the pattern. - # - set precmd "$itk_option(-textwidget) search \ - -count [list [itcl::scope _matchLen($this)]]" - - if {! [_get case]} { - append precmd " -nocase" - } - - if {[_get regexp]} { - append precmd " -regexp" - } else { - append precmd " -exact" - } - - # - # If we are going to find all matches, then the start point for - # the search will be the beginning of the text; otherwise, we'll - # use the last known starting point +/- a character depending on - # the direction. - # - if {[_get all]} { - set _searchPoint($itk_option(-textwidget)) 1.0 - } else { - if {[_get backwards]} { - append precmd " -backwards" - } else { - append precmd " -forwards" - } - } - - # - # Get the pattern to be matched and add it to the search command. - # Since it may contain embedded spaces, we'll wrap it in a list. - # - append precmd " [list $pattern]" - - # - # If the search is for all matches, then we'll be performing the - # search until no more matches are found; otherwise, we'll break - # out of the loop after one search. - # - while {1} { - if {[_get all]} { - set postcmd " $_searchPoint($itk_option(-textwidget)) end" - - } else { - set postcmd " $_searchPoint($itk_option(-textwidget))" - } - - # - # Create the final search command out of the pre and post parts - # and evaluate it which returns the location of the matching string. - # - set cmd {} - append cmd $precmd $postcmd - - if {[catch {eval $cmd} matchPoint] != 0} { - set _searchPoint($itk_option(-textwidget)) 1.0 - return {} - } - - # - # If a match exists, then we'll make this spot be the new starting - # position. Then we'll tag the line and the pattern in the line. - # The foreground and background settings will lite these positions - # in the text widget up. - # - if {$matchPoint != {}} { - set _searchPoint($itk_option(-textwidget)) $matchPoint - - $itk_option(-textwidget) tag add search-line \ - "$_searchPoint($itk_option(-textwidget)) linestart" \ - "$_searchPoint($itk_option(-textwidget))" - $itk_option(-textwidget) tag add search-line \ - "$_searchPoint($itk_option(-textwidget)) + \ - $_matchLen($this) chars" \ - "$_searchPoint($itk_option(-textwidget)) lineend" - $itk_option(-textwidget) tag add search-pattern \ - $_searchPoint($itk_option(-textwidget)) \ - "$_searchPoint($itk_option(-textwidget)) + \ - $_matchLen($this) chars" - } - - # - # Set the search point for the next time through to be one - # character more or less from the current search point based - # on the direction. - # - if {[_get all] || ! [_get backwards]} { - set _searchPoint($itk_option(-textwidget)) \ - [$itk_option(-textwidget) index \ - "$_searchPoint($itk_option(-textwidget)) + 1c"] - } else { - set _searchPoint($itk_option(-textwidget)) \ - [$itk_option(-textwidget) index \ - "$_searchPoint($itk_option(-textwidget)) - 1c"] - } - - # - # If this isn't a find all operation or we didn't get a match, exit. - # - if {(! [_get all]) || ($matchPoint == {})} { - break - } - } - - # - # Configure the colors for the search-line and search-pattern. - # - $itk_option(-textwidget) tag configure search-line \ - -foreground $itk_option(-searchforeground) - $itk_option(-textwidget) tag configure search-line \ - -background $itk_option(-searchbackground) - $itk_option(-textwidget) tag configure search-pattern \ - -background $itk_option(-patternbackground) - $itk_option(-textwidget) tag configure search-pattern \ - -foreground $itk_option(-patternforeground) - - # - # Adjust the view to be the last matched position. - # - if {$matchPoint != {}} { - $itk_option(-textwidget) see $matchPoint - } - - # - # There may be multiple matches of the pattern on a single line, - # so we'll set the tag priorities such that the pattern tag is higher. - # - $itk_option(-textwidget) tag raise search-pattern search-line - - # - # If a match command is defined, then call it with the match point. - # - if {$itk_option(-matchcommand) != {}} { - [subst $itk_option(-matchcommand)] $matchPoint - } - - # - # Return the match point to the caller so they know if we found - # anything and if so where - # - return $matchPoint -} - -# ------------------------------------------------------------------ -# PROTECTED METHOD: _get setting -# -# Get the current value for the pattern, case, regexp, or backwards. -# ------------------------------------------------------------------ -itcl::body ::iwidgets::Finddialog::_get {setting} { - switch $setting { - pattern { - return [$itk_component(pattern) get] - } - case { - return $_optionValues($this-case) - } - regexp { - return $_optionValues($this-regexp) - } - backwards { - return $_optionValues($this-backwards) - } - all { - return $_optionValues($this-all) - } - default { - error "bad get setting: \"$setting\", should be pattern,\ - case, regexp, backwards, or all" - } - } -} - -# ------------------------------------------------------------------ -# PROTECTED METHOD: _textExists -# -# Check the validity of the text widget option. Does it exist and -# is it of the class Text or Scrolledtext. -# ------------------------------------------------------------------ -itcl::body ::iwidgets::Finddialog::_textExists {} { - if {$itk_option(-textwidget) == {}} { - return 0 - } - - if {! [winfo exists $itk_option(-textwidget)]} { - error "bad finddialog text widget value: \"$itk_option(-textwidget)\",\ - the widget doesn't exist" - } - - if {([winfo class $itk_option(-textwidget)] != "Text") && - ([itcl::find objects -isa iwidgets::Scrolledtext *::$itk_option(-textwidget)] == "")} { - error "bad finddialog text widget value: \"$itk_option(-textwidget)\",\ - must be of the class Text or based on Scrolledtext" - } - - return 1 -} diff --git a/iwidgets/library/hierarchy.itk b/iwidgets/library/hierarchy.itk deleted file mode 100644 index 03954dd..0000000 --- a/iwidgets/library/hierarchy.itk +++ /dev/null @@ -1,1983 +0,0 @@ -# Hierarchy -# ---------------------------------------------------------------------- -# Hierarchical data viewer. Manages a list of nodes that can be -# expanded or collapsed. Individual nodes can be highlighted. -# Clicking with the right mouse button on any item brings up a -# special item menu. Clicking on the background area brings up -# a different popup menu. -# ---------------------------------------------------------------------- -# AUTHOR: Michael J. McLennan -# Bell Labs Innovations for Lucent Technologies -# mmclennan@lucent.com -# -# Mark L. Ulferts -# DSC Communications -# mulferts@austin.dsccc.com -# -# RCS: $Id: hierarchy.itk,v 1.9 2002/09/06 16:27:03 smithc Exp $ -# ---------------------------------------------------------------------- -# Copyright (c) 1996 Lucent Technologies -# ====================================================================== -# Permission to use, copy, modify, and distribute this software and its -# documentation for any purpose and without fee is hereby granted, -# provided that the above copyright notice appear in all copies and that -# both that the copyright notice and warranty disclaimer appear in -# supporting documentation, and that the names of Lucent Technologies -# any of their entities not be used in advertising or publicity -# pertaining to distribution of the software without specific, written -# prior permission. -# -# Lucent Technologies disclaims all warranties with regard to this -# software, including all implied warranties of merchantability and -# fitness. In no event shall Lucent Technologies be liable for any -# special, indirect or consequential damages or any damages whatsoever -# resulting from loss of use, data or profits, whether in an action of -# contract, negligence or other tortuous action, arising out of or in -# connection with the use or performance of this software. -# -# ---------------------------------------------------------------------- -# Copyright (c) 1996 DSC Technologies Corporation -# ====================================================================== -# Permission to use, copy, modify, distribute and license this software -# and its documentation for any purpose, and without fee or written -# agreement with DSC, is hereby granted, provided that the above copyright -# notice appears in all copies and that both the copyright notice and -# warranty disclaimer below appear in supporting documentation, and that -# the names of DSC Technologies Corporation or DSC Communications -# Corporation not be used in advertising or publicity pertaining to the -# software without specific, written prior permission. -# -# DSC DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING -# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, 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. IN NO EVENT SHALL -# DSC BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR -# ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, -# WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION, -# ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS -# SOFTWARE. -# ====================================================================== - -# -# Usual options. -# -itk::usual Hierarchy { - keep -cursor -textfont -font - keep -background -foreground -textbackground - keep -selectbackground -selectforeground -} - -# ------------------------------------------------------------------ -# HIERARCHY -# ------------------------------------------------------------------ -itcl::class iwidgets::Hierarchy { - inherit iwidgets::Scrolledwidget - - constructor {args} {} - - destructor {} - - itk_option define -alwaysquery alwaysQuery AlwaysQuery 0 - itk_option define -closedicon closedIcon Icon {} - itk_option define -dblclickcommand dblClickCommand Command {} - itk_option define -expanded expanded Expanded 0 - itk_option define -filter filter Filter 0 - itk_option define -font font Font \ - -*-Courier-Medium-R-Normal--*-120-*-*-*-*-*-* - itk_option define -height height Height 0 - itk_option define -iconcommand iconCommand Command {} - itk_option define -icondblcommand iconDblCommand Command {} - itk_option define -imagecommand imageCommand Command {} - itk_option define -imagedblcommand imageDblCommand Command {} - itk_option define -imagemenuloadcommand imageMenuLoadCommand Command {} - itk_option define -markbackground markBackground Foreground #a0a0a0 - itk_option define -markforeground markForeground Background Black - itk_option define -nodeicon nodeIcon Icon {} - itk_option define -openicon openIcon Icon {} - itk_option define -querycommand queryCommand Command {} - itk_option define -selectcommand selectCommand Command {} - itk_option define -selectbackground selectBackground Foreground #c3c3c3 - itk_option define -selectforeground selectForeground Background Black - itk_option define -textmenuloadcommand textMenuLoadCommand Command {} - itk_option define -visibleitems visibleItems VisibleItems 80x24 - itk_option define -width width Width 0 - - public { - method clear {} - method collapse {node} - method current {} - method draw {{when -now}} - method expand {node} - method expanded {node} - method expState { } - method mark {op args} - method prune {node} - method refresh {node} - method selection {op args} - method toggle {node} - - method bbox {index} - method compare {index1 op index2} - method debug {args} {eval $args} - method delete {first {last {}}} - method dlineinfo {index} - method dump {args} - method get {index1 {index2 {}}} - method index {index} - method insert {args} - method scan {option args} - method search {args} - method see {index} - method tag {op args} - method window {option args} - method xview {args} - method yview {args} - } - - protected { - method _contents {uid} - method _post {x y} - method _drawLevel {node indent} - method _select {x y} - method _deselectSubNodes {uid} - method _deleteNodeInfo {uid} - method _getParent {uid} - method _getHeritage {uid} - method _isInternalTag {tag} - method _iconSelect {node icon} - method _iconDblSelect {node icon} - method _imageSelect {node} - method _imageDblClick {node} - method _imagePost {node image type x y} - method _double {x y} - } - - private { - method _configureTags {} - - variable _filterCode "" ;# Compact view flag. - variable _hcounter 0 ;# Counter for hierarchy icons - variable _icons ;# Array of user icons by uid - variable _images ;# Array of our icons by uid - variable _indents ;# Array of indentation by uid - variable _marked ;# Array of marked nodes by uid - variable _markers "" ;# List of markers for level being drawn - variable _nodes ;# Array of subnodes by uid - variable _pending "" ;# Pending draw flag - variable _posted "" ;# List of tags at posted menu position - variable _selected ;# Array of selected nodes by uid - variable _tags ;# Array of user tags by uid - variable _text ;# Array of displayed text by uid - variable _states ;# Array of selection state by uid - variable _ucounter 0 ;# Counter for user icons - } -} - -# -# Provide a lowercased access method for the Hierarchy class. -# -proc ::iwidgets::hierarchy {pathName args} { - uplevel ::iwidgets::Hierarchy $pathName $args -} - -# -# Use option database to override default resources of base classes. -# -option add *Hierarchy.menuCursor arrow widgetDefault -option add *Hierarchy.labelPos n widgetDefault -option add *Hierarchy.tabs 30 widgetDefault - -# ------------------------------------------------------------------ -# CONSTRUCTOR -# ------------------------------------------------------------------ -itcl::body iwidgets::Hierarchy::constructor {args} { - itk_option remove iwidgets::Labeledwidget::state - - # - # Our -width and -height options are slightly different than - # those implemented by our base class, so we're going to - # remove them and redefine our own. - # - itk_option remove iwidgets::Scrolledwidget::width - itk_option remove iwidgets::Scrolledwidget::height - - # - # Create a clipping frame which will provide the border for - # relief display. - # - itk_component add clipper { - frame $itk_interior.clipper - } { - usual - - keep -borderwidth -relief -highlightthickness -highlightcolor - rename -highlightbackground -background background Background - } - grid $itk_component(clipper) -row 0 -column 0 -sticky nsew - grid rowconfigure $_interior 0 -weight 1 - grid columnconfigure $_interior 0 -weight 1 - - # - # Create a text widget for displaying our hierarchy. - # - itk_component add list { - text $itk_component(clipper).list -wrap none -cursor center_ptr \ - -state disabled -width 1 -height 1 \ - -xscrollcommand \ - [itcl::code $this _scrollWidget $itk_interior.horizsb] \ - -yscrollcommand \ - [itcl::code $this _scrollWidget $itk_interior.vertsb] \ - -borderwidth 0 -highlightthickness 0 - } { - usual - - keep -spacing1 -spacing2 -spacing3 -tabs - rename -font -textfont textFont Font - rename -background -textbackground textBackground Background - ignore -highlightthickness -highlightcolor - ignore -insertbackground -insertborderwidth - ignore -insertontime -insertofftime -insertwidth - ignore -selectborderwidth - ignore -borderwidth - } - grid $itk_component(list) -row 0 -column 0 -sticky nsew - grid rowconfigure $itk_component(clipper) 0 -weight 1 - grid columnconfigure $itk_component(clipper) 0 -weight 1 - - # - # Configure the command on the vertical scroll bar in the base class. - # - $itk_component(vertsb) configure \ - -command [itcl::code $itk_component(list) yview] - - # - # Configure the command on the horizontal scroll bar in the base class. - # - $itk_component(horizsb) configure \ - -command [itcl::code $itk_component(list) xview] - - # - # Configure our text component's tab settings for twenty levels. - # - set tabs "" - for {set i 1} {$i < 20} {incr i} { - lappend tabs [expr {$i*12+4}] - } - $itk_component(list) configure -tabs $tabs - - # - # Add popup menus that can be configured by the user to add - # new functionality. - # - itk_component add itemMenu { - menu $itk_component(list).itemmenu -tearoff 0 - } { - usual - ignore -tearoff - rename -cursor -menucursor menuCursor Cursor - } - - itk_component add bgMenu { - menu $itk_component(list).bgmenu -tearoff 0 - } { - usual - ignore -tearoff - rename -cursor -menucursor menuCursor Cursor - } - - # - # Adjust the bind tags to remove the class bindings. Also, add - # bindings for mouse button 1 to do selection and button 3 to - # display a popup. - # - bindtags $itk_component(list) [list $itk_component(list) . all] - - bind $itk_component(list) \ - [itcl::code $this _select %x %y] - - bind $itk_component(list) \ - [itcl::code $this _double %x %y] - - bind $itk_component(list) \ - [itcl::code $this _post %x %y] - - # - # Initialize the widget based on the command line options. - # - eval itk_initialize $args -} - -# ------------------------------------------------------------------ -# DESTRUCTOR -# ------------------------------------------------------------------ -itcl::body iwidgets::Hierarchy::destructor {} { - if {$_pending != ""} { - after cancel $_pending - } -} - -# ------------------------------------------------------------------ -# OPTIONS -# ------------------------------------------------------------------ - -# ------------------------------------------------------------------ -# OPTION: -font -# -# Font used for text in the list. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Hierarchy::font { - $itk_component(list) tag configure info \ - -font $itk_option(-font) -spacing1 6 -} - -# ------------------------------------------------------------------ -# OPTION: -selectbackground -# -# Background color scheme for selected nodes. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Hierarchy::selectbackground { - $itk_component(list) tag configure hilite \ - -background $itk_option(-selectbackground) -} - -# ------------------------------------------------------------------ -# OPTION: -selectforeground -# -# Foreground color scheme for selected nodes. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Hierarchy::selectforeground { - $itk_component(list) tag configure hilite \ - -foreground $itk_option(-selectforeground) -} - -# ------------------------------------------------------------------ -# OPTION: -markbackground -# -# Background color scheme for marked nodes. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Hierarchy::markbackground { - $itk_component(list) tag configure lowlite \ - -background $itk_option(-markbackground) -} - -# ------------------------------------------------------------------ -# OPTION: -markforeground -# -# Foreground color scheme for marked nodes. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Hierarchy::markforeground { - $itk_component(list) tag configure lowlite \ - -foreground $itk_option(-markforeground) -} - -# ------------------------------------------------------------------ -# OPTION: -querycommand -# -# Command executed to query the contents of each node. If this -# command contains "%n", it is replaced with the name of the desired -# node. In its simpilest form it should return the children of the -# given node as a list which will be depicted in the display. -# -# Since the names of the children are used as tags in the underlying -# text widget, each child must be unique in the hierarchy. Due to -# the unique requirement, the nodes shall be reffered to as uids -# or uid in the singular sense. -# -# {uid [uid ...]} -# -# where uid is a unique id and primary key for the hierarchy entry -# -# Should the unique requirement pose a problem, the list returned -# can take on another more extended form which enables the -# association of text to be displayed with the uids. The uid must -# still be unique, but the text does not have to obey the unique -# rule. In addition, the format also allows the specification of -# additional tags to be used on the same entry in the hierarchy -# as the uid and additional icons to be displayed just before -# the node. The tags and icons are considered to be the property of -# the user in that the hierarchy widget will not depend on any of -# their values. -# -# {{uid [text [tags [icons]]]} {uid [text [tags [icons]]]} ...} -# -# where uid is a unique id and primary key for the hierarchy entry -# text is the text to be displayed for this uid -# tags is a list of user tags to be applied to the entry -# icons is a list of icons to be displayed in front of the text -# -# The hierarchy widget does a look ahead from each node to determine -# if the node has a children. This can be cost some performace with -# large hierarchies. User's can avoid this by providing a hint in -# the user tags. A tag of "leaf" or "branch" tells the hierarchy -# widget the information it needs to know thereby avoiding the look -# ahead operation. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Hierarchy::querycommand { - clear - draw -eventually - - # Added for SF ticket #596111 - _configureTags -} - -# ------------------------------------------------------------------ -# OPTION: -selectcommand -# -# Command executed to select an item in the list. If this command -# contains "%n", it is replaced with the name of the selected node. -# If it contains a "%s", it is replaced with a boolean indicator of -# the node's current selection status, where a value of 1 denotes -# that the node is currently selected and 0 that it is not. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Hierarchy::selectcommand { -} - -# ------------------------------------------------------------------ -# OPTION: -dblclickcommand -# -# Command executed to double click an item in the list. If this command -# contains "%n", it is replaced with the name of the selected node. -# If it contains a "%s", it is replaced with a boolean indicator of -# the node's current selection status, where a value of 1 denotes -# that the node is currently selected and 0 that it is not. -# -# Douglas R. Howard, Jr. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Hierarchy::dblclickcommand { -} - -# ------------------------------------------------------------------ -# OPTION: -iconcommand -# -# Command executed upon selection of user icons. If this command -# contains "%n", it is replaced with the name of the node the icon -# belongs to. Should it contain "%i" then the icon name is -# substituted. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Hierarchy::iconcommand { -} - -# ------------------------------------------------------------------ -# OPTION: -icondblcommand -# -# Command executed upon double selection of user icons. If this command -# contains "%n", it is replaced with the name of the node the icon -# belongs to. Should it contain "%i" then the icon name is -# substituted. -# -# Douglas R. Howard, Jr. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Hierarchy::icondblcommand { -} - -# ------------------------------------------------------------------ -# OPTION: -imagecommand -# -# Command executed upon selection of image icons. If this command -# contains "%n", it is replaced with the name of the node the icon -# belongs to. Should it contain "%i" then the icon name is -# substituted. -# -# Douglas R. Howard, Jr. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Hierarchy::imagecommand { -} - -# ------------------------------------------------------------------ -# OPTION: -imagedblcommand -# -# Command executed upon double selection of user icons. If this command -# contains "%n", it is replaced with the name of the node the icon -# belongs to. -# -# Douglas R. Howard, Jr. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Hierarchy::imagedblcommand { -} - -# ------------------------------------------------------------------ -# OPTION: -alwaysquery -# -# Boolean flag which tells the hierarchy widget weather or not -# each refresh of the display should be via a new query using -# the -querycommand option or use the values previous found the -# last time the query was made. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Hierarchy::alwaysquery { - switch -- $itk_option(-alwaysquery) { - 1 - true - yes - on { - ;# okay - } - 0 - false - no - off { - ;# okay - } - default { - error "bad alwaysquery option \"$itk_option(-alwaysquery)\":\ - should be boolean" - } - } -} - -# ------------------------------------------------------------------ -# OPTION: -filter -# -# When true only the branch nodes and selected items are displayed. -# This gives a compact view of important items. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Hierarchy::filter { - switch -- $itk_option(-filter) { - 1 - true - yes - on { - set newCode {set display [info exists _selected($child)]} - } - 0 - false - no - off { - set newCode {set display 1} - } - default { - error "bad filter option \"$itk_option(-filter)\":\ - should be boolean" - } - } - if {$newCode != $_filterCode} { - set _filterCode $newCode - draw -eventually - } -} - -# ------------------------------------------------------------------ -# OPTION: -expanded -# -# When true, the hierarchy will be completely expanded when it -# is first displayed. A fresh display can be triggered by -# resetting the -querycommand option. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Hierarchy::expanded { - switch -- $itk_option(-expanded) { - 1 - true - yes - on { - ;# okay - } - 0 - false - no - off { - ;# okay - } - default { - error "bad expanded option \"$itk_option(-expanded)\":\ - should be boolean" - } - } -} - -# ------------------------------------------------------------------ -# OPTION: -openicon -# -# Specifies the open icon image to be used in the hierarchy. Should -# one not be provided, then one will be generated, pixmap if -# possible, bitmap otherwise. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Hierarchy::openicon { - if {$itk_option(-openicon) == {}} { - if {[lsearch [image names] openFolder] == -1} { - if {[lsearch [image types] pixmap] != -1} { - image create pixmap openFolder -data { - /* XPM */ - static char * dir_opened [] = { - "16 16 4 1", - /* colors */ - ". c grey85 m white g4 grey90", - "b c black m black g4 black", - "y c yellow m white g4 grey80", - "g c grey70 m white g4 grey70", - /* pixels */ - "................", - "................", - "................", - "..bbbb..........", - ".bggggb.........", - "bggggggbbbbbbb..", - "bggggggggggggb..", - "bgbbbbbbbbbbbbbb", - "bgbyyyyyyyyyyybb", - "bbyyyyyyyyyyyyb.", - "bbyyyyyyyyyyybb.", - "byyyyyyyyyyyyb..", - "bbbbbbbbbbbbbb..", - "................", - "................", - "................"}; - } - } else { - image create bitmap openFolder -data { - #define open_width 16 - #define open_height 16 - static char open_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x3c, 0x00, 0x42, 0x00, - 0x81, 0x3f, 0x01, 0x20, 0xf9, 0xff, 0x0d, 0xc0, - 0x07, 0x40, 0x03, 0x60, 0x01, 0x20, 0x01, 0x30, - 0xff, 0x1f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; - } - } - } - set itk_option(-openicon) openFolder - } else { - if {[lsearch [image names] $itk_option(-openicon)] == -1} { - error "bad openicon option \"$itk_option(-openicon)\":\ - should be an existing image" - } - } -} - -# ------------------------------------------------------------------ -# OPTION: -closedicon -# -# Specifies the closed icon image to be used in the hierarchy. -# Should one not be provided, then one will be generated, pixmap if -# possible, bitmap otherwise. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Hierarchy::closedicon { - if {$itk_option(-closedicon) == {}} { - if {[lsearch [image names] closedFolder] == -1} { - if {[lsearch [image types] pixmap] != -1} { - image create pixmap closedFolder -data { - /* XPM */ - static char *dir_closed[] = { - "16 16 3 1", - ". c grey85 m white g4 grey90", - "b c black m black g4 black", - "y c yellow m white g4 grey80", - "................", - "................", - "................", - "..bbbb..........", - ".byyyyb.........", - "bbbbbbbbbbbbbb..", - "byyyyyyyyyyyyb..", - "byyyyyyyyyyyyb..", - "byyyyyyyyyyyyb..", - "byyyyyyyyyyyyb..", - "byyyyyyyyyyyyb..", - "byyyyyyyyyyyyb..", - "bbbbbbbbbbbbbb..", - "................", - "................", - "................"}; - } - } else { - image create bitmap closedFolder -data { - #define closed_width 16 - #define closed_height 16 - static char closed_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x78, 0x00, 0x84, 0x00, - 0xfe, 0x7f, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, - 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, - 0xfe, 0x7f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; - } - } - } - set itk_option(-closedicon) closedFolder - } else { - if {[lsearch [image names] $itk_option(-closedicon)] == -1} { - error "bad closedicon option \"$itk_option(-closedicon)\":\ - should be an existing image" - } - } -} - -# ------------------------------------------------------------------ -# OPTION: -nodeicon -# -# Specifies the node icon image to be used in the hierarchy. Should -# one not be provided, then one will be generated, pixmap if -# possible, bitmap otherwise. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Hierarchy::nodeicon { - if {$itk_option(-nodeicon) == {}} { - if {[lsearch [image names] nodeFolder] == -1} { - if {[lsearch [image types] pixmap] != -1} { - image create pixmap nodeFolder -data { - /* XPM */ - static char *dir_node[] = { - "16 16 3 1", - ". c grey85 m white g4 grey90", - "b c black m black g4 black", - "y c yellow m white g4 grey80", - "................", - "................", - "................", - "...bbbbbbbbbbb..", - "..bybyyyyyyyyb..", - ".byybyyyyyyyyb..", - "byyybyyyyyyyyb..", - "bbbbbyyyyyyyyb..", - "byyyyyyyyyyyyb..", - "byyyyyyyyyyyyb..", - "byyyyyyyyyyyyb..", - "byyyyyyyyyyyyb..", - "bbbbbbbbbbbbbb..", - "................", - "................", - "................"}; - } - } else { - image create bitmap nodeFolder -data { - #define node_width 16 - #define node_height 16 - static char node_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0xe0, 0x7f, 0x50, 0x40, - 0x48, 0x40, 0x44, 0x40, 0x42, 0x40, 0x7e, 0x40, - 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, - 0xfe, 0x7f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; - } - } - } - set itk_option(-nodeicon) nodeFolder - } else { - if {[lsearch [image names] $itk_option(-nodeicon)] == -1} { - error "bad nodeicon option \"$itk_option(-nodeicon)\":\ - should be an existing image" - } - } -} - -# ------------------------------------------------------------------ -# OPTION: -width -# -# Specifies the width of the hierarchy widget as an entire unit. -# The value may be specified in any of the forms acceptable to -# Tk_GetPixels. Any additional space needed to display the other -# components such as labels, margins, and scrollbars force the text -# to be compressed. A value of zero along with the same value for -# the height causes the value given for the visibleitems option -# to be applied which administers geometry constraints in a different -# manner. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Hierarchy::width { - if {$itk_option(-width) != 0} { - set shell [lindex [grid info $itk_component(clipper)] 1] - - # - # Due to a bug in the tk4.2 grid, we have to check the - # propagation before setting it. Setting it to the same - # value it already is will cause it to toggle. - # - if {[grid propagate $shell]} { - grid propagate $shell no - } - - $itk_component(list) configure -width 1 - $shell configure \ - -width [winfo pixels $shell $itk_option(-width)] - } else { - configure -visibleitems $itk_option(-visibleitems) - } -} - -# ------------------------------------------------------------------ -# OPTION: -height -# -# Specifies the height of the hierarchy widget as an entire unit. -# The value may be specified in any of the forms acceptable to -# Tk_GetPixels. Any additional space needed to display the other -# components such as labels, margins, and scrollbars force the text -# to be compressed. A value of zero along with the same value for -# the width causes the value given for the visibleitems option -# to be applied which administers geometry constraints in a different -# manner. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Hierarchy::height { - if {$itk_option(-height) != 0} { - set shell [lindex [grid info $itk_component(clipper)] 1] - - # - # Due to a bug in the tk4.2 grid, we have to check the - # propagation before setting it. Setting it to the same - # value it already is will cause it to toggle. - # - if {[grid propagate $shell]} { - grid propagate $shell no - } - - $itk_component(list) configure -height 1 - $shell configure \ - -height [winfo pixels $shell $itk_option(-height)] - } else { - configure -visibleitems $itk_option(-visibleitems) - } -} - -# ------------------------------------------------------------------ -# OPTION: -visibleitems -# -# Specified the widthxheight in characters and lines for the text. -# This option is only administered if the width and height options -# are both set to zero, otherwise they take precedence. With the -# visibleitems option engaged, geometry constraints are maintained -# only on the text. The size of the other components such as -# labels, margins, and scroll bars, are additive and independent, -# effecting the overall size of the scrolled text. In contrast, -# should the width and height options have non zero values, they -# are applied to the scrolled text as a whole. The text is -# compressed or expanded to maintain the geometry constraints. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Hierarchy::visibleitems { - if {[regexp {^[0-9]+x[0-9]+$} $itk_option(-visibleitems)]} { - if {($itk_option(-width) == 0) && \ - ($itk_option(-height) == 0)} { - set chars [lindex [split $itk_option(-visibleitems) x] 0] - set lines [lindex [split $itk_option(-visibleitems) x] 1] - - set shell [lindex [grid info $itk_component(clipper)] 1] - - # - # Due to a bug in the tk4.2 grid, we have to check the - # propagation before setting it. Setting it to the same - # value it already is will cause it to toggle. - # - if {! [grid propagate $shell]} { - grid propagate $shell yes - } - - $itk_component(list) configure -width $chars -height $lines - } - - } else { - error "bad visibleitems option\ - \"$itk_option(-visibleitems)\": should be\ - widthxheight" - } -} - -# ------------------------------------------------------------------ -# OPTION: -textmenuloadcommand -# -# Dynamically loads the popup menu based on what was selected. -# -# Douglas R. Howard, Jr. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Hierarchy::textmenuloadcommand {} - -# ------------------------------------------------------------------ -# OPTION: -imagemenuloadcommand -# -# Dynamically loads the popup menu based on what was selected. -# -# Douglas R. Howard, Jr. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Hierarchy::imagemenuloadcommand {} - - -# ------------------------------------------------------------------ -# PUBLIC METHODS -# ------------------------------------------------------------------ - -# ---------------------------------------------------------------------- -# PUBLIC METHOD: clear -# -# Removes all items from the display including all tags and icons. -# The display will remain empty until the -filter or -querycommand -# options are set. -# ---------------------------------------------------------------------- -itcl::body iwidgets::Hierarchy::clear {} { - $itk_component(list) configure -state normal -cursor watch - $itk_component(list) delete 1.0 end - $itk_component(list) configure -state disabled -cursor $itk_option(-cursor) - - # Clear the tags - eval $itk_component(list) tag delete [$itk_component(list) tag names] - - catch {unset _nodes} - catch {unset _text} - catch {unset _tags} - catch {unset _icons} - catch {unset _states} - catch {unset _images} - catch {unset _indents} - catch {unset _marked} - catch {unset _selected} - set _markers "" - set _posted "" - set _ucounter 0 - set _hcounter 0 - - foreach mark [$itk_component(list) mark names] { - $itk_component(list) mark unset $mark - } - - return -} - -# ---------------------------------------------------------------------- -# PUBLIC METHOD: selection option ?uid uid...? -# -# Handles all operations controlling selections in the hierarchy. -# Selections may be cleared, added, removed, or queried. The add and -# remove options accept a series of unique ids. -# ---------------------------------------------------------------------- -itcl::body iwidgets::Hierarchy::selection {op args} { - switch -- $op { - clear { - $itk_component(list) tag remove hilite 1.0 end - catch {unset _selected} - return - } - add { - foreach node $args { - set _selected($node) 1 - catch { - $itk_component(list) tag add hilite \ - "$node.first" "$node.last" - } - } - } - remove { - foreach node $args { - catch { - unset _selected($node) - $itk_component(list) tag remove hilite \ - "$node.first" "$node.last" - } - } - } - get { - return [array names _selected] - } - default { - error "bad selection operation \"$op\":\ - should be add, remove, clear or get" - } - } -} - -# ---------------------------------------------------------------------- -# PUBLIC METHOD: mark option ?arg arg...? -# -# Handles all operations controlling marks in the hierarchy. Marks may -# be cleared, added, removed, or queried. The add and remove options -# accept a series of unique ids. -# ---------------------------------------------------------------------- -itcl::body iwidgets::Hierarchy::mark {op args} { - switch -- $op { - clear { - $itk_component(list) tag remove lowlite 1.0 end - catch {unset _marked} - return - } - add { - foreach node $args { - set _marked($node) 1 - catch { - $itk_component(list) tag add lowlite \ - "$node.first" "$node.last" - } - } - } - remove { - foreach node $args { - catch { - unset _marked($node) - $itk_component(list) tag remove lowlite \ - "$node.first" "$node.last" - } - } - } - get { - return [array names _marked] - } - default { - error "bad mark operation \"$op\":\ - should be add, remove, clear or get" - } - } -} - -# ---------------------------------------------------------------------- -# PUBLIC METHOD: current -# -# Returns the node that was most recently selected by the right mouse -# button when the item menu was posted. Usually used by the code -# in the item menu to figure out what item is being manipulated. -# ---------------------------------------------------------------------- -itcl::body iwidgets::Hierarchy::current {} { - return $_posted -} - -# ---------------------------------------------------------------------- -# PUBLIC METHOD: expand node -# -# Expands the hierarchy beneath the specified node. Since this can take -# a moment for large hierarchies, the cursor will be changed to a watch -# during the expansion. -# ---------------------------------------------------------------------- -itcl::body iwidgets::Hierarchy::expand {node} { - if {! [info exists _states($node)]} { - error "bad expand node argument: \"$node\", the node doesn't exist" - } - - if {!$_states($node) && \ - (([lsearch $_tags($node) branch] != -1) || \ - ([llength [_contents $node]] > 0))} { - $itk_component(list) configure -state normal -cursor watch - update - - # - # Get the indentation level for the node. - # - set indent $_indents($node) - - set _markers "" - $itk_component(list) mark set insert "$node:start" - _drawLevel $node $indent - - # - # Following the draw, all our markers need adjusting. - # - foreach {name index} $_markers { - $itk_component(list) mark set $name $index - } - - # - # Set the image to be the open icon, denote the new state, - # and set the cursor back to normal along with the state. - # - $_images($node) configure -image $itk_option(-openicon) - - set _states($node) 1 - - $itk_component(list) configure -state disabled \ - -cursor $itk_option(-cursor) - } -} - -# ---------------------------------------------------------------------- -# PUBLIC METHOD: collapse node -# -# Collapses the hierarchy beneath the specified node. Since this can -# take a moment for large hierarchies, the cursor will be changed to a -# watch during the expansion. -# ---------------------------------------------------------------------- -itcl::body iwidgets::Hierarchy::collapse {node} { - if {! [info exists _states($node)]} { - error "bad collapse node argument: \"$node\", the node doesn't exist" - } - - if {[info exists _states($node)] && $_states($node) && \ - (([lsearch $_tags($node) branch] != -1) || \ - ([llength [_contents $node]] > 0))} { - $itk_component(list) configure -state normal -cursor watch - update - - _deselectSubNodes $node - - $itk_component(list) delete "$node:start" "$node:end" - - catch {$_images($node) configure -image $itk_option(-closedicon)} - - set _states($node) 0 - - $itk_component(list) configure -state disabled \ - -cursor $itk_option(-cursor) - } -} - -# ---------------------------------------------------------------------- -# PUBLIC METHOD: toggle node -# -# Toggles the hierarchy beneath the specified node. If the hierarchy -# is currently expanded, then it is collapsed, and vice-versa. -# ---------------------------------------------------------------------- -itcl::body iwidgets::Hierarchy::toggle {node} { - if {! [info exists _states($node)]} { - error "bad toggle node argument: \"$node\", the node doesn't exist" - } - - if {$_states($node)} { - collapse $node - } else { - expand $node - } -} - -# ---------------------------------------------------------------------- -# PUBLIC METHOD: prune node -# -# Removes a particular node from the hierarchy. -# ---------------------------------------------------------------------- -itcl::body iwidgets::Hierarchy::prune {node} { - # - # While we're working, change the state and cursor so we can - # edit the text and give a busy visual clue. - # - $itk_component(list) configure -state normal -cursor watch - - # - # Recursively delete all the subnode information from our internal - # arrays and remove all the tags. - # - _deleteNodeInfo $node - - # - # If the mark $node:end exists then the node has decendents so - # so we'll remove from the mark $node:start to $node:end in order - # to delete all the subnodes below it in the text. - # - if {[lsearch [$itk_component(list) mark names] $node:end] != -1} { - $itk_component(list) delete $node:start $node:end - $itk_component(list) mark unset $node:end - } - - # - # Next we need to remove the node itself. Using the ranges for - # its tag we'll remove it from line start to the end plus one - # character which takes us to the start of the next node. - # - foreach {start end} [$itk_component(list) tag ranges $node] { - $itk_component(list) delete "$start linestart" "$end + 1 char" - } - - # - # Delete the tag for this node. - # - $itk_component(list) tag delete $node - - # - # The node must be removed from the list of subnodes for its parent. - # We don't really have a clean way to do upwards referencing, so - # the dirty way will have to do. We'll cycle through each node - # and if this node is in its list of subnodes, we'll remove it. - # - foreach uid [array names _nodes] { - if {[set index [lsearch $_nodes($uid) $node]] != -1} { - set _nodes($uid) [lreplace $_nodes($uid) $index $index] - } - } - - # - # We're done, so change the state and cursor back to their - # original values. - # - $itk_component(list) configure -state disabled -cursor $itk_option(-cursor) -} - -# ---------------------------------------------------------------------- -# PUBLIC METHOD: draw ?when? -# -# Performs a complete draw of the entire hierarchy. -# ---------------------------------------------------------------------- -itcl::body iwidgets::Hierarchy::draw {{when -now}} { - if {$when == "-eventually"} { - if {$_pending == ""} { - set _pending [after idle [itcl::code $this draw -now]] - } - return - } elseif {$when != "-now"} { - error "bad when option \"$when\": should be -eventually or -now" - } - $itk_component(list) configure -state normal -cursor watch - update - - $itk_component(list) delete 1.0 end - catch {unset _images} - set _markers "" - - _drawLevel "" "" - - foreach {name index} $_markers { - $itk_component(list) mark set $name $index - } - - $itk_component(list) configure -state disabled -cursor $itk_option(-cursor) - set _pending "" -} - -# ---------------------------------------------------------------------- -# PUBLIC METHOD: refresh node -# -# Performs a redraw of a specific node. If that node is currently -# not visible, then no action is taken. -# ---------------------------------------------------------------------- -itcl::body iwidgets::Hierarchy::refresh {node} { - if {! [info exists _nodes($node)]} { - error "bad refresh node argument: \"$node\", the node doesn't exist" - } - - - if {! $_states($node)} {return} - - foreach parent [_getHeritage $node] { - if {! $_states($parent)} {return} - } - - $itk_component(list) configure -state normal -cursor watch - $itk_component(list) delete $node:start $node:end - - set _markers "" - $itk_component(list) mark set insert "$node:start" - set indent $_indents($node) - - _drawLevel $node $indent - - foreach {name index} $_markers { - $itk_component(list) mark set $name $index - } - - $itk_component(list) configure -state disabled -cursor $itk_option(-cursor) -} - -# ------------------------------------------------------------------ -# THIN WRAPPED TEXT METHODS: -# -# The following methods are thin wraps of standard text methods. -# Consult the Tk text man pages for functionallity and argument -# documentation. -# ------------------------------------------------------------------ - -# ------------------------------------------------------------------ -# PUBLIC METHOD: bbox index -# -# Returns four element list describing the bounding box for the list -# item at index -# ------------------------------------------------------------------ -itcl::body iwidgets::Hierarchy::bbox {index} { - return [$itk_component(list) bbox $index] -} - -# ------------------------------------------------------------------ -# PUBLIC METHOD compare index1 op index2 -# -# Compare indices according to relational operator. -# ------------------------------------------------------------------ -itcl::body iwidgets::Hierarchy::compare {index1 op index2} { - return [$itk_component(list) compare $index1 $op $index2] -} - -# ------------------------------------------------------------------ -# PUBLIC METHOD delete first ?last? -# -# Delete a range of characters from the text. -# ------------------------------------------------------------------ -itcl::body iwidgets::Hierarchy::delete {first {last {}}} { - $itk_component(list) configure -state normal -cursor watch - $itk_component(list) delete $first $last - $itk_component(list) configure -state disabled -cursor $itk_option(-cursor) -} - -# ------------------------------------------------------------------ -# PUBLIC METHOD dump ?switches? index1 ?index2? -# -# Returns information about the contents of the text widget from -# index1 to index2. -# ------------------------------------------------------------------ -itcl::body iwidgets::Hierarchy::dump {args} { - return [eval $itk_component(list) dump $args] -} - -# ------------------------------------------------------------------ -# PUBLIC METHOD dlineinfo index -# -# Returns a five element list describing the area occupied by the -# display line containing index. -# ------------------------------------------------------------------ -itcl::body iwidgets::Hierarchy::dlineinfo {index} { - return [$itk_component(list) dlineinfo $index] -} - -# ------------------------------------------------------------------ -# PUBLIC METHOD get index1 ?index2? -# -# Return text from start index to end index. -# ------------------------------------------------------------------ -itcl::body iwidgets::Hierarchy::get {index1 {index2 {}}} { - return [$itk_component(list) get $index1 $index2] -} - -# ------------------------------------------------------------------ -# PUBLIC METHOD index index -# -# Return position corresponding to index. -# ------------------------------------------------------------------ -itcl::body iwidgets::Hierarchy::index {index} { - return [$itk_component(list) index $index] -} - -# ------------------------------------------------------------------ -# PUBLIC METHOD insert index chars ?tagList? -# -# Insert text at index. -# ------------------------------------------------------------------ -itcl::body iwidgets::Hierarchy::insert {args} { - $itk_component(list) configure -state normal -cursor watch - eval $itk_component(list) insert $args - $itk_component(list) configure -state disabled -cursor $itk_option(-cursor) -} - -# ------------------------------------------------------------------ -# PUBLIC METHOD scan option args -# -# Implements scanning on texts. -# ------------------------------------------------------------------ -itcl::body iwidgets::Hierarchy::scan {option args} { - eval $itk_component(list) scan $option $args -} - -# ------------------------------------------------------------------ -# PUBLIC METHOD search ?switches? pattern index ?varName? -# -# Searches the text for characters matching a pattern. -# ------------------------------------------------------------------ -itcl::body iwidgets::Hierarchy::search {args} { - return [eval $itk_component(list) search $args] -} - -# ------------------------------------------------------------------ -# PUBLIC METHOD see index -# -# Adjusts the view in the window so the character at index is -# visible. -# ------------------------------------------------------------------ -itcl::body iwidgets::Hierarchy::see {index} { - $itk_component(list) see $index -} - -# ------------------------------------------------------------------ -# PUBLIC METHOD tag option ?arg arg ...? -# -# Manipulate tags dependent on options. -# ------------------------------------------------------------------ -itcl::body iwidgets::Hierarchy::tag {op args} { - return [eval $itk_component(list) tag $op $args] -} - -# ------------------------------------------------------------------ -# PUBLIC METHOD window option ?arg arg ...? -# -# Manipulate embedded windows. -# ------------------------------------------------------------------ -itcl::body iwidgets::Hierarchy::window {option args} { - return [eval $itk_component(list) window $option $args] -} - -# ---------------------------------------------------------------------- -# PUBLIC METHOD: xview args -# -# Thin wrap of the text widget's xview command. -# ---------------------------------------------------------------------- -itcl::body iwidgets::Hierarchy::xview {args} { - return [eval itk_component(list) xview $args] -} - -# ---------------------------------------------------------------------- -# PUBLIC METHOD: yview args -# -# Thin wrap of the text widget's yview command. -# ---------------------------------------------------------------------- -itcl::body iwidgets::Hierarchy::yview {args} { - return [eval $itk_component(list) yview $args] -} - -# ---------------------------------------------------------------------- -# PUBLIC METHOD: expanded node -# -# Tells if a node is expanded or collapsed -# -# Douglas R. Howard, Jr. -# ---------------------------------------------------------------------- -itcl::body iwidgets::Hierarchy::expanded {node} { - if {! [info exists _states($node)]} { - error "bad collapse node argument: \"$node\", the node doesn't exist" - } - - return $_states($node) -} - -# ---------------------------------------------------------------------- -# PUBLIC METHOD: expState -# -# Returns a list of all expanded nodes -# -# Douglas R. Howard, Jr. -# ---------------------------------------------------------------------- -itcl::body iwidgets::Hierarchy::expState {} { - set nodes [_contents ""] - set open "" - set i 0 - while {1} { - if {[info exists _states([lindex $nodes $i])] && - $_states([lindex $nodes $i])} { - lappend open [lindex $nodes $i] - foreach child [_contents [lindex $nodes $i]] { - lappend nodes $child - } - } - incr i - if {$i >= [llength $nodes]} {break} - } - - return $open -} - -# ------------------------------------------------------------------ -# PROTECTED METHODS -# ------------------------------------------------------------------ - -# ---------------------------------------------------------------------- -# PROTECTED METHOD: _drawLevel node indent -# -# Used internally by draw to draw one level of the hierarchy. -# Draws all of the nodes under node, using the indent string to -# indent nodes. -# ---------------------------------------------------------------------- -itcl::body iwidgets::Hierarchy::_drawLevel {node indent} { - lappend _markers "$node:start" [$itk_component(list) index insert] - set bg [$itk_component(list) cget -background] - - # - # Obtain the list of subnodes for this node and cycle through - # each one displaying it in the hierarchy. - # - foreach child [_contents $node] { - set _images($child) "$itk_component(list).hicon[incr _hcounter]" - - if {![info exists _states($child)]} { - set _states($child) $itk_option(-expanded) - } - - # - # Check the user tags to see if they have been kind enough - # to tell us ahead of time what type of node we are dealing - # with branch or leaf. If they neglected to do so, then - # get the contents of the child node to see if it has children - # itself. - # - set display 0 - - if {[lsearch $_tags($child) leaf] != -1} { - set type leaf - } elseif {[lsearch $_tags($child) branch] != -1} { - set type branch - } else { - if {[llength [_contents $child]] == 0} { - set type leaf - } else { - set type branch - } - } - - # - # Now that we know the type of node, branch or leaf, we know - # the type of icon to use. - # - if {$type == "leaf"} { - set icon $itk_option(-nodeicon) - eval $_filterCode - } else { - if {$_states($child)} { - set icon $itk_option(-openicon) - } else { - set icon $itk_option(-closedicon) - } - set display 1 - } - - # - # If display is set then we're going to be drawing this node. - # Save off the indentation level for this node and do the indent. - # - if {$display} { - set _indents($child) "$indent\t" - $itk_component(list) insert insert $indent - - # - # Add the branch or leaf icon and setup a binding to toggle - # its expanded/collapsed state. - # - label $_images($child) -image $icon -background $bg - # DRH - enhanced and added features that handle image clicking, - # double clicking, and right clicking behavior - bind $_images($child) \ - "[itcl::code $this toggle $child]; [itcl::code $this _imageSelect $child]" - bind $_images($child) [itcl::code $this _imageDblClick $child] - bind $_images($child) \ - [itcl::code $this _imagePost $child $_images($child) $type %x %y] - $itk_component(list) window create insert -window $_images($child) - - # - # If any user icons exist then draw them as well. The little - # regexp is just to check and see if they've passed in a - # command which needs to be evaluated as opposed to just - # a variable. Also, attach a binding to call them if their - # icon is selected. - # - if {[info exists _icons($child)]} { - foreach image $_icons($child) { - set wid "$itk_component(list).uicon[incr _ucounter]" - - if {[regexp {\[.*\]} $image]} { - eval label $wid -image $image -background $bg - } else { - label $wid -image $image -background $bg - } - - # DRH - this will bind events to the icons to allow - # clicking, double clicking, and right clicking actions. - bind $wid \ - [itcl::code $this _iconSelect $child $image] - bind $wid \ - [itcl::code $this _iconDblSelect $child $image] - bind $wid \ - [itcl::code $this _imagePost $child $wid $type %x %y] - $itk_component(list) window create insert -window $wid - } - } - - # - # Create the list of tags to be applied to the text. Start - # out with a tag of "info" and append "hilite" if the node - # is currently selected, finally add the tags given by the - # user. - # - set texttags [list "info" $child] - - if {[info exists _selected($child)]} { - lappend texttags hilite - } - - # The following conditional added for SF ticket #600941. - if {[info exists _marked($child)]} { - lappend texttags lowlite - } - - foreach tag $_tags($child) { - lappend texttags $tag - } - - # - # Insert the text for the node along with the tags and - # append to the markers the start of this node. The text - # has been broken at newlines into a list. We'll make sure - # that each line is at the same indentation position. - # - set firstline 1 - foreach line $_text($child) { - if {$firstline} { - $itk_component(list) insert insert " " - } else { - $itk_component(list) insert insert "$indent\t" - } - - $itk_component(list) insert insert $line $texttags "\n" - set firstline 0 - } - - $itk_component(list) tag raise $child - lappend _markers "$child:start" [$itk_component(list) index insert] - - # - # If the state of the node is open, proceed to draw the next - # node below it in the hierarchy. - # - if {$_states($child)} { - _drawLevel $child "$indent\t" - } - } - } - - lappend _markers "$node:end" [$itk_component(list) index insert] -} - -# ---------------------------------------------------------------------- -# PROTECTED METHOD: _contents uid -# -# Used internally to get the contents of a particular node. If this -# is the first time the node has been seen or the -alwaysquery -# option is set, the -querycommand code is executed to query the node -# list, and the list is stored until the next time it is needed. -# -# The querycommand may return not only the list of subnodes for the -# node but additional information on the tags and icons to be used. -# The return value must be parsed based on the number of elements in -# the list where the format is a list of lists: -# -# {{uid [text [tags [icons]]]} {uid [text [tags [icons]]]} ...} -# ---------------------------------------------------------------------- -itcl::body iwidgets::Hierarchy::_contents {uid} { - if {$itk_option(-alwaysquery)} { - } else { - if {[info exists _nodes($uid)]} { - return $_nodes($uid) - } - } - - # - # Substitute any %n's for the node name whose children we're - # interested in obtaining. - # - set cmd $itk_option(-querycommand) - regsub -all {%n} $cmd [list $uid] cmd - - set nodeinfolist [uplevel \#0 $cmd] - - # - # Cycle through the node information returned by the query - # command determining if additional information such as text, - # user tags, or user icons have been provided. For text, - # break it into a list at any newline characters. - # - set _nodes($uid) {} - - foreach nodeinfo $nodeinfolist { - set subnodeuid [lindex $nodeinfo 0] - lappend _nodes($uid) $subnodeuid - - set llen [llength $nodeinfo] - - if {$llen == 0 || $llen > 4} { - error "invalid number of elements returned by query\ - command for node: \"$uid\",\ - should be uid \[text \[tags \[icons\]\]\]" - } - - if {$llen == 1} { - set _text($subnodeuid) [split $subnodeuid \n] - } - if {$llen > 1} { - set _text($subnodeuid) [split [lindex $nodeinfo 1] \n] - } - if {$llen > 2} { - set _tags($subnodeuid) [lindex $nodeinfo 2] - } else { - set _tags($subnodeuid) unknown - } - if {$llen > 3} { - set _icons($subnodeuid) [lindex $nodeinfo 3] - } - } - - # - # Return the list of nodes. - # - return $_nodes($uid) -} - -# ---------------------------------------------------------------------- -# PROTECTED METHOD: _post x y -# -# Used internally to post the popup menu at the coordinate (x,y) -# relative to the widget. If (x,y) is on an item, then the itemMenu -# component is posted. Otherwise, the bgMenu is posted. -# ---------------------------------------------------------------------- -itcl::body iwidgets::Hierarchy::_post {x y} { - set rx [expr {[winfo rootx $itk_component(list)]+$x}] - set ry [expr {[winfo rooty $itk_component(list)]+$y}] - - set index [$itk_component(list) index @$x,$y] - - # - # The posted variable will hold the list of tags which exist at - # this x,y position that will be passed back to the user. They - # don't need to know about our internal tags, info, hilite, and - # lowlite, so remove them from the list. - # - set _posted {} - - foreach tag [$itk_component(list) tag names $index] { - if {![_isInternalTag $tag]} { - lappend _posted $tag - } - } - - # - # If we have tags then do the popup at this position. - # - if {$_posted != {}} { - # DRH - here is where the user's function for dynamic popup - # menu loading is done, if the user has specified to do so with the - # "-textmenuloadcommand" - if {$itk_option(-textmenuloadcommand) != {}} { - eval $itk_option(-textmenuloadcommand) - } - tk_popup $itk_component(itemMenu) $rx $ry - } else { - tk_popup $itk_component(bgMenu) $rx $ry - } -} - -# ---------------------------------------------------------------------- -# PROTECTED METHOD: _imagePost node image type x y -# -# Used internally to post the popup menu at the coordinate (x,y) -# relative to the widget. If (x,y) is on an image, then the itemMenu -# component is posted. -# -# Douglas R. Howard, Jr. -# ---------------------------------------------------------------------- -itcl::body iwidgets::Hierarchy::_imagePost {node image type x y} { - set rx [expr {[winfo rootx $image]+$x}] - set ry [expr {[winfo rooty $image]+$y}] - - # - # The posted variable will hold the list of tags which exist at - # this x,y position that will be passed back to the user. They - # don't need to know about our internal tags, info, hilite, and - # lowlite, so remove them from the list. - # - set _posted {} - - lappend _posted $node $type - - # - # If we have tags then do the popup at this position. - # - if {$itk_option(-imagemenuloadcommand) != {}} { - eval $itk_option(-imagemenuloadcommand) - } - tk_popup $itk_component(itemMenu) $rx $ry -} - -# ---------------------------------------------------------------------- -# PROTECTED METHOD: _select x y -# -# Used internally to select an item at the coordinate (x,y) relative -# to the widget. The command associated with the -selectcommand -# option is execute following % character substitutions. If %n -# appears in the command, the selected node is substituted. If %s -# appears, a boolean value representing the current selection state -# will be substituted. -# ---------------------------------------------------------------------- -itcl::body iwidgets::Hierarchy::_select {x y} { - if {$itk_option(-selectcommand) != {}} { - if {[set seltags [$itk_component(list) tag names @$x,$y]] != {}} { - foreach tag $seltags { - if {![_isInternalTag $tag]} { - lappend node $tag - } - } - - if {[lsearch $seltags "hilite"] == -1} { - set selectstatus 0 - } else { - set selectstatus 1 - } - - set cmd $itk_option(-selectcommand) - regsub -all {%n} $cmd [lindex $node end] cmd - regsub -all {%s} $cmd [list $selectstatus] cmd - - uplevel #0 $cmd - } - } - - return -} - -# ---------------------------------------------------------------------- -# PROTECTED METHOD: _double x y -# -# Used internally to double click an item at the coordinate (x,y) relative -# to the widget. The command associated with the -dblclickcommand -# option is execute following % character substitutions. If %n -# appears in the command, the selected node is substituted. If %s -# appears, a boolean value representing the current selection state -# will be substituted. -# -# Douglas R. Howard, Jr. -# ---------------------------------------------------------------------- -itcl::body iwidgets::Hierarchy::_double {x y} { - if {$itk_option(-dblclickcommand) != {}} { - if {[set seltags [$itk_component(list) tag names @$x,$y]] != {}} { - foreach tag $seltags { - if {![_isInternalTag $tag]} { - lappend node $tag - } - } - - if {[lsearch $seltags "hilite"] == -1} { - set selectstatus 0 - } else { - set selectstatus 1 - } - - set cmd $itk_option(-dblclickcommand) - regsub -all {%n} $cmd [list $node] cmd - regsub -all {%s} $cmd [list $selectstatus] cmd - - uplevel #0 $cmd - } - } - - return -} - -# ---------------------------------------------------------------------- -# PROTECTED METHOD: _iconSelect node icon -# -# Used internally to upon selection of user icons. The -iconcommand -# is executed after substitution of the node for %n and icon for %i. -# -# Douglas R. Howard, Jr. -# ---------------------------------------------------------------------- -itcl::body iwidgets::Hierarchy::_iconSelect {node icon} { - set cmd $itk_option(-iconcommand) - regsub -all {%n} $cmd [list $node] cmd - regsub -all {%i} $cmd [list $icon] cmd - - uplevel \#0 $cmd - - return {} -} - -# ---------------------------------------------------------------------- -# PROTECTED METHOD: _iconDblSelect node icon -# -# Used internally to upon double selection of user icons. The -# -icondblcommand is executed after substitution of the node for %n and -# icon for %i. -# -# Douglas R. Howard, Jr. -# ---------------------------------------------------------------------- -itcl::body iwidgets::Hierarchy::_iconDblSelect {node icon} { - if {$itk_option(-icondblcommand) != {}} { - set cmd $itk_option(-icondblcommand) - regsub -all {%n} $cmd [list $node] cmd - regsub -all {%i} $cmd [list $icon] cmd - - uplevel \#0 $cmd - } - return {} -} - -# ---------------------------------------------------------------------- -# PROTECTED METHOD: _imageSelect node icon -# -# Used internally to upon selection of user icons. The -imagecommand -# is executed after substitution of the node for %n. -# -# Douglas R. Howard, Jr. -# ---------------------------------------------------------------------- -itcl::body iwidgets::Hierarchy::_imageSelect {node} { - if {$itk_option(-imagecommand) != {}} { - set cmd $itk_option(-imagecommand) - regsub -all {%n} $cmd [list $node] cmd - - uplevel \#0 $cmd - } - return {} -} - -# ---------------------------------------------------------------------- -# PROTECTED METHOD: _imageDblClick node -# -# Used internally to upon double selection of images. The -# -imagedblcommand is executed. -# -# Douglas R. Howard, Jr. -# ---------------------------------------------------------------------- -itcl::body iwidgets::Hierarchy::_imageDblClick {node} { - if {$itk_option(-imagedblcommand) != {}} { - set cmd $itk_option(-imagedblcommand) - regsub -all {%n} $cmd [list $node] cmd - - uplevel \#0 $cmd - } - return {} -} - -# ---------------------------------------------------------------------- -# PROTECTED METHOD: _deselectSubNodes uid -# -# Used internally to recursively deselect all the nodes beneath a -# particular node. -# ---------------------------------------------------------------------- -itcl::body iwidgets::Hierarchy::_deselectSubNodes {uid} { - foreach node $_nodes($uid) { - if {[array names _selected $node] != {}} { - unset _selected($node) - } - - if {[array names _nodes $node] != {}} { - _deselectSubNodes $node - } - } -} - -# ---------------------------------------------------------------------- -# PROTECTED METHOD: _deleteNodeInfo uid -# -# Used internally to recursively delete all the information about a -# node and its decendents. -# ---------------------------------------------------------------------- -itcl::body iwidgets::Hierarchy::_deleteNodeInfo {uid} { - # - # Recursively call ourseleves as we go down the hierarchy beneath - # this node. - # - if {[info exists _nodes($uid)]} { - foreach node $_nodes($uid) { - if {[array names _nodes $node] != {}} { - _deleteNodeInfo $node - } - } - } - - # - # Unset any entries in our arrays for the node. - # - catch {unset _nodes($uid)} - catch {unset _text($uid)} - catch {unset _tags($uid)} - catch {unset _icons($uid)} - catch {unset _states($uid)} - catch {unset _images($uid)} - catch {unset _indents($uid)} -} - -# ---------------------------------------------------------------------- -# PROTECTED METHOD: _getParent uid -# -# Used internally to determine the parent for a node. -# ---------------------------------------------------------------------- -itcl::body iwidgets::Hierarchy::_getParent {uid} { - foreach node [array names _nodes] { - if {[set index [lsearch $_nodes($node) $uid]] != -1} { - return $node - } - } -} - -# ---------------------------------------------------------------------- -# PROTECTED METHOD: _getHeritage uid -# -# Used internally to determine the list of parents for a node. -# ---------------------------------------------------------------------- -itcl::body iwidgets::Hierarchy::_getHeritage {uid} { - set parents {} - - if {[set parent [_getParent $uid]] != {}} { - lappend parents $parent - } - - return $parents -} - -# ---------------------------------------------------------------------- -# PROTECTED METHOD (could be proc?): _isInternalTag tag -# -# Used internally to tags not to used for user callback commands -# ---------------------------------------------------------------------- -itcl::body iwidgets::Hierarchy::_isInternalTag {tag} { - set ii [expr {[lsearch -exact {info hilite lowlite unknown} $tag] != -1}]; - return $ii; -} - -# ---------------------------------------------------------------------- -# PRIVATE METHOD: _configureTags -# -# This method added to fix SF ticket #596111. When the -querycommand -# is reset after initial construction, the text component loses its -# tag configuration. This method resets the hilite, lowlite, and info -# tags. csmith: 9/5/02 -# ---------------------------------------------------------------------- -itcl::body iwidgets::Hierarchy::_configureTags {} { - tag configure hilite -background $itk_option(-selectbackground) \ - -foreground $itk_option(-selectforeground) - tag configure lowlite -background $itk_option(-markbackground) \ - -foreground $itk_option(-markforeground) - tag configure info -font $itk_option(-font) -spacing1 6 -} diff --git a/iwidgets/library/hyperhelp.itk b/iwidgets/library/hyperhelp.itk deleted file mode 100644 index 6991eb1..0000000 --- a/iwidgets/library/hyperhelp.itk +++ /dev/null @@ -1,508 +0,0 @@ -# -# Hyperhelp -# ---------------------------------------------------------------------- -# Implements a help facility using html formatted hypertext files. -# -# ---------------------------------------------------------------------- -# AUTHOR: Kris Raney EMAIL: kraney@spd.dsccc.com -# -# @(#) $Id: hyperhelp.itk,v 1.5 2002/03/16 05:26:19 mgbacke Exp $ -# ---------------------------------------------------------------------- -# Copyright (c) 1996 DSC Technologies Corporation -# ====================================================================== -# Permission to use, copy, modify, distribute and license this software -# and its documentation for any purpose, and without fee or written -# agreement with DSC, is hereby granted, provided that the above copyright -# notice appears in all copies and that both the copyright notice and -# warranty disclaimer below appear in supporting documentation, and that -# the names of DSC Technologies Corporation or DSC Communications -# Corporation not be used in advertising or publicity pertaining to the -# software without specific, written prior permission. -# -# DSC DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING -# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, 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. IN NO EVENT SHALL -# DSC BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR -# ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, -# WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION, -# ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS -# SOFTWARE. -# ====================================================================== - -# -# Acknowledgements: -# -# Special thanks go to Sam Shen(SLShen@lbl.gov), as this code is based on his -# help.tcl code from tk inspect. - -# -# Default resources. -# -option add *Hyperhelp.width 575 widgetDefault -option add *Hyperhelp.height 450 widgetDefault -option add *Hyperhelp.modality none widgetDefault -option add *Hyperhelp.vscrollMode static widgetDefault -option add *Hyperhelp.hscrollMode static widgetDefault -option add *Hyperhelp.maxHistory 20 widgetDefault - -# -# Usual options. -# -itk::usual Hyperhelp { - keep -activebackground -activerelief -background -borderwidth -cursor \ - -foreground -highlightcolor -highlightthickness \ - -selectbackground -selectborderwidth -selectforeground \ - -textbackground -} - -# ------------------------------------------------------------------ -# HYPERHELP -# ------------------------------------------------------------------ -itcl::class iwidgets::Hyperhelp { - inherit iwidgets::Shell - - constructor {args} {} - - itk_option define -topics topics Topics {} - itk_option define -helpdir helpdir Directory . - itk_option define -title title Title "Help" - itk_option define -closecmd closeCmd CloseCmd {} - itk_option define -maxhistory maxHistory MaxHistory 20 - - public variable beforelink {} - public variable afterlink {} - - public method showtopic {topic} - public method followlink {link} - public method forward {} - public method back {} - public method updatefeedback {n} - - protected method _readtopic {file {anchorpoint {}}} - protected method _pageforward {} - protected method _pageback {} - protected method _lineforward {} - protected method _lineback {} - protected method _fill_go_menu {} - - protected variable _history {} ;# History list of viewed pages - protected variable _history_ndx -1 ;# current position in history list - protected variable _history_len 0 ;# length of history list - protected variable _histdir -1 ;# direction in history we just came - ;# from - protected variable _len 0 ;# length of text to be rendered - protected variable _file {} ;# current topic - - private variable _remaining 0 ;# remaining text to be rendered - private variable _rendering 0 ;# flag - in process of rendering -} - -# -# Provide a lowercased access method for the Scrolledlistbox class. -# -proc ::iwidgets::hyperhelp {pathName args} { - uplevel ::iwidgets::Hyperhelp $pathName $args -} - -# ------------------------------------------------------------------ -# CONSTRUCTOR -# ------------------------------------------------------------------ -itcl::body iwidgets::Hyperhelp::constructor {args} { - itk_option remove iwidgets::Shell::padx iwidgets::Shell::pady - - # - # Create a pulldown menu - # - itk_component add -private menubar { - frame $itk_interior.menu -relief raised -bd 2 - } { - keep -background -cursor - } - pack $itk_component(menubar) -side top -fill x - - itk_component add -private topicmb { - menubutton $itk_component(menubar).topicmb -text "Topics" \ - -menu $itk_component(menubar).topicmb.topicmenu \ - -underline 0 -padx 8 -pady 2 - } { - keep -background -cursor -font -foreground \ - -activebackground -activeforeground - } - pack $itk_component(topicmb) -side left - - itk_component add -private topicmenu { - menu $itk_component(topicmb).topicmenu -tearoff no - } { - keep -background -cursor -font -foreground \ - -activebackground -activeforeground - } - - itk_component add -private navmb { - menubutton $itk_component(menubar).navmb -text "Navigate" \ - -menu $itk_component(menubar).navmb.navmenu \ - -underline 0 -padx 8 -pady 2 - } { - keep -background -cursor -font -foreground \ - -activebackground -activeforeground - } - pack $itk_component(navmb) -side left - - itk_component add -private navmenu { - menu $itk_component(navmb).navmenu -tearoff no - } { - keep -background -cursor -font -foreground \ - -activebackground -activeforeground - } - set m $itk_component(navmenu) - $m add command -label "Forward" -underline 0 -state disabled \ - -command [itcl::code $this forward] -accelerator f - $m add command -label "Back" -underline 0 -state disabled \ - -command [itcl::code $this back] -accelerator b - $m add cascade -label "Go" -underline 0 -menu $m.go - - itk_component add -private navgo { - menu $itk_component(navmenu).go -postcommand [itcl::code $this _fill_go_menu] - } { - keep -background -cursor -font -foreground \ - -activebackground -activeforeground - } - - # - # Create a scrolledhtml object to display help pages - # - itk_component add scrtxt { - iwidgets::scrolledhtml $itk_interior.scrtxt \ - -linkcommand "$this followlink" -feedback "$this updatefeedback" - } { - keep -hscrollmode -vscrollmode -background -textbackground \ - -fontname -fontsize -fixedfont -link \ - -linkhighlight -borderwidth -cursor -sbwidth -scrollmargin \ - -width -height -foreground -highlightcolor -visibleitems \ - -highlightthickness -padx -pady -activerelief \ - -relief -selectbackground -selectborderwidth \ - -selectforeground -setgrid -wrap -unknownimage - } - pack $itk_component(scrtxt) -fill both -expand yes - - # - # Bind shortcut keys - # - bind $itk_component(hull) [itcl::code $this forward] - bind $itk_component(hull) [itcl::code $this back] - bind $itk_component(hull) [itcl::code $this forward] - bind $itk_component(hull) [itcl::code $this back] - bind $itk_component(hull) [itcl::code $this _pageforward] - bind $itk_component(hull) [itcl::code $this _pageforward] - bind $itk_component(hull) [itcl::code $this _pageback] - bind $itk_component(hull) [itcl::code $this _pageback] - bind $itk_component(hull) [itcl::code $this _pageback] - bind $itk_component(hull) [itcl::code $this _lineforward] - bind $itk_component(hull) [itcl::code $this _lineback] - - wm title $itk_component(hull) "Help" - - eval itk_initialize $args - if {[lsearch -exact $args -closecmd] == -1} { - configure -closecmd [itcl::code $this deactivate] - } -} - -# ------------------------------------------------------------------ -# OPTIONS -# ------------------------------------------------------------------ - -# ------------------------------------------------------------------ -# OPTION: -topics -# -# Specifies the topics to display on the menu. For each topic, there should -# be a file named /.html -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Hyperhelp::topics { - set m $itk_component(topicmenu) - $m delete 0 last - foreach topic $itk_option(-topics) { - if {[lindex $topic 1] == {} } { - $m add radiobutton -variable topic \ - -value $topic \ - -label $topic \ - -command [list $this showtopic $topic] - } else { - if {[string index [file dirname [lindex $topic 1]] 0] != "/" && \ - [string index [file dirname [lindex $topic 1]] 0] != "~"} { - set link $itk_option(-helpdir)/[lindex $topic 1] - } else { - set link [lindex $topic 1] - } - $m add radiobutton -variable topic \ - -value [lindex $topic 0] \ - -label [lindex $topic 0] \ - -command [list $this followlink $link] - } - } - $m add separator - $m add command -label "Close Help" -underline 0 \ - -command $itk_option(-closecmd) -} - -# ------------------------------------------------------------------ -# OPTION: -title -# -# Specify the window title. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Hyperhelp::title { - wm title $itk_component(hull) $itk_option(-title) -} - -# ------------------------------------------------------------------ -# OPTION: -helpdir -# -# Set location of help files -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Hyperhelp::helpdir { - if {[file pathtype $itk_option(-helpdir)] == "relative"} { - configure -helpdir [file join [pwd] $itk_option(-helpdir)] - } else { - set _history {} - set _history_len 0 - set _history_ndx -1 - $itk_component(navmenu) entryconfig 0 -state disabled - $itk_component(navmenu) entryconfig 1 -state disabled - configure -topics $itk_option(-topics) - } -} - -# ------------------------------------------------------------------ -# OPTION: -closecmd -# -# Specify the command to execute when close is selected from the menu -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Hyperhelp::closecmd { - $itk_component(topicmenu) entryconfigure last -command $itk_option(-closecmd) -} - -# ------------------------------------------------------------------ -# METHODS -# ------------------------------------------------------------------ - -# ------------------------------------------------------------------ -# METHOD: showtopic topic -# -# render text of help topic . The text is expected to be found in -# /.html -# ------------------------------------------------------------------ -itcl::body iwidgets::Hyperhelp::showtopic {topic} { - if ![regexp {(.*)#(.*)} $topic dummy topicname anchorpart] { - set topicname $topic - set anchorpart {} - } - if {$topicname == ""} { - set topicname $_file - set filepath $_file - } else { - set filepath $itk_option(-helpdir)/$topicname.html - } - if {[incr _history_ndx] < $itk_option(-maxhistory)} { - set _history [lrange $_history 0 [expr {$_history_ndx - 1}]] - set _history_len [expr {$_history_ndx + 1}] - } else { - incr _history_ndx -1 - set _history [lrange $_history 1 $_history_ndx] - set _history_len [expr {$_history_ndx + 1}] - } - lappend _history [list $topicname $filepath $anchorpart] - _readtopic $filepath $anchorpart -} - -# ------------------------------------------------------------------ -# METHOD: followlink link -# -# Callback for click on a link. Shows new topic. -# ------------------------------------------------------------------ -itcl::body iwidgets::Hyperhelp::followlink {link} { - if {[string compare $beforelink ""] != 0} { - eval $beforelink $link - } - if ![regexp {(.*)#(.*)} $link dummy filepart anchorpart] { - set filepart $link - set anchorpart {} - } - if {$filepart != "" && [string index [file dirname $filepart] 0] != "/" && \ - [string index [file dirname $filepart] 0] != "~"} { - set filepart [$itk_component(scrtxt) pwd]/$filepart - set hfile $filepart - } else { - set hfile $_file - } - incr _history_ndx - set _history [lrange $_history 0 [expr {$_history_ndx - 1}]] - set _history_len [expr {$_history_ndx + 1}] - lappend _history [list [file rootname [file tail $hfile]] $hfile $anchorpart] - set ret [_readtopic $filepart $anchorpart] - if {[string compare $afterlink ""] != 0} { - eval $afterlink $link - } - return $ret -} - -# ------------------------------------------------------------------ -# METHOD: forward -# -# Show topic one forward in history list -# ------------------------------------------------------------------ -itcl::body iwidgets::Hyperhelp::forward {} { - if {$_rendering || ($_history_ndx+1) >= $_history_len} return - incr _history_ndx - eval _readtopic [lrange [lindex $_history $_history_ndx] 1 end] -} - -# ------------------------------------------------------------------ -# METHOD: back -# -# Show topic one back in history list -# ------------------------------------------------------------------ -itcl::body iwidgets::Hyperhelp::back {} { - if {$_rendering || $_history_ndx <= 0} return - incr _history_ndx -1 - set _histdir 1 - eval _readtopic [lrange [lindex $_history $_history_ndx] 1 end] -} - -# ------------------------------------------------------------------ -# METHOD: updatefeedback remaining -# -# Callback from text to update feedback widget -# ------------------------------------------------------------------ -itcl::body iwidgets::Hyperhelp::updatefeedback {n} { - if {($_remaining - $n) > .1*$_len} { - [$itk_interior.feedbackshell childsite].helpfeedback step [expr {$_remaining - $n}] - update idletasks - set _remaining $n - } -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _readtopic -# -# Read in file, render it in text area, and jump to anchorpoint -# ------------------------------------------------------------------ -itcl::body iwidgets::Hyperhelp::_readtopic {file {anchorpoint {}}} { - if {$file != ""} { - if {[string compare $file $_file] != 0} { - if {[catch {set f [open $file r]} err]} { - incr _history_ndx $_histdir - set _history_len [expr {$_history_ndx + 1}] - set _histdir -1 - set m $itk_component(navmenu) - if {($_history_ndx+1) < $_history_len} { - $m entryconfig 0 -state normal - } else { - $m entryconfig 0 -state disabled - } - if {$_history_ndx > 0} { - $m entryconfig 1 -state normal - } else { - $m entryconfig 1 -state disabled - } - return - } - set _file $file - set txt [read $f] - iwidgets::shell $itk_interior.feedbackshell -title \ - "Rendering HTML" -padx 1 -pady 1 - iwidgets::Feedback [$itk_interior.feedbackshell \ - childsite].helpfeedback \ - -steps [set _len [string length $txt]] \ - -labeltext "Rendering HTML" -labelpos n - pack [$itk_interior.feedbackshell childsite].helpfeedback - $itk_interior.feedbackshell center $itk_interior - $itk_interior.feedbackshell activate - set _remaining $_len - set _rendering 1 - if {[catch {$itk_component(scrtxt) render $txt [file dirname \ - $file]} err]} { - if [regexp "" $err] { - $itk_component(scrtxt) render "$err" - } else { - $itk_component(scrtxt) render "
$err
" - } - } - wm title $itk_component(hull) "Help: $file" - itcl::delete object [$itk_interior.feedbackshell \ - childsite].helpfeedback - itcl::delete object $itk_interior.feedbackshell - set _rendering 0 - } - } - set m $itk_component(navmenu) - if {($_history_ndx+1) < $_history_len} { - $m entryconfig 0 -state normal - } else { - $m entryconfig 0 -state disabled - } - if {$_history_ndx > 0} { - $m entryconfig 1 -state normal - } else { - $m entryconfig 1 -state disabled - } - if {$anchorpoint != {}} { - $itk_component(scrtxt) import -link #$anchorpoint - } else { - $itk_component(scrtxt) import -link # - } - set _histdir -1 -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _fill_go_menu -# -# update go submenu with current history -# ------------------------------------------------------------------ -itcl::body iwidgets::Hyperhelp::_fill_go_menu {} { - set m $itk_component(navgo) - catch {$m delete 0 last} - for {set i [expr {$_history_len - 1}]} {$i >= 0} {incr i -1} { - set topic [lindex [lindex $_history $i] 0] - set filepath [lindex [lindex $_history $i] 1] - set anchor [lindex [lindex $_history $i] 2] - $m add command -label $topic \ - -command [list $this followlink $filepath#$anchor] - } -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _pageforward -# -# Callback for page forward shortcut key -# ------------------------------------------------------------------ -itcl::body iwidgets::Hyperhelp::_pageforward {} { - $itk_component(scrtxt) yview scroll 1 pages -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _pageback -# -# Callback for page back shortcut key -# ------------------------------------------------------------------ -itcl::body iwidgets::Hyperhelp::_pageback {} { - $itk_component(scrtxt) yview scroll -1 pages -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _lineforward -# -# Callback for line forward shortcut key -# ------------------------------------------------------------------ -itcl::body iwidgets::Hyperhelp::_lineforward {} { - $itk_component(scrtxt) yview scroll 1 units -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _lineback -# -# Callback for line back shortcut key -# ------------------------------------------------------------------ -itcl::body iwidgets::Hyperhelp::_lineback {} { - $itk_component(scrtxt) yview scroll -1 units -} diff --git a/iwidgets/library/labeledframe.itk b/iwidgets/library/labeledframe.itk deleted file mode 100644 index 0f91223..0000000 --- a/iwidgets/library/labeledframe.itk +++ /dev/null @@ -1,497 +0,0 @@ -# -# Labeledframe -# ---------------------------------------------------------------------- -# Implements a hull frame with a grooved relief, a label, and a -# frame childsite. -# -# The frame childsite can be filled with any widget via a derived class -# or though the use of the childsite method. This class was designed -# to be a general purpose base class for supporting the combination of -# a labeled frame and a childsite. The options include the ability to -# position the label at configurable locations within the grooved relief -# of the hull frame, and control the display of the label. -# -# To following demonstrates the different values which the "-labelpos" -# option may be set to and the resulting layout of the label when -# one executes the following command with "-labeltext" set to "LABEL": -# -# example: -# labeledframe .w -labeltext LABEL -labelpos -# -# ne n nw se s sw -# -# *LABEL**** **LABEL** ****LABEL* ********** ********* ********** -# * * * * * * * * * * * * -# * * * * * * * * * * * * -# * * * * * * * * * * * * -# ********** ********* ********** *LABEL**** **LABEL** ****LABEL* -# -# en e es wn s ws -# -# ********** ********* ********* ********* ********* ********** -# * * * * * * * * * * * * -# L * * * * * * L * * * * -# A * L * * * * A * L * L -# B * A * L * * B * A * A -# E * B * A * * E * B * B -# L * E * B * * L * E * E -# * * L * E * * * * L * L -# * * * * L * * * * * * * -# ********** ********** ********* ********** ********* ********** -# -# ---------------------------------------------------------------------- -# AUTHOR: John A. Tucker EMAIL: jatucker@spd.dsccc.com -# -# ====================================================================== -# Copyright (c) 1997 DSC Technologies Corporation -# ====================================================================== -# Permission to use, copy, modify, distribute and license this software -# and its documentation for any purpose, and without fee or written -# agreement with DSC, is hereby granted, provided that the above copyright -# notice appears in all copies and that both the copyright notice and -# warranty disclaimer below appear in supporting documentation, and that -# the names of DSC Technologies Corporation or DSC Communications -# Corporation not be used in advertising or publicity pertaining to the -# software without specific, written prior permission. -# -# DSC DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING -# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, 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. IN NO EVENT SHALL -# DSC BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR -# ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, -# WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION, -# ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS -# SOFTWARE. -# ====================================================================== - -# -# Default resources. -# -option add *Labeledframe.labelMargin 10 widgetDefault -option add *Labeledframe.labelFont \ - "-Adobe-Helvetica-Bold-R-Normal--*-120-*-*-*-*-*-*" widgetDefault -option add *Labeledframe.labelPos n widgetDefault -option add *Labeledframe.borderWidth 2 widgetDefault -option add *Labeledframe.relief groove widgetDefault - - -# -# Usual options. -# -itk::usual Labeledframe { - keep -background -cursor -labelfont -foreground -} - -itcl::class iwidgets::Labeledframe { - - inherit itk::Archetype - - itk_option define -ipadx iPadX IPad 0 - itk_option define -ipady iPadY IPad 0 - - itk_option define -labelmargin labelMargin LabelMargin 10 - itk_option define -labelpos labelPos LabelPos n - - constructor {args} {} - destructor {} - - # - # Public methods - # - public method childsite {} - - # - # Protected methods - # - protected { - method _positionLabel {{when later}} - method _collapseMargin {} - method _setMarginThickness {value} - method smt {value} { _setMarginThickness $value } - } - - # - # Private methods/data - # - private { - proc _initTable {} - - variable _reposition "" ;# non-null => _positionLabel pending - variable itk_hull "" - - common _LAYOUT_TABLE - } -} - -# -# Provide a lowercased access method for the Labeledframe class. -# -proc ::iwidgets::labeledframe {pathName args} { - uplevel ::iwidgets::Labeledframe $pathName $args -} - -# ----------------------------------------------------------------------------- -# CONSTRUCTOR -# ----------------------------------------------------------------------------- -itcl::body iwidgets::Labeledframe::constructor { args } { - # - # Create a window with the same name as this object - # - set itk_hull [namespace tail $this] - set itk_interior $itk_hull - - itk_component add hull { - frame $itk_hull \ - -relief groove \ - -class [namespace tail [info class]] - } { - keep -background -cursor -relief -borderwidth - rename -highlightbackground -background background Background - rename -highlightcolor -background background Background - } - bind itk-delete-$itk_hull "itcl::delete object $this" - - set tags [bindtags $itk_hull] - bindtags $itk_hull [linsert $tags 0 itk-delete-$itk_hull] - - # - # Create the childsite frame window - # _______ - # |_____| - # |_|X|_| - # |_____| - # - itk_component add childsite { - frame $itk_interior.childsite -highlightthickness 0 -bd 0 - } - - # - # Create the label to be positioned within the grooved relief - # of the hull frame. - # - itk_component add label { - label $itk_interior.label -highlightthickness 0 -bd 0 - } { - usual - rename -bitmap -labelbitmap labelBitmap Bitmap - rename -font -labelfont labelFont Font - rename -image -labelimage labelImage Image - rename -text -labeltext labelText Text - rename -textvariable -labelvariable labelVariable Variable - ignore -highlightthickness -highlightcolor - } - - grid $itk_component(childsite) -row 1 -column 1 -sticky nsew - grid columnconfigure $itk_interior 1 -weight 1 - grid rowconfigure $itk_interior 1 -weight 1 - - bind $itk_component(label) +[itcl::code $this _positionLabel] - - # - # Initialize the class array of layout configuration options. Since - # this is a one time only thing. - # - _initTable - - eval itk_initialize $args - - # - # When idle, position the label. - # - _positionLabel -} - -# ----------------------------------------------------------------------------- -# DESTRUCTOR -# ----------------------------------------------------------------------------- -itcl::body iwidgets::Labeledframe::destructor {} { - - if {$_reposition != ""} { - after cancel $_reposition - } - - if {[winfo exists $itk_hull]} { - set tags [bindtags $itk_hull] - set i [lsearch $tags itk-delete-$itk_hull] - if {$i >= 0} { - bindtags $itk_hull [lreplace $tags $i $i] - } - destroy $itk_hull - } -} - -# ----------------------------------------------------------------------------- -# OPTIONS -# ----------------------------------------------------------------------------- - -# ------------------------------------------------------------------ -# OPTION: -ipadx -# -# Specifies the width of the horizontal gap from the border to the -# the child site. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Labeledframe::ipadx { - grid configure $itk_component(childsite) -padx $itk_option(-ipadx) - _positionLabel -} - -# ------------------------------------------------------------------ -# OPTION: -ipady -# -# Specifies the width of the vertical gap from the border to the -# the child site. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Labeledframe::ipady { - grid configure $itk_component(childsite) -pady $itk_option(-ipady) - _positionLabel -} - -# ----------------------------------------------------------------------------- -# OPTION: -labelmargin -# -# Set the margin of the most adjacent side of the label to the hull -# relief. -# ---------------------------------------------------------------------------- -itcl::configbody iwidgets::Labeledframe::labelmargin { - _positionLabel -} - -# ----------------------------------------------------------------------------- -# OPTION: -labelpos -# -# Set the position of the label within the relief of the hull frame -# widget. -# ---------------------------------------------------------------------------- -itcl::configbody iwidgets::Labeledframe::labelpos { - _positionLabel -} - -# ----------------------------------------------------------------------------- -# PROCS -# ----------------------------------------------------------------------------- - -# ----------------------------------------------------------------------------- -# PRIVATE PROC: _initTable -# -# Initializes the _LAYOUT_TABLE common variable of the Labeledframe -# class. The initialization is performed in its own proc ( as opposed -# to in the class definition ) so that the initialization occurs only -# once. -# -# _LAYOUT_TABLE common array description: -# Provides a table of the configuration option values -# used to place the label widget within the grooved relief of the hull -# frame for each of the 12 possible "-labelpos" values. -# -# Each of the 12 rows is layed out as follows: -# {"-relx" "-rely" } -# ----------------------------------------------------------------------------- -itcl::body iwidgets::Labeledframe::_initTable {} { - if {![catch {set _LAYOUT_TABLE(nw-relx)}]} return ;#RZ - array set _LAYOUT_TABLE { - nw-relx 0.0 nw-rely 0.0 nw-wrap 0 nw-conf rowconfigure nw-num 0 - n-relx 0.5 n-rely 0.0 n-wrap 0 n-conf rowconfigure n-num 0 - ne-relx 1.0 ne-rely 0.0 ne-wrap 0 ne-conf rowconfigure ne-num 0 - - sw-relx 0.0 sw-rely 1.0 sw-wrap 0 sw-conf rowconfigure sw-num 2 - s-relx 0.5 s-rely 1.0 s-wrap 0 s-conf rowconfigure s-num 2 - se-relx 1.0 se-rely 1.0 se-wrap 0 se-conf rowconfigure se-num 2 - - en-relx 1.0 en-rely 0.0 en-wrap 1 en-conf columnconfigure en-num 2 - e-relx 1.0 e-rely 0.5 e-wrap 1 e-conf columnconfigure e-num 2 - es-relx 1.0 es-rely 1.0 es-wrap 1 es-conf columnconfigure es-num 2 - - wn-relx 0.0 wn-rely 0.0 wn-wrap 1 wn-conf columnconfigure wn-num 0 - w-relx 0.0 w-rely 0.5 w-wrap 1 w-conf columnconfigure w-num 0 - ws-relx 0.0 ws-rely 1.0 ws-wrap 1 ws-conf columnconfigure ws-num 0 - } - - # - # Since this is a one time only thing, we'll redefine the proc to be empty - # afterwards so it only happens once. - # - # NOTE: Be careful to use the "body" command, or the proc will get lost! - # - #RZ itcl::body ::iwidgets::Labeledframe::_initTable {} {} -} - -# ----------------------------------------------------------------------------- -# METHODS -# ----------------------------------------------------------------------------- - -# ----------------------------------------------------------------------------- -# PUBLIC METHOD:: childsite -# -# ----------------------------------------------------------------------------- -itcl::body iwidgets::Labeledframe::childsite {} { - return $itk_component(childsite) -} - -# ----------------------------------------------------------------------------- -# PROTECTED METHOD: _positionLabel ?when? -# -# Places the label in the relief of the hull. If "when" is "now", the -# change is applied immediately. If it is "later" or it is not -# specified, then the change is applied later, when the application -# is idle. -# ----------------------------------------------------------------------------- -itcl::body iwidgets::Labeledframe::_positionLabel {{when later}} { - - if {$when == "later"} { - if {$_reposition == ""} { - set _reposition [after idle [itcl::code $this _positionLabel now]] - } - return - } - - set pos $itk_option(-labelpos) - - # - # If there is not an entry for the "relx" value associated with - # the given "-labelpos" option value, then it invalid. - # - if { [catch {set relx $_LAYOUT_TABLE($pos-relx)}] } { - error "bad labelpos option\"$itk_option(-labelpos)\": should be\ - nw, n, ne, sw, s, se, en, e, es, wn, w, or ws" - } - - update idletasks - $itk_component(label) configure -wraplength $_LAYOUT_TABLE($pos-wrap) - set labelWidth [winfo reqwidth $itk_component(label)] - set labelHeight [winfo reqheight $itk_component(label)] - set borderwidth $itk_option(-borderwidth) - set margin $itk_option(-labelmargin) - - switch $pos { - nw { - set labelThickness $labelHeight - set minsize [expr {$labelThickness/2.0}] - set xPos [expr {$minsize+$borderwidth+$margin}] - set yPos -$minsize - } - n { - set labelThickness $labelHeight - set minsize [expr {$labelThickness/2.0}] - set xPos [expr {-$labelWidth/2.0}] - set yPos -$minsize - } - ne { - set labelThickness $labelHeight - set minsize [expr {$labelThickness/2.0}] - set xPos [expr {-($minsize+$borderwidth+$margin+$labelWidth)}] - set yPos -$minsize - } - - sw { - set labelThickness $labelHeight - set minsize [expr {$labelThickness/2.0}] - set xPos [expr {$minsize+$borderwidth+$margin}] - set yPos -$minsize - } - s { - set labelThickness $labelHeight - set minsize [expr {$labelThickness/2.0}] - set xPos [expr {-$labelWidth/2.0}] - set yPos [expr {-$labelHeight/2.0}] - } - se { - set labelThickness $labelHeight - set minsize [expr {$labelThickness/2.0}] - set xPos [expr {-($minsize+$borderwidth+$margin+$labelWidth)}] - set yPos [expr {-$labelHeight/2.0}] - } - - wn { - set labelThickness $labelWidth - set minsize [expr {$labelThickness/2.0}] - set xPos -$minsize - set yPos [expr {$minsize+$margin+$borderwidth}] - } - w { - set labelThickness $labelWidth - set minsize [expr {$labelThickness/2.0}] - set xPos -$minsize - set yPos [expr {-($labelHeight/2.0)}] - } - ws { - set labelThickness $labelWidth - set minsize [expr {$labelThickness/2.0}] - set xPos -$minsize - set yPos [expr {-($minsize+$borderwidth+$margin+$labelHeight)}] - } - - en { - set labelThickness $labelWidth - set minsize [expr {$labelThickness/2.0}] - set xPos -$minsize - set yPos [expr {$minsize+$borderwidth+$margin}] - } - e { - set labelThickness $labelWidth - set minsize [expr {$labelThickness/2.0}] - set xPos -$minsize - set yPos [expr {-($labelHeight/2.0)}] - } - es { - set labelThickness $labelWidth - set minsize [expr {$labelThickness/2.0}] - set xPos -$minsize - set yPos [expr {-($minsize+$borderwidth+$margin+$labelHeight)}] - } - } - _setMarginThickness $minsize - - place $itk_component(label) \ - -relx $_LAYOUT_TABLE($pos-relx) -x $xPos \ - -rely $_LAYOUT_TABLE($pos-rely) -y $yPos \ - -anchor nw - - set what $_LAYOUT_TABLE($pos-conf) - set number $_LAYOUT_TABLE($pos-num) - - grid $what $itk_interior $number -minsize $minsize - - set _reposition "" -} - -# ----------------------------------------------------------------------------- -# PROTECTED METHOD: _collapseMargin -# -# Resets the "-minsize" of all rows and columns of the hull's grid -# used to set the label margin to 0 -# ----------------------------------------------------------------------------- -itcl::body iwidgets::Labeledframe::_collapseMargin {} { - grid columnconfigure $itk_interior 0 -minsize 0 - grid columnconfigure $itk_interior 2 -minsize 0 - grid rowconfigure $itk_interior 0 -minsize 0 - grid rowconfigure $itk_interior 2 -minsize 0 -} - -# ----------------------------------------------------------------------------- -# PROTECTED METHOD: _setMarginThickness -# -# Set the margin thickness ( i.e. the hidden "-highlightthickness" -# of the hull ) to the input value. -# -# The "-highlightthickness" option of the hull frame is not intended to be -# configured by users of this class, but does need to be configured to properly -# place the label whenever the label is configured. -# -# Therefore, since I can't find a better way at this time, I achieve this -# configuration by: adding the "-highlightthickness" option back into -# the hull frame; configuring the "-highlightthickness" option to properly -# place the label; and then remove the "-highlightthickness" option from the -# hull. -# -# This way the option is not visible or configurable without some hacking. -# -# ----------------------------------------------------------------------------- -itcl::body iwidgets::Labeledframe::_setMarginThickness {value} { - itk_option add hull.highlightthickness - $itk_component(hull) configure -highlightthickness $value - itk_option remove hull.highlightthickness -} - - diff --git a/iwidgets/library/labeledwidget.itk b/iwidgets/library/labeledwidget.itk deleted file mode 100644 index d8ba5dc..0000000 --- a/iwidgets/library/labeledwidget.itk +++ /dev/null @@ -1,445 +0,0 @@ -# -# Labeledwidget -# ---------------------------------------------------------------------- -# Implements a labeled widget which contains a label and child site. -# The child site is a frame which can filled with any widget via a -# derived class or though the use of the childsite method. This class -# was designed to be a general purpose base class for supporting the -# combination of label widget and a childsite, where a label may be -# text, bitmap or image. The options include the ability to position -# the label around the childsite widget, modify the font and margin, -# and control the display of the label. -# -# ---------------------------------------------------------------------- -# AUTHOR: Mark L. Ulferts EMAIL: mulferts@austin.dsccc.com -# -# @(#) $Id: labeledwidget.itk,v 1.4 2001/08/20 20:02:53 smithc Exp $ -# ---------------------------------------------------------------------- -# Copyright (c) 1995 DSC Technologies Corporation -# ====================================================================== -# Permission to use, copy, modify, distribute and license this software -# and its documentation for any purpose, and without fee or written -# agreement with DSC, is hereby granted, provided that the above copyright -# notice appears in all copies and that both the copyright notice and -# warranty disclaimer below appear in supporting documentation, and that -# the names of DSC Technologies Corporation or DSC Communications -# Corporation not be used in advertising or publicity pertaining to the -# software without specific, written prior permission. -# -# DSC DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING -# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, 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. IN NO EVENT SHALL -# DSC BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR -# ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, -# WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION, -# ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS -# SOFTWARE. -# ====================================================================== - -# -# Usual options. -# -itk::usual Labeledwidget { - keep -background -cursor -foreground -labelfont -} - -# ------------------------------------------------------------------ -# LABELEDWIDGET -# ------------------------------------------------------------------ -itcl::class iwidgets::Labeledwidget { - inherit itk::Widget - - constructor {args} {} - destructor {} - - itk_option define -disabledforeground disabledForeground \ - DisabledForeground \#a3a3a3 - itk_option define -labelpos labelPos Position w - itk_option define -labelmargin labelMargin Margin 2 - itk_option define -labeltext labelText Text {} - itk_option define -labelvariable labelVariable Variable {} - itk_option define -labelbitmap labelBitmap Bitmap {} - itk_option define -labelimage labelImage Image {} - itk_option define -state state State normal - itk_option define -sticky sticky Sticky nsew - - public method childsite - - private method _positionLabel {{when later}} - - proc alignlabels {args} {} - - protected variable _reposition "" ;# non-null => _positionLabel pending -} - -# -# Provide a lowercased access method for the Labeledwidget class. -# -proc ::iwidgets::labeledwidget {pathName args} { - uplevel ::iwidgets::Labeledwidget $pathName $args -} - -# ------------------------------------------------------------------ -# CONSTRUCTOR -# ------------------------------------------------------------------ -itcl::body iwidgets::Labeledwidget::constructor {args} { - # - # Create a frame for the childsite widget. - # - itk_component add -protected lwchildsite { - frame $itk_interior.lwchildsite - } - - # - # Create label. - # - itk_component add label { - label $itk_interior.label - } { - usual - - rename -font -labelfont labelFont Font - ignore -highlightcolor -highlightthickness - } - - # - # Set the interior to be the childsite for derived classes. - # - set itk_interior $itk_component(lwchildsite) - - # - # Initialize the widget based on the command line options. - # - eval itk_initialize $args - - # - # When idle, position the label. - # - _positionLabel -} - -# ------------------------------------------------------------------ -# DESTRUCTOR -# ------------------------------------------------------------------ -itcl::body iwidgets::Labeledwidget::destructor {} { - if {$_reposition != ""} {after cancel $_reposition} -} - -# ------------------------------------------------------------------ -# OPTIONS -# ------------------------------------------------------------------ - -# ------------------------------------------------------------------ -# OPTION: -disabledforeground -# -# Specified the foreground to be used on the label when disabled. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Labeledwidget::disabledforeground {} - -# ------------------------------------------------------------------ -# OPTION: -labelpos -# -# Set the position of the label on the labeled widget. The margin -# between the label and childsite comes along for the ride. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Labeledwidget::labelpos { - _positionLabel -} - -# ------------------------------------------------------------------ -# OPTION: -labelmargin -# -# Specifies the distance between the widget and label. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Labeledwidget::labelmargin { - _positionLabel -} - -# ------------------------------------------------------------------ -# OPTION: -labeltext -# -# Specifies the label text. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Labeledwidget::labeltext { - $itk_component(label) configure -text $itk_option(-labeltext) - - _positionLabel -} - -# ------------------------------------------------------------------ -# OPTION: -labelvariable -# -# Specifies the label text variable. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Labeledwidget::labelvariable { - $itk_component(label) configure -textvariable $itk_option(-labelvariable) - - _positionLabel -} - -# ------------------------------------------------------------------ -# OPTION: -labelbitmap -# -# Specifies the label bitmap. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Labeledwidget::labelbitmap { - $itk_component(label) configure -bitmap $itk_option(-labelbitmap) - - _positionLabel -} - -# ------------------------------------------------------------------ -# OPTION: -labelimage -# -# Specifies the label image. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Labeledwidget::labelimage { - $itk_component(label) configure -image $itk_option(-labelimage) - - _positionLabel -} - -# ------------------------------------------------------------------ -# OPTION: -sticky -# -# Specifies the stickyness of the child site. This option was added -# by James Bonfield (committed by Chad Smith 8/20/01). -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Labeledwidget::sticky { - grid $itk_component(lwchildsite) -sticky $itk_option(-sticky) -} - -# ------------------------------------------------------------------ -# OPTION: -state -# -# Specifies the state of the label. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Labeledwidget::state { - _positionLabel -} - -# ------------------------------------------------------------------ -# METHODS -# ------------------------------------------------------------------ - -# ------------------------------------------------------------------ -# METHOD: childsite -# -# Returns the path name of the child site widget. -# ------------------------------------------------------------------ -itcl::body iwidgets::Labeledwidget::childsite {} { - return $itk_component(lwchildsite) -} - -# ------------------------------------------------------------------ -# PROCEDURE: alignlabels widget ?widget ...? -# -# The alignlabels procedure takes a list of widgets derived from -# the Labeledwidget class and adjusts the label margin to align -# the labels. -# ------------------------------------------------------------------ -itcl::body iwidgets::Labeledwidget::alignlabels {args} { - update - set maxLabelWidth 0 - - # - # Verify that all the widgets are of type Labeledwidget and - # determine the size of the maximum length label string. - # - foreach iwid $args { - set objcmd [itcl::find objects -isa Labeledwidget *::$iwid] - - if {$objcmd == ""} { - error "$iwid is not a \"Labeledwidget\"" - } - - set csWidth [winfo reqwidth $iwid.lwchildsite] - set shellWidth [winfo reqwidth $iwid] - - if {($shellWidth - $csWidth) > $maxLabelWidth} { - set maxLabelWidth [expr {$shellWidth - $csWidth}] - } - } - - # - # Adjust the margins for the labels such that the child sites and - # labels line up. - # - foreach iwid $args { - set csWidth [winfo reqwidth $iwid.lwchildsite] - set shellWidth [winfo reqwidth $iwid] - - set labelSize [expr {$shellWidth - $csWidth}] - - if {$maxLabelWidth > $labelSize} { - set objcmd [itcl::find objects -isa Labeledwidget *::$iwid] - set dist [expr {$maxLabelWidth - \ - ($labelSize - [$objcmd cget -labelmargin])}] - - $objcmd configure -labelmargin $dist - } - } -} - -# ------------------------------------------------------------------ -# PROTECTED METHOD: _positionLabel ?when? -# -# Packs the label and label margin. If "when" is "now", the -# change is applied immediately. If it is "later" or it is not -# specified, then the change is applied later, when the application -# is idle. -# ------------------------------------------------------------------ -itcl::body iwidgets::Labeledwidget::_positionLabel {{when later}} { - if {$when == "later"} { - if {$_reposition == ""} { - set _reposition [after idle [itcl::code $this _positionLabel now]] - } - return - - } elseif {$when != "now"} { - error "bad option \"$when\": should be now or later" - } - - # - # If we have a label, be it text, bitmap, or image continue. - # - if {($itk_option(-labeltext) != {}) || \ - ($itk_option(-labelbitmap) != {}) || \ - ($itk_option(-labelimage) != {}) || \ - ($itk_option(-labelvariable) != {})} { - - # - # Set the foreground color based on the state. - # - if {[info exists itk_option(-state)]} { - switch -- $itk_option(-state) { - disabled { - $itk_component(label) configure \ - -foreground $itk_option(-disabledforeground) - } - normal { - $itk_component(label) configure \ - -foreground $itk_option(-foreground) - } - } - } - - set parent [winfo parent $itk_component(lwchildsite)] - - # - # Switch on the label position option. Using the grid, - # adjust the row/column setting of the label, margin, and - # and childsite. The margin height/width is adjust based - # on the orientation as well. Finally, set the weights such - # that the childsite takes the heat on expansion and shrinkage. - # - switch $itk_option(-labelpos) { - nw - - n - - ne { - grid $itk_component(label) -row 0 -column 0 \ - -sticky $itk_option(-labelpos) - grid $itk_component(lwchildsite) -row 2 -column 0 \ - -sticky $itk_option(-sticky) - - grid rowconfigure $parent 0 -weight 0 -minsize 0 - grid rowconfigure $parent 1 -weight 0 -minsize \ - [winfo pixels $itk_component(label) \ - $itk_option(-labelmargin)] - grid rowconfigure $parent 2 -weight 1 -minsize 0 - - grid columnconfigure $parent 0 -weight 1 -minsize 0 - grid columnconfigure $parent 1 -weight 0 -minsize 0 - grid columnconfigure $parent 2 -weight 0 -minsize 0 - } - - en - - e - - es { - grid $itk_component(lwchildsite) -row 0 -column 0 \ - -sticky $itk_option(-sticky) - grid $itk_component(label) -row 0 -column 2 \ - -sticky $itk_option(-labelpos) - - grid rowconfigure $parent 0 -weight 1 -minsize 0 - grid rowconfigure $parent 1 -weight 0 -minsize 0 - grid rowconfigure $parent 2 -weight 0 -minsize 0 - - grid columnconfigure $parent 0 -weight 1 -minsize 0 - grid columnconfigure $parent 1 -weight 0 -minsize \ - [winfo pixels $itk_component(label) \ - $itk_option(-labelmargin)] - grid columnconfigure $parent 2 -weight 0 -minsize 0 - } - - se - - s - - sw { - grid $itk_component(lwchildsite) -row 0 -column 0 \ - -sticky $itk_option(-sticky) - grid $itk_component(label) -row 2 -column 0 \ - -sticky $itk_option(-labelpos) - - grid rowconfigure $parent 0 -weight 1 -minsize 0 - grid rowconfigure $parent 1 -weight 0 -minsize \ - [winfo pixels $itk_component(label) \ - $itk_option(-labelmargin)] - grid rowconfigure $parent 2 -weight 0 -minsize 0 - - grid columnconfigure $parent 0 -weight 1 -minsize 0 - grid columnconfigure $parent 1 -weight 0 -minsize 0 - grid columnconfigure $parent 2 -weight 0 -minsize 0 - } - - wn - - w - - ws { - grid $itk_component(lwchildsite) -row 0 -column 2 \ - -sticky $itk_option(-sticky) - grid $itk_component(label) -row 0 -column 0 \ - -sticky $itk_option(-labelpos) - - grid rowconfigure $parent 0 -weight 1 -minsize 0 - grid rowconfigure $parent 1 -weight 0 -minsize 0 - grid rowconfigure $parent 2 -weight 0 -minsize 0 - - grid columnconfigure $parent 0 -weight 0 -minsize 0 - grid columnconfigure $parent 1 -weight 0 -minsize \ - [winfo pixels $itk_component(label) \ - $itk_option(-labelmargin)] - grid columnconfigure $parent 2 -weight 1 -minsize 0 - } - - default { - error "bad labelpos option\ - \"$itk_option(-labelpos)\": should be\ - nw, n, ne, sw, s, se, en, e, es, wn, w, or ws" - } - } - - # - # Else, neither the label text, bitmap, or image have a value, so - # forget them so they don't appear and manage only the childsite. - # - } else { - grid forget $itk_component(label) - - grid $itk_component(lwchildsite) -row 0 -column 0 -sticky $itk_option(-sticky) - - set parent [winfo parent $itk_component(lwchildsite)] - - grid rowconfigure $parent 0 -weight 1 -minsize 0 - grid rowconfigure $parent 1 -weight 0 -minsize 0 - grid rowconfigure $parent 2 -weight 0 -minsize 0 - grid columnconfigure $parent 0 -weight 1 -minsize 0 - grid columnconfigure $parent 1 -weight 0 -minsize 0 - grid columnconfigure $parent 2 -weight 0 -minsize 0 - } - - # - # Reset the resposition flag. - # - set _reposition "" -} diff --git a/iwidgets/library/mainwindow.itk b/iwidgets/library/mainwindow.itk deleted file mode 100644 index 1f9051e..0000000 --- a/iwidgets/library/mainwindow.itk +++ /dev/null @@ -1,313 +0,0 @@ -# -# Mainwindow -# ---------------------------------------------------------------------- -# This class implements a mainwindow containing a menubar, toolbar, -# mousebar, childsite, status line, and help line. Each item may -# be filled and configured to suit individual needs. -# -# ---------------------------------------------------------------------- -# AUTHOR: Mark L. Ulferts EMAIL: mulferts@austin.dsccc.com -# -# @(#) RCS: $Id: mainwindow.itk,v 1.2 2001/08/07 19:56:48 smithc Exp $ -# ---------------------------------------------------------------------- -# Copyright (c) 1997 DSC Technologies Corporation -# ====================================================================== -# Permission to use, copy, modify, distribute and license this software -# and its documentation for any purpose, and without fee or written -# agreement with DSC, is hereby granted, provided that the above copyright -# notice appears in all copies and that both the copyright notice and -# warranty disclaimer below appear in supporting documentation, and that -# the names of DSC Technologies Corporation or DSC Communications -# Corporation not be used in advertising or publicity pertaining to the -# software without specific, written prior permission. -# -# DSC DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING -# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, 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. IN NO EVENT SHALL -# DSC BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR -# ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, -# WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION, -# ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS -# SOFTWARE. -# ====================================================================== - -# ------------------------------------------------------------------ -# MAINWINDOW -# ------------------------------------------------------------------ -itcl::class iwidgets::Mainwindow { - inherit iwidgets::Shell - - constructor {args} {} - - itk_option define -helpline helpLine HelpLine 1 - itk_option define -statusline statusLine StatusLine 1 - - public { - method childsite {} - method menubar {args} - method mousebar {args} - method msgd {args} - method toolbar {args} - } - - protected { - method _exitCB {} - - common _helpVar - common _statusVar - } -} - -# -# Provide a lowercased access method for the ::iwidgets::Mainwindow class. -# -proc iwidgets::mainwindow {pathName args} { - uplevel ::iwidgets::Mainwindow $pathName $args -} - -# ------------------------------------------------------------------ -# CONSTRUCTOR -# ------------------------------------------------------------------ -itcl::body iwidgets::Mainwindow::constructor {args} { - itk_option add hull.width hull.height - - pack propagate $itk_component(hull) no - - wm protocol $itk_component(hull) WM_DELETE_WINDOW [itcl::code $this _exitCB] - - # - # Create a menubar, renaming the font, foreground, and background - # so they may be separately set. The help variable will be setup - # as well. - # - itk_component add menubar { - iwidgets::Menubar $itk_interior.menubar \ - -helpvariable [itcl::scope _helpVar($this)] - } { - keep -disabledforeground -cursor \ - -highlightbackground -highlightthickness - rename -font \ - -menubarfont menuBarFont Font - rename -foreground \ - -menubarforeground menuBarForeground Foreground - rename -background \ - -menubarbackground menuBarBackground Background - } - - # - # Add a toolbar beneath the menubar. - # - itk_component add toolbar { - iwidgets::Toolbar $itk_interior.toolbar -orient horizontal \ - -helpvariable [itcl::scope _helpVar($this)] - } { - keep -balloonbackground -balloondelay1 -balloondelay2 \ - -balloonfont -balloonforeground -disabledforeground -cursor \ - -highlightbackground -highlightthickness - rename -font -toolbarfont toolbarFont Font - rename -foreground -toolbarforeground toolbarForeground Foreground - rename -background -toolbarbackground toolbarBackground Background - } - - # - # Add a mouse bar on the left. - # - itk_component add mousebar { - iwidgets::Toolbar $itk_interior.mousebar -orient vertical \ - -helpvariable [itcl::scope _helpVar($this)] - } { - keep -balloonbackground -balloondelay1 -balloondelay2 \ - -balloonfont -balloonforeground -disabledforeground -cursor \ - -highlightbackground -highlightthickness - rename -font -toolbarfont toolbarFont Font - rename -foreground -toolbarforeground toolbarForeground Foreground - rename -background -toolbarbackground toolbarBackground Background - } - - # - # Create the childsite window window. - # - itk_component add -protected mwchildsite { - frame $itk_interior.mwchildsite - } - - # - # Add the help and system status lines - # - itk_component add -protected lineframe { - frame $itk_interior.lineframe - } - - itk_component add help { - label $itk_component(lineframe).help \ - -textvariable [itcl::scope _helpVar($this)] \ - -relief sunken -borderwidth 2 -width 10 - } - - itk_component add status { - label $itk_component(lineframe).status \ - -textvariable [itcl::scope _statusVar($this)] \ - -relief sunken -borderwidth 2 -width 10 - } - - # - # Create the message dialog for use throughout the mainwindow. - # - itk_component add msgd { - iwidgets::Messagedialog $itk_interior.msgd -modality application - } { - usual - ignore -modality - } - - # - # Use the grid to pack together the menubar, toolbar, mousebar, - # childsite, and status area. - # - grid $itk_component(menubar) -row 0 -column 0 -columnspan 2 -sticky ew - grid $itk_component(toolbar) -row 1 -column 0 -columnspan 2 -sticky ew - grid $itk_component(mousebar) -row 2 -column 0 -sticky ns - grid $itk_component(mwchildsite) -row 2 -column 1 -sticky nsew \ - -padx 5 -pady 5 - grid $itk_component(lineframe) -row 3 -column 0 -columnspan 2 -sticky ew - - grid columnconfigure $itk_interior 1 -weight 1 - grid rowconfigure $itk_interior 2 -weight 1 - - # - # Set the interior to be the childsite for derived classes. - # - set itk_interior $itk_component(mwchildsite) - - # - # Initialize all the configuration options. - # - eval itk_initialize $args -} - -# ------------------------------------------------------------------ -# OPTIONS -# ------------------------------------------------------------------ - -# ------------------------------------------------------------------ -# OPTION: -helpline -# -# Specifies whether or not to display the help line. The value -# may be given in any of the forms acceptable to Tk_GetBoolean. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Mainwindow::helpline { - if {$itk_option(-helpline)} { - pack $itk_component(help) -side left -fill x -expand yes -padx 2 - } else { - pack forget $itk_component(help) - } -} - -# ------------------------------------------------------------------ -# OPTION: -statusline -# -# Specifies whether or not to display the status line. The value -# may be given in any of the forms acceptable to Tk_GetBoolean. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Mainwindow::statusline { - if {$itk_option(-statusline)} { - pack $itk_component(status) -side right -fill x -expand yes -padx 2 - } else { - pack forget $itk_component(status) - } -} - -# ------------------------------------------------------------------ -# METHODS -# ------------------------------------------------------------------ - -# ------------------------------------------------------------------ -# METHOD: childsite -# -# Return the childsite widget. -# ------------------------------------------------------------------ -itcl::body iwidgets::Mainwindow::childsite {} { - return $itk_component(mwchildsite) -} - -# ------------------------------------------------------------------ -# METHOD: menubar ?args? -# -# Evaluate the args against the Menubar component. -# ------------------------------------------------------------------ -itcl::body iwidgets::Mainwindow::menubar {args} { - if {[llength $args] == 0} { - return $itk_component(menubar) - } else { - return [eval $itk_component(menubar) $args] - } -} - -# ------------------------------------------------------------------ -# METHOD: toolbar ?args? -# -# Evaluate the args against the Toolbar component. -# ------------------------------------------------------------------ -itcl::body iwidgets::Mainwindow::toolbar {args} { - if {[llength $args] == 0} { - return $itk_component(toolbar) - } else { - return [eval $itk_component(toolbar) $args] - } -} - -# ------------------------------------------------------------------ -# METHOD: mousebar ?args? -# -# Evaluate the args against the Mousebar component. -# ------------------------------------------------------------------ -itcl::body iwidgets::Mainwindow::mousebar {args} { - if {[llength $args] == 0} { - return $itk_component(mousebar) - } else { - return [eval $itk_component(mousebar) $args] - } -} - -# ------------------------------------------------------------------ -# METHOD: msgd ?args? -# -# Evaluate the args against the Messagedialog component. -# ------------------------------------------------------------------ -itcl::body iwidgets::Mainwindow::msgd {args} { - if {[llength $args] == 0} { - return $itk_component(msgd) - } else { - return [eval $itk_component(msgd) $args] - } -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _exitCB -# -# Menu callback for the exit option from the file menu. The method -# confirms the user's request to exit the application prior to -# taking the action. -# ------------------------------------------------------------------ -itcl::body iwidgets::Mainwindow::_exitCB {} { - # - # Configure the message dialog for confirmation of the exit request. - # - msgd configure -title Confirmation -bitmap questhead \ - -text "Exit confirmation\n\ - Are you sure ?" - msgd buttonconfigure OK -text Yes - msgd buttonconfigure Cancel -text No - msgd default Cancel - msgd center $itk_component(hull) - - # - # Activate the message dialog and given a positive response - # proceed to exit the application - # - if {[msgd activate]} { - ::exit - } -} diff --git a/iwidgets/library/menubar.itk b/iwidgets/library/menubar.itk deleted file mode 100644 index 48b9d04..0000000 --- a/iwidgets/library/menubar.itk +++ /dev/null @@ -1,2267 +0,0 @@ -# -# Menubar widget -# ---------------------------------------------------------------------- -# The Menubar command creates a new window (given by the pathName -# argument) and makes it into a Pull down menu widget. Additional -# options, described above may be specified on the command line or -# in the option database to configure aspects of the Menubar such -# as its colors and font. The Menubar command returns its pathName -# argument. At the time this command is invoked, there must not exist -# a window named pathName, but pathName's parent must exist. -# -# A Menubar is a widget that simplifies the task of creating -# menu hierarchies. It encapsulates a frame widget, as well -# as menubuttons, menus, and menu entries. The Menubar allows -# menus to be specified and refer enced in a more consistent -# manner than using Tk to build menus directly. First, Menubar -# allows a menu tree to be expressed in a hierachical "language". -# The Menubar accepts a menuButtons option that allows a list of -# menubuttons to be added to the Menubar. In turn, each menubutton -# accepts a menu option that spec ifies a list of menu entries -# to be added to the menubutton's menu (as well as an option -# set for the menu). Cascade entries in turn, accept a menu -# option that specifies a list of menu entries to be added to -# the cascade's menu (as well as an option set for the menu). In -# this manner, a complete menu grammar can be expressed to the -# Menubar. Additionally, the Menubar allows each component of -# the Menubar system to be referenced by a simple componentPathName -# syntax. Finally, the Menubar extends the option set of menu -# entries to include the helpStr option used to implement status -# bar help. -# -# WISH LIST: -# This section lists possible future enhancements. -# -# ---------------------------------------------------------------------- -# AUTHOR: Bill W. Scott -# -# CURRENT MAINTAINER: Chad Smith --> csmith@adc.com or itclguy@yahoo.com -# -# @(#) $Id: menubar.itk,v 1.8 2001/08/15 18:33:13 smithc Exp $ -# ---------------------------------------------------------------------- -# Copyright (c) 1995 DSC Technologies Corporation -# ====================================================================== -# Permission to use, copy, modify, distribute and license this software -# and its documentation for any purpose, and without fee or written -# agreement with DSC, is hereby granted, provided that the above copyright -# notice appears in all copies and that both the copyright notice and -# warranty disclaimer below appear in supporting documentation, and that -# the names of DSC Technologies Corporation or DSC Communications -# Corporation not be used in advertising or publicity pertaining to the -# software without specific, written prior permission. -# -# DSC DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING -# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, 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. IN NO EVENT SHALL -# DSC BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR -# ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, -# WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION, -# ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS -# SOFTWARE. -# ====================================================================== - - -# -# Usual options. -# -itk::usual Menubar { - keep -activebackground -activeborderwidth -activeforeground \ - -anchor -background -borderwidth -cursor -disabledforeground \ - -font -foreground -highlightbackground -highlightthickness \ - -highlightcolor -justify -padx -pady -wraplength -} - -itcl::class iwidgets::Menubar { - inherit itk::Widget - - constructor { args } {} - - itk_option define -foreground foreground Foreground Black - itk_option define -activebackground activeBackground Foreground "#ececec" - itk_option define -activeborderwidth activeBorderWidth BorderWidth 2 - itk_option define -activeforeground activeForeground Background black - itk_option define -anchor anchor Anchor center - itk_option define -borderwidth borderWidth BorderWidth 2 - itk_option define \ - -disabledforeground disabledForeground DisabledForeground #a3a3a3 - itk_option define \ - -font font Font "-Adobe-Helvetica-Bold-R-Normal--*-120-*-*-*-*-*-*" - itk_option define \ - -highlightbackground highlightBackground HighlightBackground #d9d9d9 - itk_option define -highlightcolor highlightColor HighlightColor Black - itk_option define \ - -highlightthickness highlightThickness HighlightThickness 0 - itk_option define -justify justify Justify center - itk_option define -padx padX Pad 4p - itk_option define -pady padY Pad 3p - itk_option define -wraplength wrapLength WrapLength 0 - itk_option define -menubuttons menuButtons MenuButtons {} - itk_option define -helpvariable helpVariable HelpVariable {} - - public { - method add { type path args } { } - method delete { args } { } - method index { path } { } - method insert { beforeComponent type name args } - method invoke { entryPath } { } - method menucget { args } { } - method menuconfigure { path args } { } - method path { args } { } - method type { path } { } - method yposition { entryPath } { } - } - - private { - method menubutton { menuName args } { } - method options { args } { } - method command { cmdName args } { } - method checkbutton { chkName args } { } - method radiobutton { radName args } { } - method separator { sepName args } { } - method cascade { casName args } { } - method _helpHandler { menuPath } { } - method _addMenuButton { buttonName args} { } - method _insertMenuButton { beforeMenuPath buttonName args} { } - method _makeMenuButton {buttonName args} { } - method _makeMenu \ - { componentName widgetName menuPath menuEvalStr } { } - method _substEvalStr { evalStr } { } - method _deleteMenu { menuPath {menuPath2 {}} } { } - method _deleteAMenu { path } { } - method _addEntry { type path args } { } - method _addCascade { tkMenuPath path args } { } - method _insertEntry { beforeEntryPath type name args } { } - method _insertCascade { bfIndex tkMenuPath path args } { } - method _deleteEntry { entryPath {entryPath2 {}} } { } - method _configureMenu { path tkPath {option {}} args } { } - method _configureMenuOption { type path args } { } - method _configureMenuEntry { path index {option {}} args } { } - method _unsetPaths { parent } { } - method _entryPathToTkMenuPath {entryPath} { } - method _getTkIndex { tkMenuPath tkIndex} { } - method _getPdIndex { tkMenuPath tkIndex } { } - method _getMenuList { } { } - method _getEntryList { menu } { } - method _parsePath { path } { } - method _getSymbolicPath { parent segment } { } - method _getCallerLevel { } - - variable _parseLevel 0 ;# The parse level depth - variable _callerLevel #0 ;# abs level of caller - variable _pathMap ;# Array indexed by Menubar's path - ;# naming, yields tk menu path - variable _entryIndex -1 ;# current entry help is displayed - ;# for during help events - - variable _tkMenuPath ;# last tk menu being added to - variable _ourMenuPath ;# our last valid path constructed. - - variable _menuOption ;# The -menu option - variable _helpString ;# The -helpstr optio - variable _fixed 0 ;#RZ bug fix - } -} - -# -# Use option database to override default resources. -# -option add *Menubar*Menu*tearOff false widgetDefault -option add *Menubar*Menubutton*relief flat widgetDefault -option add *Menubar*Menu*relief raised widgetDefault - -# -# Provide a lowercase access method for the menubar class -# -proc ::iwidgets::menubar { args } { - uplevel ::iwidgets::Menubar $args -} - -# ------------------------------------------------------------------ -# CONSTRUCTOR -# ------------------------------------------------------------------ -itcl::body iwidgets::Menubar::constructor { args } { - component hull configure -borderwidth 0 - - # - # Create the Menubar Frame that will hold the menus. - # - # might want to make -relief and -bd options with defaults - itk_component add menubar { - frame $itk_interior.menubar -relief raised -bd 2 - } { - keep -cursor -background -width -height - } - pack $itk_component(menubar) -fill both -expand yes - - # Map our pathname to class to the actual menubar frame - set _pathMap(.) $itk_component(menubar) - - eval itk_initialize $args - set _fixed 1 ;#RZ - # - # HACK HACK HACK - # Tk expects some variables to be defined and due to some - # unknown reason we confuse its normal ordering. So, if - # the user creates a menubutton with no menu it will fail - # when clicked on with a "Error: can't read $tkPriv(oldGrab): - # no such element in array". So by setting it to null we - # avoid this error. - uplevel #0 "set tkPriv(oldGrab) {}" - -} - -# ------------------------------------------------------------------ -# OPTIONS -# ------------------------------------------------------------------ -# This first set of options are for configuring menus and/or menubuttons -# at the menu level. -# -# ------------------------------------------------------------------ -# OPTION -foreground -# -# menu -# menubutton -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Menubar::foreground { -} - -# ------------------------------------------------------------------ -# OPTION -activebackground -# -# menu -# menubutton -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Menubar::activebackground { -} - -# ------------------------------------------------------------------ -# OPTION -activeborderwidth -# -# menu -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Menubar::activeborderwidth { -} - -# ------------------------------------------------------------------ -# OPTION -activeforeground -# -# menu -# menubutton -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Menubar::activeforeground { -} - -# ------------------------------------------------------------------ -# OPTION -anchor -# -# menubutton -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Menubar::anchor { -} - -# ------------------------------------------------------------------ -# OPTION -borderwidth -# -# menu -# menubutton -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Menubar::borderwidth { -} - -# ------------------------------------------------------------------ -# OPTION -disabledforeground -# -# menu -# menubutton -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Menubar::disabledforeground { -} - -# ------------------------------------------------------------------ -# OPTION -font -# -# menu -# menubutton -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Menubar::font { -} - -# ------------------------------------------------------------------ -# OPTION -highlightbackground -# -# menubutton -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Menubar::highlightbackground { -} - -# ------------------------------------------------------------------ -# OPTION -highlightcolor -# -# menubutton -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Menubar::highlightcolor { -} - -# ------------------------------------------------------------------ -# OPTION -highlightthickness -# -# menubutton -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Menubar::highlightthickness { -} - -# ------------------------------------------------------------------ -# OPTION -justify -# -# menubutton -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Menubar::justify { -} - -# ------------------------------------------------------------------ -# OPTION -padx -# -# menubutton -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Menubar::padx { -} - -# ------------------------------------------------------------------ -# OPTION -pady -# -# menubutton -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Menubar::pady { -} - -# ------------------------------------------------------------------ -# OPTION -wraplength -# -# menubutton -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Menubar::wraplength { -} - -# ------------------------------------------------------------------ -# OPTION -menubuttons -# -# The menuButton option is a string which specifies the arrangement -# of menubuttons on the Menubar frame. Each menubutton entry is -# delimited by the newline character. Each entry is treated as -# an add command to the Menubar. -# -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Menubar::menubuttons { - if { $itk_option(-menubuttons) != {} } { - - # IF one exists already, delete the old one and create - # a new one - #RZ if { ! [catch {_parsePath .0}] } - if { $_fixed && ! [catch {_parsePath .0}] } { - delete .0 .last - } - - # - # Determine the context level to evaluate the option string at - # - set _callerLevel [_getCallerLevel] - - # - # Parse the option string in their scope, then execute it in - # our scope. - # - incr _parseLevel - _substEvalStr itk_option(-menubuttons) - eval $itk_option(-menubuttons) - - # reset so that we know we aren't parsing in a scope currently. - incr _parseLevel -1 - } -} - -# ------------------------------------------------------------------ -# OPTION -helpvariable -# -# Specifies the global variable to update whenever the mouse is in -# motion over a menu entry. This global variable is updated with the -# current value of the active menu entry's helpStr. Other widgets -# can "watch" this variable with the trace command, or as is the -# case with entry or label widgets, they can set their textVariable -# to the same global variable. This allows for a simple implementation -# of a help status bar. Whenever the mouse leaves a menu entry, -# the helpVariable is set to the empty string {}. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Menubar::helpvariable { - if {"" != $itk_option(-helpvariable) && - ![string match ::* $itk_option(-helpvariable)] && - ![string match @itcl* $itk_option(-helpvariable)]} { - set itk_option(-helpvariable) "::$itk_option(-helpvariable)" - } -} - - -# ------------------------------------------------------------- -# -# METHOD: add type path args -# -# Adds either a menu to the menu bar or a menu entry to a -# menu pane. -# -# If the type is one of cascade, checkbutton, command, -# radiobutton, or separator it adds a new entry to the bottom -# of the menu denoted by the menuPath prefix of componentPath- -# Name. The new entry's type is given by type. If additional -# arguments are present, they specify options available to -# component type Entry. See the man pages for menu(n) in the -# section on Entries. In addition all entries accept an added -# option, helpStr: -# -# -helpstr value -# -# Specifes the string to associate with the entry. -# When the mouse moves over the associated entry, the variable -# denoted by helpVariable is set. Another widget can bind to -# the helpVariable and thus display status help. -# -# If the type is menubutton, it adds a new menubut- -# ton to the menu bar. If additional arguments are present, -# they specify options available to component type MenuButton. -# -# If the type is menubutton or cascade, the menu -# option is available in addition to normal Tk options for -# these to types. -# -# -menu menuSpec -# -# This is only valid for componentPathNames of type -# menubutton or cascade. Specifes an option set and/or a set -# of entries to place on a menu and associate with the menu- -# button or cascade. The option keyword allows the menu widget -# to be configured. Each item in the menuSpec is treated as -# add commands (each with the possibility of having other -# -menu options). In this way a menu can be recursively built. -# -# The last segment of componentPathName cannot be -# one of the keywords last, menu, end. Additionally, it may -# not be a number. However the componentPathName may be refer- -# enced in this manner (see discussion of Component Path -# Names). -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::add { type path args } { - if ![regexp \ - {^(menubutton|command|cascade|separator|radiobutton|checkbutton)$} \ - $type] { - error "bad type \"$type\": must be one of the following:\ - \"command\", \"checkbutton\", \"radiobutton\",\ - \"separator\", \"cascade\", or \"menubutton\"" - } - regexp {[^.]+$} $path segName - if [regexp {^(menu|last|end|[0-9]+)$} $segName] { - error "bad name \"$segName\": user created component \ - path names may not end with \ - \"end\", \"last\", \"menu\", \ - or be an integer" - } - - # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, - # OK, either add a menu - # ''''''''''''''''''''''''''''''''''''''''''''''''''''' - if { $type == "menubutton" } { - # grab the last component name (the menu name) - eval _addMenuButton $segName $args - # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, - # Or add an entry - # ''''''''''''''''''''''''''''''''''''''''''''''''''''' - } else { - eval _addEntry $type $path $args - } -} - - -# ------------------------------------------------------------- -# -# METHOD: delete entryPath ?entryPath2? -# -# If componentPathName is of component type MenuButton or -# Menu, delete operates on menus. If componentPathName is of -# component type Entry, delete operates on menu entries. -# -# This command deletes all components between com- -# ponentPathName and componentPathName2 inclusive. If com- -# ponentPathName2 is omitted then it defaults to com- -# ponentPathName. Returns an empty string. -# -# If componentPathName is of type Menubar, then all menus -# and the menu bar frame will be destroyed. In this case com- -# ponentPathName2 is ignored. -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::delete { args } { - - # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, - # Handle out of bounds in arg lengths - # ''''''''''''''''''''''''''''''''''''''''''''''''''''' - if { [llength $args] > 0 && [llength $args] <=2 } { - - # Path Conversions - # ''''''''''''''''''''''''''''''''''''''''''''''''''''' - set path [_parsePath [lindex $args 0]] - - set pathOrIndex $_pathMap($path) - - # Menu Entry - # ''''''''''''''''''''''''''''''''''''''''''''''''''''' - if { [regexp {^[0-9]+$} $pathOrIndex] } { - eval "_deleteEntry $args" - - # Menu - # ''''''''''''''''''''''''''''''''''''''''''''''''''''' - } else { - eval "_deleteMenu $args" - } - } else { - error "wrong # args: should be \ - \"$itk_component(hull) delete pathName ?pathName2?\"" - } - return "" -} - -# ------------------------------------------------------------- -# -# METHOD: index path -# -# If componentPathName is of type menubutton or menu, it -# returns the position of the menu/menubutton on the Menubar -# frame. -# -# If componentPathName is of type command, separator, -# radiobutton, checkbutton, or cascade, it returns the menu -# widget's numerical index for the entry corresponding to com- -# ponentPathName. If path is not found or the Menubar frame is -# passed in, -1 is returned. -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::index { path } { - - # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, - # Path conversions - # ''''''''''''''''''''''''''''''''''''''''''''''''''''' - if { [catch {set fullPath [_parsePath $path]} ] } { - return -1 - } - if { [catch {set tkPathOrIndex $_pathMap($fullPath)} ] } { - return -1 - } - - # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, - # If integer, return the value, otherwise look up the menu position - # ''''''''''''''''''''''''''''''''''''''''''''''''''''' - if { [regexp {^[0-9]+$} $tkPathOrIndex] } { - set index $tkPathOrIndex - } else { - set index [lsearch [_getMenuList] $fullPath] - } - - return $index -} - -# ------------------------------------------------------------- -# -# METHOD: insert beforeComponent type name ?option value? -# -# Insert a new component named name before the component -# specified by componentPathName. -# -# If componentPathName is of type MenuButton or Menu, the -# new component inserted is of type Menu and given the name -# name. In this case valid option value pairs are those -# accepted by menubuttons. -# -# If componentPathName is of type Entry, the new com- -# ponent inserted is of type Entry and given the name name. In -# this case valid option value pairs are those accepted by -# menu entries. -# -# name cannot be one of the keywords last, menu, end. -# dditionally, it may not be a number. However the com- -# ponentPathName may be referenced in this manner (see discus- -# sion of Component Path Names). -# -# Returns -1 if the menubar frame is passed in. -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::insert { beforeComponent type name args } { - if ![regexp \ - {^(menubutton|command|cascade|separator|radiobutton|checkbutton)$} \ - $type] { - error "bad type \"$type\": must be one of the following:\ - \"command\", \"checkbutton\", \"radiobutton\",\ - \"separator\", \"cascade\", or \"menubutton\"" - } - regexp {[^.]+$} $name segName - if [regexp {^(menu|last|end|[0-9]+)$} $segName] { - error "bad name \"$name\": user created component \ - path names may not end with \ - \"end\", \"last\", \"menu\", \ - or be an integer" - } - - set beforeComponent [_parsePath $beforeComponent] - - # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, - # Choose menu insertion or entry insertion - # ''''''''''''''''''''''''''''''''''''''''''''''''''''' - if { $type == "menubutton" } { - eval _insertMenuButton $beforeComponent $name $args - } else { - eval _insertEntry $beforeComponent $type $name $args - } -} - - -# ------------------------------------------------------------- -# -# METHOD: invoke entryPath -# -# Invoke the action of the menu entry denoted by -# entryComponentPathName. See the sections on the individual -# entries in the menu(n) man pages. If the menu entry is dis- -# abled then nothing happens. If the entry has a command -# associated with it then the result of that command is -# returned as the result of the invoke widget command. Other- -# wise the result is an empty string. -# -# If componentPathName is not a menu entry, an error is -# issued. -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::invoke { entryPath } { - - # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, - # Path Conversions - # ''''''''''''''''''''''''''''''''''''''''''''''''''''' - set entryPath [_parsePath $entryPath] - set index $_pathMap($entryPath) - - # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, - # Error Processing - # ''''''''''''''''''''''''''''''''''''''''''''''''''''' - # first verify that beforeEntryPath is actually a path to - # an entry and not to menu, menubutton, etc. - if { ! [regexp {^[0-9]+$} $index] } { - error "bad entry path: beforeEntryPath is not an entry" - } - - # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, - # Call invoke command - # ''''''''''''''''''''''''''''''''''''''''''''''''''''' - # get the tk menu path to call - set tkMenuPath [_entryPathToTkMenuPath $entryPath] - - # call the menu's invoke command, adjusting index based on tearoff - $tkMenuPath invoke [_getTkIndex $tkMenuPath $index] -} - -# ------------------------------------------------------------- -# -# METHOD: menucget componentPath option -# -# Returns the current value of the configuration option -# given by option. The component type of componentPathName -# determines the valid available options. -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::menucget { path opt } { - return [lindex [menuconfigure $path $opt] 4] -} - -# ------------------------------------------------------------- -# -# METHOD: menuconfigure componentPath ?option? ?value option value...? -# -# Query or modify the configuration options of the sub- -# component of the Menubar specified by componentPathName. If -# no option is specified, returns a list describing all of the -# available options for componentPathName (see -# Tk_ConfigureInfo for information on the format of this -# list). If option is specified with no value, then the com- -# mand returns a list describing the one named option (this -# list will be identical to the corresponding sublist of the -# value returned if no option is specified). If one or more -# option-value pairs are specified, then the command modifies -# the given widget option(s) to have the given value(s); in -# this case the command returns an empty string. The component -# type of componentPathName determines the valid available -# options. -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::menuconfigure { path args } { - - # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, - # Path Conversions - # ''''''''''''''''''''''''''''''''''''''''''''''''''''' - set path [_parsePath $path] - set tkPathOrIndex $_pathMap($path) - - # Case: Menu entry being configured - # ''''''''''''''''''''''''''''''''''''''''''''''''''''' - if { [regexp {^[0-9]+$} $tkPathOrIndex] } { - eval "_configureMenuEntry $path $tkPathOrIndex $args" - - # Case: Menu (button and pane) being configured. - # ''''''''''''''''''''''''''''''''''''''''''''''''''''' - } else { - eval _configureMenu $path $tkPathOrIndex $args - } -} - -# ------------------------------------------------------------- -# -# METHOD: path -# -# SYNOPIS: path ?? -# -# Returns a fully formed component path that matches pat- -# tern. If no match is found it returns -1. The mode argument -# indicates how the search is to be matched against pattern -# and it must have one of the following values: -# -# -glob Pattern is a glob-style pattern which is -# matched against each component path using the same rules as -# the string match command. -# -# -regexp Pattern is treated as a regular expression -# and matched against each component path using the same -# rules as the regexp command. -# -# The default mode is -glob. -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::path { args } { - - set len [llength $args] - if { $len < 1 || $len > 2 } { - error "wrong # args: should be \ - \"$itk_component(hull) path ?mode?> \"" - } - - set pathList [array names _pathMap] - - set len [llength $args] - switch -- $len { - 1 { - # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, - # Case: no search modes given - # ''''''''''''''''''''''''''''''''''''''''''''''''''''' - set pattern [lindex $args 0] - set found [lindex $pathList [lsearch -glob $pathList $pattern]] - } - 2 { - # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, - # Case: search modes present (-glob, -regexp) - # ''''''''''''''''''''''''''''''''''''''''''''''''''''' - set options [lindex $args 0] - set pattern [lindex $args 1] - set found \ - [lindex $pathList [lsearch $options $pathList $pattern]] - } - default { - # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, - # Case: wrong # arguments - # ''''''''''''''''''''''''''''''''''''''''''''''''''''' - error "wrong # args: \ - should be \"$itk_component(hull) path ?-glob? ?-regexp? pattern\"" - } - } - - return $found -} - -# ------------------------------------------------------------- -# -# METHOD: type path -# -# Returns the type of the component given by entryCom- -# ponentPathName. For menu entries, this is the type argument -# passed to the add/insert widget command when the entry was -# created, such as command or separator. Othewise it is either -# a menubutton or a menu. -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::type { path } { - - # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, - # Path Conversions - # ''''''''''''''''''''''''''''''''''''''''''''''''''''' - set path [_parsePath $path] - - # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, - # Error Handling: does the path exist? - # ''''''''''''''''''''''''''''''''''''''''''''''''''''' - if { [catch {set index $_pathMap($path)} ] } { - error "bad path \"$path\"" - } - - # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, - # ENTRY, Ask TK for type - # ''''''''''''''''''''''''''''''''''''''''''''''''''''' - if { [regexp {^[0-9]+$} $index] } { - # get the menu path from the entry path name - set tkMenuPath [_entryPathToTkMenuPath $path] - - # call the menu's type command, adjusting index based on tearoff - set type [$tkMenuPath type [_getTkIndex $tkMenuPath $index]] - # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, - # MENUBUTTON, MENU, or FRAME - # ''''''''''''''''''''''''''''''''''''''''''''''''''''' - } else { - # should not happen, but have a path that is not a valid window. - if { [catch {set className [winfo class $_pathMap($path)]}] } { - error "serious error: \"$path\" is not a valid window" - } - # get the classname, look it up, get index, us it to look up type - set type [ lindex \ - {frame menubutton menu} \ - [lsearch { Frame Menubutton Menu } $className] \ - ] - } - return $type -} - -# ------------------------------------------------------------- -# -# METHOD: yposition entryPath -# -# Returns a decimal string giving the y-coordinate within -# the menu window of the topmost pixel in the entry specified -# by componentPathName. If the componentPathName is not an -# entry, an error is issued. -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::yposition { entryPath } { - - # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, - # Path Conversions - # ''''''''''''''''''''''''''''''''''''''''''''''''''''' - set entryPath [_parsePath $entryPath] - set index $_pathMap($entryPath) - - # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, - # Error Handling - # ''''''''''''''''''''''''''''''''''''''''''''''''''''' - # first verify that entryPath is actually a path to - # an entry and not to menu, menubutton, etc. - if { ! [regexp {^[0-9]+$} $index] } { - error "bad value: entryPath is not an entry" - } - - # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, - # Call yposition command - # ''''''''''''''''''''''''''''''''''''''''''''''''''''' - # get the menu path from the entry path name - set tkMenuPath [_entryPathToTkMenuPath $entryPath] - - # call the menu's yposition command, adjusting index based on tearoff - return [$tkMenuPath yposition [_getTkIndex $tkMenuPath $index]] - -} - -# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -# PARSING METHODS -# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -# ------------------------------------------------------------- -# -# PARSING METHOD: menubutton -# -# This method is invoked via an evaluation of the -menubuttons -# option for the Menubar. -# -# It adds a new menubutton and processes any -menu options -# for creating entries on the menu pane associated with the -# menubutton -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::menubutton { menuName args } { - eval "add menubutton .$menuName $args" -} - -# ------------------------------------------------------------- -# -# PARSING METHOD: options -# -# This method is invoked via an evaluation of the -menu -# option for menubutton commands. -# -# It configures the current menu ($_ourMenuPath) with the options -# that follow (args) -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::options { args } { - eval "$_tkMenuPath configure $args" -} - - -# ------------------------------------------------------------- -# -# PARSING METHOD: command -# -# This method is invoked via an evaluation of the -menu -# option for menubutton commands. -# -# It adds a new command entry to the current menu, $_ourMenuPath -# naming it $cmdName. Since this is the most common case when -# creating menus, streamline it by duplicating some code from -# the add{} method. -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::command { cmdName args } { - set path $_ourMenuPath.$cmdName - - # error checking - regsub {.*[.]} $path "" segName - if [regexp {^(menu|last|end|[0-9]+)$} $segName] { - error "bad name \"$segName\": user created component \ - path names may not end with \ - \"end\", \"last\", \"menu\", \ - or be an integer" - } - - eval _addEntry command $path $args -} - -# ------------------------------------------------------------- -# -# PARSING METHOD: checkbutton -# -# This method is invoked via an evaluation of the -menu -# option for menubutton/cascade commands. -# -# It adds a new checkbutton entry to the current menu, $_ourMenuPath -# naming it $chkName. -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::checkbutton { chkName args } { - eval "add checkbutton $_ourMenuPath.$chkName $args" -} - -# ------------------------------------------------------------- -# -# PARSING METHOD: radiobutton -# -# This method is invoked via an evaluation of the -menu -# option for menubutton/cascade commands. -# -# It adds a new radiobutton entry to the current menu, $_ourMenuPath -# naming it $radName. -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::radiobutton { radName args } { - eval "add radiobutton $_ourMenuPath.$radName $args" -} - -# ------------------------------------------------------------- -# -# PARSING METHOD: separator -# -# This method is invoked via an evaluation of the -menu -# option for menubutton/cascade commands. -# -# It adds a new separator entry to the current menu, $_ourMenuPath -# naming it $sepName. -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::separator { sepName args } { - eval $_tkMenuPath add separator - set _pathMap($_ourMenuPath.$sepName) [_getPdIndex $_tkMenuPath end] -} - -# ------------------------------------------------------------- -# -# PARSING METHOD: cascade -# -# This method is invoked via an evaluation of the -menu -# option for menubutton/cascade commands. -# -# It adds a new cascade entry to the current menu, $_ourMenuPath -# naming it $casName. It processes the -menu option if present, -# adding a new menu pane and its associated entries found. -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::cascade { casName args } { - - # Save the current menu we are adding to, cascade can change - # the current menu through -menu options. - set saveOMP $_ourMenuPath - set saveTKP $_tkMenuPath - - eval "add cascade $_ourMenuPath.$casName $args" - - # Restore the saved menu states so that the next entries of - # the -menu/-menubuttons we are processing will be at correct level. - set _ourMenuPath $saveOMP - set _tkMenuPath $saveTKP -} - -# ... A P I S U P P O R T M E T H O D S... - -# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -# MENU ADD, INSERT, DELETE -# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -# ------------------------------------------------------------- -# -# PRIVATE METHOD: _addMenuButton -# -# Makes a new menubutton & associated -menu, pack appended -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::_addMenuButton { buttonName args} { - - eval "_makeMenuButton $buttonName $args" - - #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, - # Pack at end, adjust for help buttonName - # '''''''''''''''''''''''''''''''''' - if { $buttonName == "help" } { - pack $itk_component($buttonName) -side right - } else { - pack $itk_component($buttonName) -side left - } - - return $itk_component($buttonName) -} - -# ------------------------------------------------------------- -# -# PRIVATE METHOD: _insertMenuButton -# -# inserts a menubutton named $buttonName on a menu bar before -# another menubutton specified by $beforeMenuPath -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::_insertMenuButton { beforeMenuPath buttonName args} { - - eval "_makeMenuButton $buttonName $args" - - #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, - # Pack before the $beforeMenuPath - # '''''''''''''''''''''''''''''''' - set beforeTkMenu $_pathMap($beforeMenuPath) - regsub {[.]menu$} $beforeTkMenu "" beforeTkMenu - pack $itk_component(menubar).$buttonName \ - -side left \ - -before $beforeTkMenu - - return $itk_component($buttonName) -} - -# ------------------------------------------------------------- -# -# PRIVATE METHOD: _makeMenuButton -# -# creates a menubutton named buttonName on the menubar with args. -# The -menu option if present will trigger attaching a menu pane. -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::_makeMenuButton {buttonName args} { - - #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, - # Capture the -menu option if present - # ''''''''''''''''''''''''''''''''''' - array set temp $args - if { [::info exists temp(-menu)] } { - # We only keep this in case of menuconfigure or menucget - set _menuOption(.$buttonName) $temp(-menu) - set menuEvalStr $temp(-menu) - } else { - set menuEvalStr {} - } - - # attach the actual menu widget to the menubutton's arg list - set temp(-menu) $itk_component(menubar).$buttonName.menu - set args [array get temp] - - #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, - # Create menubutton component - # '''''''''''''''''''''''''''''''' - itk_component add $buttonName { - eval ::menubutton \ - $itk_component(menubar).$buttonName \ - $args - } { - keep \ - -activebackground \ - -activeforeground \ - -anchor \ - -background \ - -borderwidth \ - -cursor \ - -disabledforeground \ - -font \ - -foreground \ - -highlightbackground \ - -highlightcolor \ - -highlightthickness \ - -justify \ - -padx \ - -pady \ - -wraplength - } - - set _pathMap(.$buttonName) $itk_component($buttonName) - - _makeMenu \ - $buttonName-menu \ - $itk_component($buttonName).menu \ - .$buttonName \ - $menuEvalStr - - return $itk_component($buttonName) - -} - -# ------------------------------------------------------------- -# -# PRIVATE METHOD: _makeMenu -# -# Creates a menu. -# It then evaluates the $menuEvalStr to create entries on the menu. -# -# Assumes the existence of $itk_component($buttonName) -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::_makeMenu \ - { componentName widgetName menuPath menuEvalStr } { - - #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, - # Create menu component - # '''''''''''''''''''''''''''''''' - itk_component add $componentName { - ::menu $widgetName - } { - keep \ - -activebackground \ - -activeborderwidth \ - -activeforeground \ - -background \ - -borderwidth \ - -cursor \ - -disabledforeground \ - -font \ - -foreground - } - - set _pathMap($menuPath.menu) $itk_component($componentName) - - #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, - # Attach help handler to this menu - # '''''''''''''''''''''''''''''''' - bind $itk_component($componentName) <> \ - [itcl::code $this _helpHandler $menuPath.menu] - - #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, - # Handle -menu - #''''''''''''''''''''''''''''''''' - set _ourMenuPath $menuPath - set _tkMenuPath $itk_component($componentName) - - # - # A zero parseLevel says we are at the top of the parse tree, - # so get the context scope level and do a subst for the menuEvalStr. - # - if { $_parseLevel == 0 } { - set _callerLevel [_getCallerLevel] - } - - # - # bump up the parse level, so if we get called via the 'eval $menuEvalStr' - # we know to skip the above steps... - # - incr _parseLevel - eval $menuEvalStr - - # - # leaving, so done with this parse level, so bump it back down - # - incr _parseLevel -1 -} - -# ------------------------------------------------------------- -# -# PRIVATE METHOD: _substEvalStr -# -# This performs the substitution and evaluation of $ [], \ found -# in the -menubutton/-menus options -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::_substEvalStr { evalStr } { - upvar $evalStr evalStrRef - set evalStrRef [uplevel $_callerLevel [list subst $evalStrRef]] -} - - -# ------------------------------------------------------------- -# -# PRIVATE METHOD: _deleteMenu -# -# _deleteMenu menuPath ?menuPath2? -# -# deletes menuPath or from menuPath to menuPath2 -# -# Menu paths may be formed in one of two ways -# .MENUBAR.menuName where menuName is the name of the menu -# .MENUBAR.menuName.menu where menuName is the name of the menu -# -# The basic rule is '.menu' is not needed. -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::_deleteMenu { menuPath {menuPath2 {}} } { - - if { $menuPath2 == "" } { - # get a corrected path (subst for number, last, end) - set path [_parsePath $menuPath] - - _deleteAMenu $path - - } else { - # gets the list of menus in interface order - set menuList [_getMenuList] - - # ... get the start menu and the last menu ... - - # get a corrected path (subst for number, last, end) - set menuStartPath [_parsePath $menuPath] - - regsub {[.]menu$} $menuStartPath "" menuStartPath - - set menuEndPath [_parsePath $menuPath2] - - regsub {[.]menu$} $menuEndPath "" menuEndPath - - # get the menu position (0 based) of the start and end menus. - set start [lsearch -exact $menuList $menuStartPath] - if { $start == -1 } { - error "bad menu path \"$menuStartPath\": \ - should be one of $menuList" - } - set end [lsearch -exact $menuList $menuEndPath] - if { $end == -1 } { - error "bad menu path \"$menuEndPath\": \ - should be one of $menuList" - } - - # now create the list from this range of menus - set delList [lrange $menuList $start $end] - - # walk thru them deleting each menu. - # this list has no .menu on the end. - foreach m $delList { - _deleteAMenu $m.menu - } - } -} - -# ------------------------------------------------------------- -# -# PRIVATE METHOD: _deleteAMenu -# -# _deleteMenu menuPath -# -# deletes a single Menu (menubutton and menu pane with entries) -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::_deleteAMenu { path } { - - # We will normalize the path to not include the '.menu' if - # it is on the path already. - - regsub {[.]menu$} $path "" menuButtonPath - regsub {.*[.]} $menuButtonPath "" buttonName - - # Loop through and destroy any cascades, etc on menu. - set entryList [_getEntryList $menuButtonPath] - foreach entry $entryList { - _deleteEntry $entry - } - - # Delete the menubutton and menu components... - destroy $itk_component($buttonName-menu) - destroy $itk_component($buttonName) - - # This is because of some itcl bug that doesn't delete - # the component on the destroy in some cases... - catch {itk_component delete $buttonName-menu} - catch {itk_component delete $buttonName} - - # unset our paths - _unsetPaths $menuButtonPath - -} - -# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -# ENTRY ADD, INSERT, DELETE -# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -# ------------------------------------------------------------- -# -# PRIVATE METHOD: _addEntry -# -# Adds an entry to menu. -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::_addEntry { type path args } { - - # Error Checking - # '''''''''''''' - # the path should not end with '.menu' - # Not needed -- already checked by add{} - # if { [regexp {[.]menu$} $path] } { - # error "bad entry path: \"$path\". \ - # The name \"menu\" is reserved for menu panes" - # } - - # get the tkMenuPath - set tkMenuPath [_entryPathToTkMenuPath $path] - if { $tkMenuPath == "" } { - error "bad entry path: \"$path\". The menu path prefix is not valid" - } - - # get the -helpstr option if present - array set temp $args - if { [::info exists temp(-helpstr)] } { - set helpStr $temp(-helpstr) - unset temp(-helpstr) - } else { - set helpStr {} - } - set args [array get temp] - - # Handle CASCADE - # '''''''''''''' - # if this is a cascade go ahead and add in the menu... - if { $type == "cascade" } { - eval [list _addCascade $tkMenuPath $path] $args - # Handle Non-CASCADE - # '''''''''''''''''' - } else { - # add the entry if one doesn't already exist with the same - # command name - if [::info exists _pathMap($path)] { - set cmdname [lindex [split $path .] end] - error "Cannot add $type \"$cmdname\". A menu item already\ - exists with this name." - } - eval [list $tkMenuPath add $type] $args - set _pathMap($path) [_getPdIndex $tkMenuPath end] - } - - # Remember the help string - set _helpString($path) $helpStr - - return $_pathMap($path) -} - -# ------------------------------------------------------------- -# -# PRIVATE METHOD: _addCascade -# -# Creates a cascade button. Handles the -menu option -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::_addCascade { tkMenuPath path args } { - - # get the cascade name from our path - regsub {.*[.]} $path "" cascadeName - - #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, - # Capture the -menu option if present - # ''''''''''''''''''''''''''''''''''' - array set temp $args - if { [::info exists temp(-menu)] } { - set menuEvalStr $temp(-menu) - } else { - set menuEvalStr {} - } - - # attach the menu pane - set temp(-menu) $tkMenuPath.$cascadeName - set args [array get temp] - - # Create the cascade entry - eval $tkMenuPath add cascade $args - - # Keep the -menu string in case of menuconfigure or menucget - if { $menuEvalStr != "" } { - set _menuOption($path) $menuEvalStr - } - - # update our pathmap - set _pathMap($path) [_getPdIndex $tkMenuPath end] - - _makeMenu \ - $cascadeName-menu \ - $tkMenuPath.$cascadeName \ - $path \ - $menuEvalStr - - #return $itk_component($cascadeName) - -} - -# ------------------------------------------------------------- -# -# PRIVATE METHOD: _insertEntry -# -# inserts an entry on a menu before entry given by beforeEntryPath. -# The added entry is of type TYPE and its name is NAME. ARGS are -# passed for customization of the entry. -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::_insertEntry { beforeEntryPath type name args } { - - # convert entryPath to an index value - set bfIndex $_pathMap($beforeEntryPath) - - # first verify that beforeEntryPath is actually a path to - # an entry and not to menu, menubutton, etc. - if { ! [regexp {^[0-9]+$} $bfIndex] } { - error "bad entry path: $beforeEntryPath is not an entry" - } - - # get the menu path from the entry path name - regsub {[.][^.]*$} $beforeEntryPath "" menuPathPrefix - set tkMenuPath $_pathMap($menuPathPrefix.menu) - - # If this entry already exists in the path map, throw an error. - if [::info exists _pathMap($menuPathPrefix.$name)] { - error "Cannot insert $type \"$name\". A menu item already\ - exists with this name." - } - - # INDEX is zero based at this point. - - # ENTRIES is a zero based list... - set entries [_getEntryList $menuPathPrefix] - - # - # Adjust the entries after the inserted item, to have - # the correct index numbers. Note, we stay zero based - # even though tk flips back and forth depending on tearoffs. - # - for {set i $bfIndex} {$i < [llength $entries]} {incr i} { - # path==entry path in numerical order - set path [lindex $entries $i] - - # add one to each entry after the inserted one. - set _pathMap($path) [expr {$i + 1}] - } - - # get the -helpstr option if present - array set temp $args - if { [::info exists temp(-helpstr)] } { - set helpStr $temp(-helpstr) - unset temp(-helpstr) - } else { - set helpStr {} - } - set args [array get temp] - - set path $menuPathPrefix.$name - - # Handle CASCADE - # '''''''''''''' - # if this is a cascade go ahead and add in the menu... - if { [string match cascade $type] } { - - if { [ catch {eval "_insertCascade \ - $bfIndex $tkMenuPath $path $args"} errMsg ]} { - for {set i $bfIndex} {$i < [llength $entries]} {incr i} { - # path==entry path in numerical order - set path [lindex $entries $i] - - # sub the one we added earlier. - set _pathMap($path) [expr {$_pathMap($path) - 1}] - # @@ delete $hs - } - error $errMsg - } - - # Handle Entry - # '''''''''''''' - } else { - - # give us a zero or 1-based index based on tear-off menu status - # invoke the menu's insert command - if { [catch {eval "$tkMenuPath insert \ - [_getTkIndex $tkMenuPath $bfIndex] $type $args"} errMsg]} { - for {set i $bfIndex} {$i < [llength $entries]} {incr i} { - # path==entry path in numerical order - set path [lindex $entries $i] - - # sub the one we added earlier. - set _pathMap($path) [expr {$_pathMap($path) - 1}] - # @@ delete $hs - } - error $errMsg - } - - - # add the helpstr option to our options list (attach to entry) - set _helpString($path) $helpStr - - # Insert the new entry path into pathmap giving it an index value - set _pathMap($menuPathPrefix.$name) $bfIndex - - } - - return [_getTkIndex $tkMenuPath $bfIndex] -} - -# ------------------------------------------------------------- -# -# PRIVATE METHOD: _insertCascade -# -# Creates a cascade button. Handles the -menu option -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::_insertCascade { bfIndex tkMenuPath path args } { - - # get the cascade name from our path - regsub {.*[.]} $path "" cascadeName - - #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, - # Capture the -menu option if present - # ''''''''''''''''''''''''''''''''''' - array set temp $args - if { [::info exists temp(-menu)] } { - # Keep the -menu string in case of menuconfigure or menucget - set _menuOption($path) $temp(-menu) - set menuEvalStr $temp(-menu) - } else { - set menuEvalStr {} - } - - # attach the menu pane - set temp(-menu) $tkMenuPath.$cascadeName - set args [array get temp] - - # give us a zero or 1-based index based on tear-off menu status - # invoke the menu's insert command - eval "$tkMenuPath insert \ - [_getTkIndex $tkMenuPath $bfIndex] cascade $args" - - # Insert the new entry path into pathmap giving it an index value - set _pathMap($path) $bfIndex - _makeMenu \ - $cascadeName-menu \ - $tkMenuPath.$cascadeName \ - $path \ - $menuEvalStr - - #return $itk_component($cascadeName) -} - -# ------------------------------------------------------------- -# -# PRIVATE METHOD: _deleteEntry -# -# _deleteEntry entryPath ?entryPath2? -# -# either -# deletes the entry entryPath -# or -# deletes the entries from entryPath to entryPath2 -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::_deleteEntry { entryPath {entryPath2 {}} } { - - if { $entryPath2 == "" } { - # get a corrected path (subst for number, last, end) - set path [_parsePath $entryPath] - - set entryIndex $_pathMap($path) - if { $entryIndex == -1 } { - error "bad value for pathName: \ - $entryPath in call to delet" - } - - # get the type, if cascade, we will want to delete menu - set type [type $path] - - # ... munge up the menu name ... - - # the tkMenuPath is looked up with the .menu added to lookup - # strip off the entry component - regsub {[.][^.]*$} $path "" menuPath - set tkMenuPath $_pathMap($menuPath.menu) - - # get the ordered entry list - set entries [_getEntryList $menuPath] - - # ... Fix up path entry indices ... - - # delete the path from the map - unset _pathMap([lindex $entries $entryIndex]) - - # Subtract off 1 for each entry below the deleted one. - for {set i [expr {$entryIndex + 1}]} \ - {$i < [llength $entries]} \ - {incr i} { - set epath [lindex $entries $i] - incr _pathMap($epath) -1 - } - - # ... Delete the menu entry widget ... - - # delete the menu entry, ajusting index for TK - $tkMenuPath delete [_getTkIndex $tkMenuPath $entryIndex] - - if { $type == "cascade" } { - regsub {.*[.]} $path "" cascadeName - destroy $itk_component($cascadeName-menu) - - # This is because of some itcl bug that doesn't delete - # the component on the destroy in some cases... - catch {itk_component delete $cascadeName-menu} - - _unsetPaths $path - } - - } else { - # get a corrected path (subst for number, last, end) - set path1 [_parsePath $entryPath] - set path2 [_parsePath $entryPath2] - - set fromEntryIndex $_pathMap($path1) - if { $fromEntryIndex == -1 } { - error "bad value for entryPath1: \ - $entryPath in call to delet" - } - set toEntryIndex $_pathMap($path2) - if { $toEntryIndex == -1 } { - error "bad value for entryPath2: \ - $entryPath2 in call to delet" - } - # ... munge up the menu name ... - - # the tkMenuPath is looked up with the .menu added to lookup - # strip off the entry component - regsub {[.][^.]*$} $path1 "" menuPath - set tkMenuPath $_pathMap($menuPath.menu) - - # get the ordered entry list - set entries [_getEntryList $menuPath] - - # ... Fix up path entry indices ... - - # delete the range from the pathMap list - for {set i $fromEntryIndex} {$i <= $toEntryIndex} {incr i} { - unset _pathMap([lindex $entries $i]) - } - - # Subtract off 1 for each entry below the deleted range. - # Loop from one below the bottom delete entry to end list - for {set i [expr {$toEntryIndex + 1}]} \ - {$i < [llength $entries]} \ - {incr i} { - # take this path and sets its index back by size of - # deleted range. - set path [lindex $entries $i] - set _pathMap($path) \ - [expr {$_pathMap($path) - \ - (($toEntryIndex - $fromEntryIndex) + 1)}] - } - - # ... Delete the menu entry widget ... - - # delete the menu entry, ajusting index for TK - $tkMenuPath delete \ - [_getTkIndex $tkMenuPath $fromEntryIndex] \ - [_getTkIndex $tkMenuPath $toEntryIndex] - - } -} - -# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -# CONFIGURATION SUPPORT -# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -# ------------------------------------------------------------- -# -# PRIVATE METHOD: _configureMenu -# -# This configures a menu. A menu is a true tk widget, thus we -# pass the tkPath variable. This path may point to either a -# menu button (does not end with the name 'menu', or a menu -# which ends with the name 'menu' -# -# path : our Menubar path name to this menu button or menu pane. -# if we end with the name '.menu' then it is a menu pane. -# tkPath : the path to the corresponding Tk menubutton or menu. -# args : the args for configuration -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::_configureMenu { path tkPath {option {}} args } { - - set class [winfo class $tkPath] - - if { $option == "" } { - # No arguments: return all options - set configList [$tkPath configure] - - if { [info exists _menuOption($path)] } { - lappend configList [list -menu menu Menu {} $_menuOption($path)] - } else { - lappend configList [list -menu menu Menu {} {}] - } - if { [info exists _helpString($path)] } { - lappend configList [list -helpstr helpStr HelpStr {} \ - $_helpString($path)] - } else { - lappend configList [list -helpstr helpStr HelpStr {} {}] - } - return $configList - - } elseif {$args == "" } { - if { $option == "-menu" } { - if { [info exists _menuOption($path)] } { - return [list -menu menu Menu {} $_menuOption($path)] - } else { - return [list -menu menu Menu {} {}] - } - } elseif { $option == "-helpstr" } { - if { [info exists _helpString($path)] } { - return [list -helpstr helpStr HelpStr {} $_helpString($path)] - } else { - return [list -helpstr helpStr HelpStr {} {}] - } - } else { - # ... OTHERWISE, let Tk get it. - return [$tkPath configure $option] - } - } else { - set args [concat $option $args] - - # If this is a menubutton, and has -menu option, process it - if { $class == "Menubutton" && [regexp -- {-menu} $args] } { - eval _configureMenuOption menubutton $path $args - } else { - eval $tkPath configure $args - } - return "" - } -} - -# ------------------------------------------------------------- -# -# PRIVATE METHOD: _configureMenuOption -# -# Allows for configuration of the -menu option on -# menubuttons and cascades -# -# find out if we are the last menu, or are before one. -# delete the old menu. -# if we are the last, then add us back at the end -# if we are before another menu, get the beforePath -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::_configureMenuOption { type path args } { - - regsub {[.][^.]*$} $path "" pathPrefix - - if { $type == "menubutton" } { - set menuList [_getMenuList] - set pos [lsearch $menuList $path] - if { $pos == ([llength $menuList] - 1) } { - set insert false - } else { - set insert true - } - } elseif { $type == "cascade" } { - set lastEntryPath [_parsePath $pathPrefix.last] - if { $lastEntryPath == $path } { - set insert false - } else { - set insert true - } - set pos [index $path] - - } - - - eval "delete $pathPrefix.$pos" - if { $insert } { - # get name from path... - regsub {.*[.]} $path "" name - - eval insert $pathPrefix.$pos $type \ - $name $args - } else { - eval add $type $path $args - } -} - -# ------------------------------------------------------------- -# -# PRIVATE METHOD: _configureMenuEntry -# -# This configures a menu entry. A menu entry is either a command, -# radiobutton, separator, checkbutton, or a cascade. These have -# a corresponding Tk index value for the corresponding tk menu -# path. -# -# path : our Menubar path name to this menu entry. -# index : the t -# args : the args for configuration -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::_configureMenuEntry { path index {option {}} args } { - - set type [type $path] - - # set len [llength $args] - - # get the menu path from the entry path name - set tkMenuPath [_entryPathToTkMenuPath $path] - - if { $option == "" } { - set configList [$tkMenuPath entryconfigure \ - [_getTkIndex $tkMenuPath $index]] - - if { $type == "cascade" } { - if { [info exists _menuOption($path)] } { - lappend configList [list -menu menu Menu {} \ - $_menuOption($path)] - } else { - lappend configList [list -menu menu Menu {} {}] - } - } - if { [info exists _helpString($path)] } { - lappend configList [list -helpstr helpStr HelpStr {} \ - $_helpString($path)] - } else { - lappend configList [list -helpstr helpStr HelpStr {} {}] - } - return $configList - - } elseif { $args == "" } { - if { $option == "-menu" } { - if { [info exists _menuOption($path)] } { - return [list -menu menu Menu {} $_menuOption($path)] - } else { - return [list -menu menu Menu {} {}] - } - } elseif { $option == "-helpstr" } { - if { [info exists _helpString($path)] } { - return [list -helpstr helpStr HelpStr {} \ - $_helpString($path)] - } else { - return [list -helpstr helpStr HelpStr {} {}] - } - } else { - # ... OTHERWISE, let Tk get it. - return [$tkMenuPath entryconfigure \ - [_getTkIndex $tkMenuPath $index] $option] - } - } else { - array set temp [concat $option $args] - - # ... Store -helpstr val,strip out -helpstr val from args - if { [::info exists temp(-helpstr)] } { - set _helpString($path) $temp(-helpstr) - unset temp(-helpstr) - } - - set args [array get temp] - if { $type == "cascade" && [::info exists temp(-menu)] } { - eval "_configureMenuOption cascade $path $args" - } else { - # invoke the menu's entryconfigure command - # being careful to ajust the INDEX to be 0 or 1 based - # depending on the tearoff status - # if the stripping process brought us down to no options - # to set, then forget the configure of widget. - if { [llength $args] != 0 } { - eval $tkMenuPath entryconfigure \ - [_getTkIndex $tkMenuPath $index] $args - } - } - return "" - } -} - -# ------------------------------------------------------------- -# -# PRIVATE METHOD: _unsetPaths -# -# comment -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::_unsetPaths { parent } { - - # first get the complete list of all menu paths - set pathList [array names _pathMap] - - # for each path that matches parent prefix, unset it. - foreach path $pathList { - if { [regexp [subst -nocommands {^$parent}] $path] } { - unset _pathMap($path) - } - } -} - -# ------------------------------------------------------------- -# -# PRIVATE METHOD: _entryPathToTkMenuPath -# -# Takes an entry path like .mbar.file.new and changes it to -# .mbar.file.menu and performs a lookup in the pathMap to -# get the corresponding menu widget name for tk -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::_entryPathToTkMenuPath {entryPath} { - - # get the menu path from the entry path name - # by stripping off the entry component of the path - regsub {[.][^.]*$} $entryPath "" menuPath - - # the tkMenuPath is looked up with the .menu added to lookup - if { [catch {set tkMenuPath $_pathMap($menuPath.menu)}] } { - return "" - } else { - return $_pathMap($menuPath.menu) - } -} - - -# ------------------------------------------------------------- -# -# These two methods address the issue of menu entry indices being -# zero-based when the menu is not a tearoff menu and 1-based when -# it is a tearoff menu. Our strategy is to hide this difference. -# -# _getTkIndex returns the index as tk likes it: 0 based for non-tearoff -# and 1 based for tearoff menus. -# -# _getPdIndex (get pulldown index) always returns it as 0 based. -# -# ------------------------------------------------------------- - -# ------------------------------------------------------------- -# -# PRIVATE METHOD: _getTkIndex -# -# give us a zero or 1-based answer depending on the tearoff -# status of the menu. If the menu denoted by tkMenuPath is a -# tearoff menu it returns a 1-based result, otherwise a -# zero-based result. -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::_getTkIndex { tkMenuPath tkIndex} { - - # if there is a tear off make it 1-based index - if { [$tkMenuPath cget -tearoff] } { - incr tkIndex - } - - return $tkIndex -} - -# ------------------------------------------------------------- -# -# PRIVATE METHOD: _getPdIndex -# -# Take a tk index and give me a zero based numerical index -# -# Ask the menu widget for the index of the entry denoted by -# 'tkIndex'. Then if the menu is a tearoff adjust the value -# to be zero based. -# -# This method returns the index as if tearoffs did not exist. -# Always returns a zero-based index. -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::_getPdIndex { tkMenuPath tkIndex } { - - # get the index from the tk menu - # this 0 based for non-tearoff and 1-based for tearoffs - set pdIndex [$tkMenuPath index $tkIndex] - - # if there is a tear off make it 0-based index - if { [$tkMenuPath cget -tearoff] } { - incr pdIndex -1 - } - - return $pdIndex -} - -# ------------------------------------------------------------- -# -# PRIVATE METHOD: _getMenuList -# -# Returns the list of menus in the order they are on the interface -# returned list is a list of our menu paths -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::_getMenuList { } { - # get the menus that are packed - set tkPathList [pack slaves $itk_component(menubar)] - - regsub -- {[.]} $itk_component(hull) "" mbName - regsub -all -- "\[.\]$mbName\[.\]menubar\[.\]" $tkPathList "." menuPathList - - return $menuPathList -} - -# ------------------------------------------------------------- -# -# PRIVATE METHOD: _getEntryList -# -# -# This method looks at a menupath and gets all the entries and -# returns a list of all the entry path names in numerical order -# based on their index values. -# -# MENU is the path to a menu, like .mbar.file.menu or .mbar.file -# we will calculate a menuPath from this: .mbar.file -# then we will build a list of entries in this menu excluding the -# path .mbar.file.menu -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::_getEntryList { menu } { - - # if it ends with menu, clip it off - regsub {[.]menu$} $menu "" menuPath - - # first get the complete list of all menu paths - set pathList [array names _pathMap] - - set numEntries 0 - # iterate over the pathList and put on menuPathList those - # that match the menuPattern - foreach path $pathList { - # if this path is on the menuPath's branch - if { [regexp [subst -nocommands {$menuPath[.][^.]*$}] $path] } { - # if not a menu itself - if { ! [regexp {[.]menu$} $path] } { - set orderedList($_pathMap($path)) $path - incr numEntries - } - } - } - set entryList {} - - for {set i 0} {$i < $numEntries} {incr i} { - lappend entryList $orderedList($i) - } - - return $entryList - -} - -# ------------------------------------------------------------- -# -# PRIVATE METHOD: _parsePath -# -# given path, PATH, _parsePath splits the path name into its -# component segments. It then puts the name back together one -# segment at a time and calls _getSymbolicPath to replace the -# keywords 'last' and 'end' as well as numeric digits. -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::_parsePath { path } { - set segments [split [string trimleft $path .] .] - - set concatPath "" - foreach seg $segments { - set concatPath [_getSymbolicPath $concatPath $seg] - if { [catch {set _pathMap($concatPath)} ] } { - error "bad path: \"$path\" does not exist. \"$seg\" not valid" - } - } - return $concatPath -} - -# ------------------------------------------------------------- -# -# PRIVATE METHOD: _getSymbolicPath -# -# Given a PATH, _getSymbolicPath looks for the last segment of -# PATH to contain: a number, the keywords last or end. If one -# of these it figures out how to get us the actual pathname -# to the searched widget -# -# Implementor's notes: -# Surely there is a shorter way to do this. The only diff -# for non-numeric is getting the llength of the correct list -# It is hard to know this upfront so it seems harder to generalize. -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::_getSymbolicPath { parent segment } { - - # if the segment is a number, then look it up positionally - # MATCH numeric index - if { [regexp {^[0-9]+$} $segment] } { - - # if we have no parent, then we area menubutton - if { $parent == {} } { - set returnPath [lindex [_getMenuList] $segment] - } else { - set returnPath [lindex [_getEntryList $parent.menu] $segment] - } - - # MATCH 'end' or 'last' keywords. - } elseif { $segment == "end" || $segment == "last" } { - - # if we have no parent, then we are a menubutton - if { $parent == {} } { - set returnPath [lindex [_getMenuList] end] - } else { - set returnPath [lindex [_getEntryList $parent.menu] end] - } - } else { - set returnPath $parent.$segment - } - - return $returnPath -} - -# ------------------------------------------------------------- -# -# PRIVATE METHOD: _helpHandler -# -# Bound to the event on a menu pane. This puts the -# help string associated with the menu entry into the -# status widget help area. If no help exists for the current -# entry, the status widget is cleared. -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::_helpHandler { menuPath } { - - if { $itk_option(-helpvariable) == {} } { - return - } - - set tkMenuWidget $_pathMap($menuPath) - - set entryIndex [$tkMenuWidget index active] - - # already on this item? - if { $entryIndex == $_entryIndex } { - return - } - - set _entryIndex $entryIndex - - if {"none" != $entryIndex} { - set entries [_getEntryList $menuPath] - - set menuEntryHit \ - [lindex $entries [_getPdIndex $tkMenuWidget $entryIndex]] - - # blank out the old one - set $itk_option(-helpvariable) {} - - # if there is a help string for this entry - if { [::info exists _helpString($menuEntryHit)] } { - set $itk_option(-helpvariable) $_helpString($menuEntryHit) - } - } else { - set $itk_option(-helpvariable) {} - set _entryIndex -1 - } -} - -# ------------------------------------------------------------- -# -# PRIVATE METHOD: _getCallerLevel -# -# Starts at stack frame #0 and works down till we either hit -# a ::Menubar stack frame or an ::itk::Archetype stack frame -# (the latter happens when a configure is called via the 'component' -# method -# -# Returns the level of the actual caller of the menubar command -# in the form of #num where num is the level number caller stack frame. -# -# ------------------------------------------------------------- -itcl::body iwidgets::Menubar::_getCallerLevel { } { - - set levelName {} - set levelsAreValid true - set level 0 - set callerLevel #$level - - while { $levelsAreValid } { - # Hit the end of the stack frame - if [catch {uplevel #$level {namespace current}}] { - set levelsAreValid false - set callerLevel #[expr {$level - 1}] - # still going - } else { - set newLevelName [uplevel #$level {namespace current}] - # See if we have run into the first ::Menubar level - if { $newLevelName == "::itk::Archetype" || \ - $newLevelName == "::iwidgets::Menubar" } { - # If so, we are done-- set the callerLevel - set levelsAreValid false - set callerLevel #[expr {$level - 1}] - } else { - set levelName $newLevelName - } - } - incr level - } - return $callerLevel -} - - -# -# The default tkMenuFind proc in menu.tcl only looks for menubuttons -# in frames. Since our menubuttons are within the Menubar class, the -# default proc won't find them during menu traversal. This proc -# redefines the default proc to remedy the problem. -#----------------------------------------------------------- -# BUG FIX: csmith (Chad Smith: csmith@adc.com), 3/30/99 -#----------------------------------------------------------- -# The line, "set qchild ..." below had a typo. It should be -# "info command $child" instead of "winfo command $child". -#----------------------------------------------------------- -proc tkMenuFind {w char} { - global tkPriv - set char [string tolower $char] - - # Added by csmith, 5/10/01, to fix a bug reported on the itcl mailing list. - if {$w == "."} { - foreach child [winfo child $w] { - set match [tkMenuFind $child $char] - if {$match != ""} { - return $match - } - } - return {} - } - - foreach child [winfo child $w] { - switch [winfo class $child] { - Menubutton { - set qchild [info command $child] - set char2 [string index [$qchild cget -text] \ - [$qchild cget -underline]] - if {([string compare $char [string tolower $char2]] == 0) - || ($char == "")} { - if {[$qchild cget -state] != "disabled"} { - return $child - } - } - } - Frame - - Menubar { - set match [tkMenuFind $child $char] - if {$match != ""} { - return $match - } - } - } - } - return {} -} diff --git a/iwidgets/library/messagebox.itk b/iwidgets/library/messagebox.itk deleted file mode 100644 index b842d4c..0000000 --- a/iwidgets/library/messagebox.itk +++ /dev/null @@ -1,399 +0,0 @@ -# -# Messagebox -# ---------------------------------------------------------------------- -# Implements an information messages area widget with scrollbars. -# Message types can be user defined and configured. Their options -# include foreground, background, font, bell, and their display -# mode of on or off. This allows message types to defined as needed, -# removed when no longer so, and modified when necessary. An export -# method is provided for file I/O. -# -# The number of lines that can be displayed may be limited with -# the default being 1000. When this limit is reached, the oldest line -# is removed. There is also support for saving the contents to a -# file, using a file selection dialog. -# ---------------------------------------------------------------------- -# -# History: -# 01/16/97 - Alfredo Jahn Renamed from InfoMsgBox to MessageBox -# Initial release... -# 01/20/97 - Alfredo Jahn Add a popup window so that 3rd mouse -# button can be used to configure/access the message area. -# New methods added: _post and _toggleDebug. -# 01/30/97 - Alfredo Jahn Add -filename option -# 05/11/97 - Mark Ulferts Added the ability to define and configure -# new types. Changed print method to be issue. -# 09/05/97 - John Tucker Added export method. -# -# ---------------------------------------------------------------------- -# AUTHOR: Alfredo Jahn V EMAIL: ajahn@spd.dsccc.com -# Mark L. Ulferts mulferts@austin.dsccc.com -# -# @(#) $Id: messagebox.itk,v 1.6 2002/03/19 19:48:57 mgbacke Exp $ -# ---------------------------------------------------------------------- -# Copyright (c) 1997 DSC Technologies Corporation -# ====================================================================== -# Permission to use, copy, modify, distribute and license this software -# and its documentation for any purpose, and without fee or written -# agreement with DSC, is hereby granted, provided that the above copyright -# notice appears in all copies and that both the copyright notice and -# warranty disclaimer below appear in supporting documentation, and that -# the names of DSC Technologies Corporation or DSC Communications -# Corporation not be used in advertising or publicity pertaining to the -# software without specific, written prior permission. -# -# DSC DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING -# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, 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. IN NO EVENT SHALL -# DSC BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR -# ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, -# WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION, -# ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS -# SOFTWARE. -# ====================================================================== - -# -# Usual options. -# -itk::usual Messagebox { - keep -activebackground -activeforeground -background -borderwidth \ - -cursor -highlightcolor -highlightthickness \ - -jump -labelfont -textbackground -troughcolor -} - -# ------------------------------------------------------------------ -# MSGTYPE -# ------------------------------------------------------------------ - -itcl::class iwidgets::MsgType { - constructor {args} {eval configure $args} - - public variable background \#d9d9d9 - public variable bell 0 - public variable font -*-Courier-Medium-R-Normal--*-120-*-*-*-*-*-* - public variable foreground Black - public variable show 1 -} - -# ------------------------------------------------------------------ -# MESSAGEBOX -# ------------------------------------------------------------------ -itcl::class iwidgets::Messagebox { - inherit itk::Widget - - constructor {args} {} - destructor {} - - itk_option define -filename fileName FileName "" - itk_option define -maxlines maxLines MaxLines 1000 - itk_option define -savedir saveDir SaveDir "[pwd]" - - public { - method clear {} - method export {filename} - method find {} - method issue {string {type DEFAULT} args} - method save {} - method type {op tag args} - } - - protected { - variable _unique 0 - variable _types {} - variable _interior {} - - method _post {x y} - } -} - -# -# Provide a lowercased access method for the Messagebox class. -# -proc ::iwidgets::messagebox {pathName args} { - uplevel ::iwidgets::Messagebox $pathName $args -} - -# -# Use option database to override default resources of base classes. -# -option add *Messagebox.labelPos n widgetDefault -option add *Messagebox.cursor top_left_arrow widgetDefault -option add *Messagebox.height 0 widgetDefault -option add *Messagebox.width 0 widgetDefault -option add *Messagebox.visibleItems 80x24 widgetDefault - -# ------------------------------------------------------------------ -# CONSTRUCTOR -# ------------------------------------------------------------------ -itcl::body iwidgets::Messagebox::constructor {args} { - set _interior $itk_interior - - # - # Create the text area. - # - itk_component add text { - iwidgets::Scrolledtext $itk_interior.text -width 1 -height 1 \ - -state disabled -wrap none - } { - keep -borderwidth -cursor -exportselection -highlightcolor \ - -highlightthickness -padx -pady -relief -setgrid -spacing1 \ - -spacing2 -spacing3 - - keep -activerelief -elementborderwidth -jump -troughcolor - - keep -hscrollmode -height -sbwidth -scrollmargin -textbackground \ - -visibleitems -vscrollmode -width - - keep -labelbitmap -labelfont -labelimage -labelmargin \ - -labelpos -labeltext -labelvariable - } - grid $itk_component(text) -row 0 -column 0 -sticky nsew - grid rowconfigure $_interior 0 -weight 1 - grid columnconfigure $_interior 0 -weight 1 - - # - # Setup right mouse button binding to post a user configurable - # popup menu and diable the binding for left mouse clicks. - # - bind [$itk_component(text) component text] "break" - bind [$itk_component(text) component text] \ - [itcl::code $this _post %x %y] - - # - # Create the small popup menu that can be configurable by users. - # - itk_component add itemMenu { - menu $itk_component(hull).itemmenu -tearoff 0 - } { - keep -background -font -foreground \ - -activebackground -activeforeground - ignore -tearoff - } - - # - # Add clear and svae options to the popup menu. - # - $itk_component(itemMenu) add command -label "Find" \ - -command [itcl::code $this find] - $itk_component(itemMenu) add command -label "Save" \ - -command [itcl::code $this save] - $itk_component(itemMenu) add command -label "Clear" \ - -command [itcl::code $this clear] - - # - # Create a standard type to be used if no others are specified. - # - type add DEFAULT - - eval itk_initialize $args -} - -# ------------------------------------------------------------------ -# DESTURCTOR -# ------------------------------------------------------------------ -itcl::body iwidgets::Messagebox::destructor {} { - foreach type $_types { - type remove $type - } -} - -# ------------------------------------------------------------------ -# METHODS -# ------------------------------------------------------------------ - -# ------------------------------------------------------------------ -# METHOD clear -# -# Clear the text area. -# ------------------------------------------------------------------ -itcl::body iwidgets::Messagebox::clear {} { - $itk_component(text) configure -state normal - - $itk_component(text) delete 1.0 end - - $itk_component(text) configure -state disabled -} - -# ------------------------------------------------------------------ -# PUBLIC METHOD: type -# -# The type method supports several subcommands. Types can be added -# removed and configured. All the subcommands use the MsgType class -# to implement the functionaility. -# ------------------------------------------------------------------ -itcl::body iwidgets::Messagebox::type {op tag args} { - switch $op { - add { - eval iwidgets::MsgType $this$tag $args - - lappend _types $tag - - $itk_component(text) tag configure $tag \ - -font [$this$tag cget -font] \ - -background [$this$tag cget -background] \ - -foreground [$this$tag cget -foreground] - - return $tag - } - - remove { - if {[set index [lsearch $_types $tag]] != -1} { - itcl::delete object $this$tag - set _types [lreplace $_types $index $index] - - return - } else { - error "bad message type: \"$tag\", does not exist" - } - } - - configure { - if {[set index [lsearch $_types $tag]] != -1} { - set retVal [eval $this$tag configure $args] - - $itk_component(text) tag configure $tag \ - -font [$this$tag cget -font] \ - -background [$this$tag cget -background] \ - -foreground [$this$tag cget -foreground] - - return $retVal - - } else { - error "bad message type: \"$tag\", does not exist" - } - } - - cget { - if {[set index [lsearch $_types $tag]] != -1} { - return [eval $this$tag cget $args] - } else { - error "bad message type: \"$tag\", does not exist" - } - } - - default { - error "bad type operation: \"$op\", should be add,\ - remove, configure or cget" - } - } -} - -# ------------------------------------------------------------------ -# PUBLIC METHOD: issue string ?type? args -# -# Print the string out to the Messagebox. Check the options of the -# message type to see if it should be displayed or if the bell -# should be wrong. -# ------------------------------------------------------------------ -itcl::body iwidgets::Messagebox::issue {string {type DEFAULT} args} { - if {[lsearch $_types $type] == -1} { - error "bad message type: \"$type\", use the type\ - command to create a new types" - } - - # - # If the type is currently configured to be displayed, then insert - # it in the text widget, add the tag to the line and move the - # vertical scroll bar to the bottom. - # - set tag $this$type - - if {[$tag cget -show]} { - $itk_component(text) configure -state normal - - # - # Find end of last message. - # - set prevend [$itk_component(text) index "end - 1 chars"] - - $itk_component(text) insert end "$string\n" $args - - $itk_component(text) tag add $type $prevend "end - 1 chars" - $itk_component(text) yview end - - # - # Sound a beep if the message type is configured such. - # - if {[$tag cget -bell]} { - bell - } - - # - # If we reached our max lines limit, then remove enough lines to - # get it back under. - # - set lineCount [lindex [split [$itk_component(text) index end] "."] 0] - - if { $lineCount > $itk_option(-maxlines) } { - set numLines [expr {$lineCount - $itk_option(-maxlines) -1}] - - $itk_component(text) delete 1.0 $numLines.0 - } - - $itk_component(text) configure -state disabled - } -} - -# ------------------------------------------------------------------ -# PUBLIC METHOD: save -# -# Save contents of messages area to a file using a fileselectionbox. -# ------------------------------------------------------------------ -itcl::body iwidgets::Messagebox::save {} { - set saveFile "" - set filter "" - - set saveFile [tk_getSaveFile -title "Save Messages" \ - -initialdir $itk_option(-savedir) \ - -parent $itk_interior \ - -initialfile $itk_option(-filename)] - - if { $saveFile != "" } { - $itk_component(text) export $saveFile - } -} - -# ------------------------------------------------------------------ -# PUBLIC METHOD: find -# -# Search the contents of messages area for a specific string. -# ------------------------------------------------------------------ -itcl::body iwidgets::Messagebox::find {} { - if {! [info exists itk_component(findd)]} { - itk_component add findd { - iwidgets::Finddialog $itk_interior.findd \ - -textwidget $itk_component(text) - } - } - - $itk_component(findd) center $itk_component(text) - $itk_component(findd) activate -} - -# ------------------------------------------------------------------ -# PRIVATE METHOD: _post -# -# Used internally to post the popup menu at the coordinate (x,y) -# relative to the widget. -# ------------------------------------------------------------------ -itcl::body iwidgets::Messagebox::_post {x y} { - set rx [expr {[winfo rootx $itk_component(text)]+$x}] - set ry [expr {[winfo rooty $itk_component(text)]+$y}] - - tk_popup $itk_component(itemMenu) $rx $ry -} - - -# ------------------------------------------------------------------ -# METHOD export filename -# -# write text to a file (export filename) -# ------------------------------------------------------------------ -itcl::body iwidgets::Messagebox::export {filename} { - - $itk_component(text) export $filename - -} - diff --git a/iwidgets/library/messagedialog.itk b/iwidgets/library/messagedialog.itk deleted file mode 100644 index fe1c19a..0000000 --- a/iwidgets/library/messagedialog.itk +++ /dev/null @@ -1,144 +0,0 @@ -# -# Messagedialog -# ---------------------------------------------------------------------- -# Implements a message dialog composite widget. The Messagedialog is -# derived from the Dialog class and is composed of an image and text -# component. The image will accept both images as well as bitmaps. -# The text can extend mutliple lines by embedding newlines. -# -# ---------------------------------------------------------------------- -# AUTHOR: Mark L. Ulferts EMAIL: mulferts@austin.dsccc.com -# -# @(#) $Id: messagedialog.itk,v 1.3 2001/08/07 19:56:48 smithc Exp $ -# ---------------------------------------------------------------------- -# Copyright (c) 1995 DSC Technologies Corporation -# ====================================================================== -# Permission to use, copy, modify, distribute and license this software -# and its documentation for any purpose, and without fee or written -# agreement with DSC, is hereby granted, provided that the above copyright -# notice appears in all copies and that both the copyright notice and -# warranty disclaimer below appear in supporting documentation, and that -# the names of DSC Technologies Corporation or DSC Communications -# Corporation not be used in advertising or publicity pertaining to the -# software without specific, written prior permission. -# -# DSC DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING -# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, 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. IN NO EVENT SHALL -# DSC BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR -# ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, -# WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION, -# ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS -# SOFTWARE. -# ====================================================================== - -# -# Usual options. -# -itk::usual Messagedialog { - keep -background -cursor -font -foreground -modality - keep -wraplength -justify -} - -# ------------------------------------------------------------------ -# MESSAGEDIALOG -# ------------------------------------------------------------------ -itcl::class iwidgets::Messagedialog { - inherit iwidgets::Dialog - - constructor {args} {} - - itk_option define -imagepos imagePos Position w -} - -# -# Provide a lowercased access method for the Messagedialog class. -# -proc ::iwidgets::messagedialog {pathName args} { - uplevel ::iwidgets::Messagedialog $pathName $args -} - -# -# Use option database to override default resources of base classes. -# -option add *Messagedialog.title "Message Dialog" widgetDefault -option add *Messagedialog.master "." widgetDefault -option add *Messagedialog.textPadX 20 widgetDefault -option add *Messagedialog.textPadY 20 widgetDefault - -# ------------------------------------------------------------------ -# CONSTRUCTOR -# ------------------------------------------------------------------ -itcl::body iwidgets::Messagedialog::constructor {args} { - # - # Create the image component which may be either a bitmap or image. - # - itk_component add image { - label $itk_interior.image - } { - keep -background -bitmap -cursor -foreground -image - } - - # - # Create the text message component. The message may extend over - # several lines by embedding '\n' characters. - # - itk_component add message { - label $itk_interior.message - } { - keep -background -cursor -font -foreground -text - keep -wraplength -justify - - rename -padx -textpadx textPadX Pad - rename -pady -textpady textPadY Pad - } - - # - # Hide the apply and help buttons. - # - hide Apply - hide Help - - # - # Initialize the widget based on the command line options. - # - eval itk_initialize $args -} - -# ------------------------------------------------------------------ -# OPTIONS -# ------------------------------------------------------------------ - -# ------------------------------------------------------------------ -# OPTION: -imagepos -# -# Specifies the image position relative to the message: n, s, -# e, or w. The default is w. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Messagedialog::imagepos { - switch $itk_option(-imagepos) { - n { - grid $itk_component(image) -row 0 -column 0 - grid $itk_component(message) -row 1 -column 0 - } - s { - grid $itk_component(message) -row 0 -column 0 - grid $itk_component(image) -row 1 -column 0 - } - e { - grid $itk_component(message) -row 0 -column 0 - grid $itk_component(image) -row 0 -column 1 - } - w { - grid $itk_component(image) -row 0 -column 0 - grid $itk_component(message) -row 0 -column 1 - } - - default { - error "bad imagepos option \"$itk_option(-imagepos)\":\ - should be n, e, s, or w" - } - } -} diff --git a/iwidgets/library/notebook.itk b/iwidgets/library/notebook.itk deleted file mode 100644 index 6451e5c..0000000 --- a/iwidgets/library/notebook.itk +++ /dev/null @@ -1,946 +0,0 @@ -# -# Notebook Widget -# ---------------------------------------------------------------------- -# The Notebook command creates a new window (given by the pathName -# argument) and makes it into a Notebook widget. Additional options, -# described above may be specified on the command line or in the -# option database to configure aspects of the Notebook such as its -# colors, font, and text. The Notebook command returns its pathName -# argument. At the time this command is invoked, there must not exist -# a window named pathName, but path Name's parent must exist. -# -# A Notebook is a widget that contains a set of pages. It displays one -# page from the set as the selected page. When a page is selected, the -# page's contents are displayed in the page area. When first created a -# Notebook has no pages. Pages may be added or deleted using widget commands -# described below. -# -# A special option may be provided to the Notebook. The -auto option -# specifies whether the Nptebook will automatically handle the unpacking -# and packing of pages when pages are selected. A value of true signifies -# that the notebook will automatically manage it. This is the default -# value. A value of false signifies the notebook will not perform automatic -# switching of pages. -# -# WISH LIST: -# This section lists possible future enhancements. -# -# ---------------------------------------------------------------------- -# AUTHOR: Bill W. Scott EMAIL: bscott@spd.dsccc.com -# -# @(#) $Id: notebook.itk,v 1.4 2001/08/15 18:33:31 smithc Exp $ -# ---------------------------------------------------------------------- -# Copyright (c) 1995 DSC Technologies Corporation -# ====================================================================== -# Permission to use, copy, modify, distribute and license this software -# and its documentation for any purpose, and without fee or written -# agreement with DSC, is hereby granted, provided that the above copyright -# notice appears in all copies and that both the copyright notice and -# warranty disclaimer below appear in supporting documentation, and that -# the names of DSC Technologies Corporation or DSC Communications -# Corporation not be used in advertising or publicity pertaining to the -# software without specific, written prior permission. -# -# DSC DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING -# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, 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. IN NO EVENT SHALL -# DSC BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR -# ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, -# WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION, -# ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS -# SOFTWARE. -# ====================================================================== - -# -# Default resources. -# -option add *Notebook.background #d9d9d9 widgetDefault -option add *Notebook.auto true widgetDefault - -# -# Usual options. -# -itk::usual Notebook { - keep -background -cursor -} - -# ------------------------------------------------------------------ -# NOTEBOOK -# ------------------------------------------------------------------ -itcl::class iwidgets::Notebook { - inherit itk::Widget - - constructor {args} {} - - itk_option define -background background Background #d9d9d9 - itk_option define -auto auto Auto true - itk_option define -scrollcommand scrollCommand ScrollCommand {} - - public method add { args } - public method childsite { args } - public method delete { args } - public method index { args } - public method insert { args } - public method prev { } - public method next { } - public method pageconfigure { args } - public method pagecget { index option } - public method select { index } - public method view { args } - - private method _childSites { } - private method _scrollCommand { } - private method _index { pathList index select} - private method _createPage { args } - private method _deletePages { fromPage toPage } - private method _configurePages { args } - private method _tabCommand { } - - private variable _currPage -1 ;# numerical index of current page selected - private variable _pages {} ;# list of Page components - private variable _uniqueID 0 ;# one-up number for unique page numbering - -} - -# -# Provide a lowercase access method for the Notebook class -# -proc ::iwidgets::notebook {pathName args} { - uplevel ::iwidgets::Notebook $pathName $args -} - -# ------------------------------------------------------------------ -# CONSTRUCTOR -# ------------------------------------------------------------------ -itcl::body iwidgets::Notebook::constructor {args} { - # - # Create the outermost frame to maintain geometry. - # - itk_component add cs { - frame $itk_interior.cs - } { - keep -cursor -background -width -height - } - pack $itk_component(cs) -fill both -expand yes - pack propagate $itk_component(cs) no - - eval itk_initialize $args - - # force bg of all pages to reflect Notebook's background. - _configurePages -background $itk_option(-background) -} - -# ------------------------------------------------------------------ -# OPTIONS -# ------------------------------------------------------------------ -# ------------------------------------------------------------------ -# OPTION -background -# -# Sets the bg color of all the pages in the Notebook. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Notebook::background { - if {$itk_option(-background) != {}} { - _configurePages -background $itk_option(-background) - } -} - -# ------------------------------------------------------------------ -# OPTION -auto -# -# Determines whether pages are automatically unpacked and -# packed when pages get selected. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Notebook::auto { - if {$itk_option(-auto) != {}} { - } -} - -# ------------------------------------------------------------------ -# OPTION -scrollcommand -# -# Command string to be invoked when the notebook -# has any changes to its current page, or number of pages. -# -# typically for scrollbars. -# ------------------------------------------------------------------ -itcl::configbody iwidgets::Notebook::scrollcommand { - if {$itk_option(-scrollcommand) != {}} { - _scrollCommand - } -} - -# ------------------------------------------------------------------ -# METHOD: add add ?