[GRASS-SVN] r35358 - in grass/trunk/lib: . external
external/bwidget external/bwidget/images
external/bwidget/lang gtcltk
svn_grass at osgeo.org
svn_grass at osgeo.org
Mon Jan 12 06:48:49 EST 2009
Author: martinl
Date: 2009-01-12 06:48:48 -0500 (Mon, 12 Jan 2009)
New Revision: 35358
Added:
grass/trunk/lib/external/bwidget/
grass/trunk/lib/external/bwidget/CHANGES.txt
grass/trunk/lib/external/bwidget/LGPL.txt
grass/trunk/lib/external/bwidget/LICENSE.txt
grass/trunk/lib/external/bwidget/Makefile
grass/trunk/lib/external/bwidget/README
grass/trunk/lib/external/bwidget/README.grass
grass/trunk/lib/external/bwidget/arrow.tcl
grass/trunk/lib/external/bwidget/bitmap.tcl
grass/trunk/lib/external/bwidget/button.tcl
grass/trunk/lib/external/bwidget/buttonbox.tcl
grass/trunk/lib/external/bwidget/color.tcl
grass/trunk/lib/external/bwidget/combobox.tcl
grass/trunk/lib/external/bwidget/dialog.tcl
grass/trunk/lib/external/bwidget/dragsite.tcl
grass/trunk/lib/external/bwidget/dropsite.tcl
grass/trunk/lib/external/bwidget/dynhelp.tcl
grass/trunk/lib/external/bwidget/entry.tcl
grass/trunk/lib/external/bwidget/font.tcl
grass/trunk/lib/external/bwidget/images/
grass/trunk/lib/external/bwidget/images/bold.gif
grass/trunk/lib/external/bwidget/images/copy.gif
grass/trunk/lib/external/bwidget/images/cut.gif
grass/trunk/lib/external/bwidget/images/dragfile.gif
grass/trunk/lib/external/bwidget/images/dragicon.gif
grass/trunk/lib/external/bwidget/images/error.gif
grass/trunk/lib/external/bwidget/images/file.gif
grass/trunk/lib/external/bwidget/images/folder.gif
grass/trunk/lib/external/bwidget/images/hourglass.gif
grass/trunk/lib/external/bwidget/images/info.gif
grass/trunk/lib/external/bwidget/images/italic.gif
grass/trunk/lib/external/bwidget/images/minus.xbm
grass/trunk/lib/external/bwidget/images/new.gif
grass/trunk/lib/external/bwidget/images/opcopy.xbm
grass/trunk/lib/external/bwidget/images/open.gif
grass/trunk/lib/external/bwidget/images/openfold.gif
grass/trunk/lib/external/bwidget/images/oplink.xbm
grass/trunk/lib/external/bwidget/images/opmove.xbm
grass/trunk/lib/external/bwidget/images/overstrike.gif
grass/trunk/lib/external/bwidget/images/palette.gif
grass/trunk/lib/external/bwidget/images/passwd.gif
grass/trunk/lib/external/bwidget/images/paste.gif
grass/trunk/lib/external/bwidget/images/plus.xbm
grass/trunk/lib/external/bwidget/images/print.gif
grass/trunk/lib/external/bwidget/images/question.gif
grass/trunk/lib/external/bwidget/images/save.gif
grass/trunk/lib/external/bwidget/images/underline.gif
grass/trunk/lib/external/bwidget/images/undo.gif
grass/trunk/lib/external/bwidget/images/warning.gif
grass/trunk/lib/external/bwidget/init.tcl
grass/trunk/lib/external/bwidget/label.tcl
grass/trunk/lib/external/bwidget/labelentry.tcl
grass/trunk/lib/external/bwidget/labelframe.tcl
grass/trunk/lib/external/bwidget/lang/
grass/trunk/lib/external/bwidget/lang/de.rc
grass/trunk/lib/external/bwidget/lang/en.rc
grass/trunk/lib/external/bwidget/lang/es.rc
grass/trunk/lib/external/bwidget/lang/fr.rc
grass/trunk/lib/external/bwidget/listbox.tcl
grass/trunk/lib/external/bwidget/mainframe.tcl
grass/trunk/lib/external/bwidget/messagedlg.tcl
grass/trunk/lib/external/bwidget/notebook.tcl
grass/trunk/lib/external/bwidget/pagesmgr.tcl
grass/trunk/lib/external/bwidget/panedw.tcl
grass/trunk/lib/external/bwidget/passwddlg.tcl
grass/trunk/lib/external/bwidget/pkgIndex.tcl
grass/trunk/lib/external/bwidget/progressbar.tcl
grass/trunk/lib/external/bwidget/progressdlg.tcl
grass/trunk/lib/external/bwidget/scrollframe.tcl
grass/trunk/lib/external/bwidget/scrollview.tcl
grass/trunk/lib/external/bwidget/scrollw.tcl
grass/trunk/lib/external/bwidget/separator.tcl
grass/trunk/lib/external/bwidget/spinbox.tcl
grass/trunk/lib/external/bwidget/titleframe.tcl
grass/trunk/lib/external/bwidget/tree.tcl
grass/trunk/lib/external/bwidget/utils.tcl
grass/trunk/lib/external/bwidget/widget.tcl
grass/trunk/lib/external/bwidget/xpm2image.tcl
grass/trunk/lib/gtcltk/
grass/trunk/lib/gtcltk/Makefile
grass/trunk/lib/gtcltk/gmsg.tcl
grass/trunk/lib/gtcltk/grocat.c
grass/trunk/lib/gtcltk/gronsole.tcl
grass/trunk/lib/gtcltk/options.tcl
grass/trunk/lib/gtcltk/select.tcl
Removed:
grass/trunk/lib/external/bwidget/CHANGES.txt
grass/trunk/lib/external/bwidget/LGPL.txt
grass/trunk/lib/external/bwidget/LICENSE.txt
grass/trunk/lib/external/bwidget/Makefile
grass/trunk/lib/external/bwidget/README
grass/trunk/lib/external/bwidget/README.grass
grass/trunk/lib/external/bwidget/arrow.tcl
grass/trunk/lib/external/bwidget/bitmap.tcl
grass/trunk/lib/external/bwidget/button.tcl
grass/trunk/lib/external/bwidget/buttonbox.tcl
grass/trunk/lib/external/bwidget/color.tcl
grass/trunk/lib/external/bwidget/combobox.tcl
grass/trunk/lib/external/bwidget/dialog.tcl
grass/trunk/lib/external/bwidget/dragsite.tcl
grass/trunk/lib/external/bwidget/dropsite.tcl
grass/trunk/lib/external/bwidget/dynhelp.tcl
grass/trunk/lib/external/bwidget/entry.tcl
grass/trunk/lib/external/bwidget/font.tcl
grass/trunk/lib/external/bwidget/images/
grass/trunk/lib/external/bwidget/images/bold.gif
grass/trunk/lib/external/bwidget/images/copy.gif
grass/trunk/lib/external/bwidget/images/cut.gif
grass/trunk/lib/external/bwidget/images/dragfile.gif
grass/trunk/lib/external/bwidget/images/dragicon.gif
grass/trunk/lib/external/bwidget/images/error.gif
grass/trunk/lib/external/bwidget/images/file.gif
grass/trunk/lib/external/bwidget/images/folder.gif
grass/trunk/lib/external/bwidget/images/hourglass.gif
grass/trunk/lib/external/bwidget/images/info.gif
grass/trunk/lib/external/bwidget/images/italic.gif
grass/trunk/lib/external/bwidget/images/minus.xbm
grass/trunk/lib/external/bwidget/images/new.gif
grass/trunk/lib/external/bwidget/images/opcopy.xbm
grass/trunk/lib/external/bwidget/images/open.gif
grass/trunk/lib/external/bwidget/images/openfold.gif
grass/trunk/lib/external/bwidget/images/oplink.xbm
grass/trunk/lib/external/bwidget/images/opmove.xbm
grass/trunk/lib/external/bwidget/images/overstrike.gif
grass/trunk/lib/external/bwidget/images/palette.gif
grass/trunk/lib/external/bwidget/images/passwd.gif
grass/trunk/lib/external/bwidget/images/paste.gif
grass/trunk/lib/external/bwidget/images/plus.xbm
grass/trunk/lib/external/bwidget/images/print.gif
grass/trunk/lib/external/bwidget/images/question.gif
grass/trunk/lib/external/bwidget/images/save.gif
grass/trunk/lib/external/bwidget/images/underline.gif
grass/trunk/lib/external/bwidget/images/undo.gif
grass/trunk/lib/external/bwidget/images/warning.gif
grass/trunk/lib/external/bwidget/init.tcl
grass/trunk/lib/external/bwidget/label.tcl
grass/trunk/lib/external/bwidget/labelentry.tcl
grass/trunk/lib/external/bwidget/labelframe.tcl
grass/trunk/lib/external/bwidget/lang/
grass/trunk/lib/external/bwidget/lang/de.rc
grass/trunk/lib/external/bwidget/lang/en.rc
grass/trunk/lib/external/bwidget/lang/es.rc
grass/trunk/lib/external/bwidget/lang/fr.rc
grass/trunk/lib/external/bwidget/listbox.tcl
grass/trunk/lib/external/bwidget/mainframe.tcl
grass/trunk/lib/external/bwidget/messagedlg.tcl
grass/trunk/lib/external/bwidget/notebook.tcl
grass/trunk/lib/external/bwidget/pagesmgr.tcl
grass/trunk/lib/external/bwidget/panedw.tcl
grass/trunk/lib/external/bwidget/passwddlg.tcl
grass/trunk/lib/external/bwidget/pkgIndex.tcl
grass/trunk/lib/external/bwidget/progressbar.tcl
grass/trunk/lib/external/bwidget/progressdlg.tcl
grass/trunk/lib/external/bwidget/scrollframe.tcl
grass/trunk/lib/external/bwidget/scrollview.tcl
grass/trunk/lib/external/bwidget/scrollw.tcl
grass/trunk/lib/external/bwidget/separator.tcl
grass/trunk/lib/external/bwidget/spinbox.tcl
grass/trunk/lib/external/bwidget/titleframe.tcl
grass/trunk/lib/external/bwidget/tree.tcl
grass/trunk/lib/external/bwidget/utils.tcl
grass/trunk/lib/external/bwidget/widget.tcl
grass/trunk/lib/external/bwidget/xpm2image.tcl
grass/trunk/lib/gtcltk/Makefile
grass/trunk/lib/gtcltk/gmsg.tcl
grass/trunk/lib/gtcltk/grocat.c
grass/trunk/lib/gtcltk/gronsole.tcl
grass/trunk/lib/gtcltk/options.tcl
grass/trunk/lib/gtcltk/select.tcl
Modified:
grass/trunk/lib/Makefile
grass/trunk/lib/external/Makefile
Log:
gtcltk and bwidget removal reverted - to make nviz working again
Modified: grass/trunk/lib/Makefile
===================================================================
--- grass/trunk/lib/Makefile 2009-01-12 11:25:34 UTC (rev 35357)
+++ grass/trunk/lib/Makefile 2009-01-12 11:48:48 UTC (rev 35358)
@@ -20,6 +20,7 @@
db \
external \
fonts \
+ gtcltk \
form \
imagery \
cluster \
Modified: grass/trunk/lib/external/Makefile
===================================================================
--- grass/trunk/lib/external/Makefile 2009-01-12 11:25:34 UTC (rev 35357)
+++ grass/trunk/lib/external/Makefile 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,6 +1,9 @@
+
MODULE_TOPDIR = ../..
-SUBDIRS = shapelib
+SUBDIRS = \
+ bwidget \
+ shapelib
include $(MODULE_TOPDIR)/include/Make/Dir.make
Copied: grass/trunk/lib/external/bwidget (from rev 35192, grass/trunk/lib/external/bwidget)
Property changes on: grass/trunk/lib/external/bwidget
___________________________________________________________________
Name: svn:ignore
+ *OBJ*
Deleted: grass/trunk/lib/external/bwidget/CHANGES.txt
===================================================================
--- grass/trunk/lib/external/bwidget/CHANGES.txt 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/CHANGES.txt 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,266 +0,0 @@
-____________________________________________________________
-BWidget 1.2.1 (07/09/1999)
-
-CHANGES FROM 1.2 TO 1.2.1
-
- This version is the first patch of 1.2. It does not introduce
- incompatibilites.
- This patch include some new requested features, that I think
- can't wait for 1.3:
- - special menu handling (see MainFrame)
- - tabs bindings in NoteBook
- - label alignment of LabelFrame
- - -repeatdelay and -repeatinterval options on SpinBox
-
-
-* Entry
- - <Destroy> event added to tag BwDisabledEntry
- - fixed bug when -textvariable use a variable containing space
-
-* MainFrame
- - fixed bug when -textvariable use a variable containing space
- - menubar entry creation modified to use the menuid as the
- subpathname to permit special menu (help, system, apple)
-
-* LabelFrame
- - LabelFrame::align command added
-
-* ScrollableFrame
- - fixed typo bug
-
-* PagesManager
- - fixed bug of window size
- - 'pages' modified to optionally include first and last indices.
- ('page' is still available but deprecated)
-
-* NoteBook
- - new command 'bindtabs'
- - fixed bug in handling result of -leavecmd command
- - 'pages' modified to optionally include first and last indices.
- ('page' is still available but deprecated)
-
-* ComboBox
- - little border added around the popdown list, which appeared
- to have no border under windows when popped above a widget
- with the same background color.
-
-* SpinBox
- - options -repeatdelay and -repeatinterval added.
-
-* Tree
- - fixed strange behaviour when editing: 'selection range'
- replaced by 'selection from'/'selection to'
- - widget is redrawn if needed in 'edit' and 'see'
- - fixed bug in see
- - nodes modified to optionally include first and last indices.
- - _subdelete modified to iterative method
-
-* ListBox
- - fixed strange behaviour when editing: 'selection range'
- replaced by 'selection from'/'selection to'
- - ListBox is redrawn if needed in 'edit' and 'see'
- - fixed bug in see
- - 'items' modified to optionally include first and last indices.
- ('item' is still available but deprecated)
-
-* SelectColor
- - fixed bug in call to GlobalVar::trace renamed GlobalVar::tracevar
-
-* DragSite and DropSite
- - fixed bug introduced by new button event.
-
-* DynamicHelp
- - restored version of 1.1, due to the bug under windows
-
-* BWidget::place
- - fixed bug when x or y is 0.
-
-* es.rc resource file included
-
-
-____________________________________________________________
-BWidget 1.2 (05/21/1999)
-
-CHANGES FROM 1.1 TO 1.2
-
-
-* 4 new widget:
- - ScrollableFrame
- - ScrollView
- - PagesManager
- - PasswdDlg (contributed by Stephane Lavirotte)
-
-* Widget:
- - Flag option type added
- - option resource database read while widget creation,
- not while widget class creation.
- - better handling of BWidget definition using another BWidget as a top pathname.
-
-* MainFrame
- - more options included for ProgressBar
- (INCOMPATIBILITY: option -variable renamed -progressvar)
- - -menu option modified to have tags on entries and menu id on cascad menu
- (INCOMPATIBILITY of option -menu)
- - new command: getmenu
- - new command: setmenustate
-
-* DropSite
- - operations completly reworked
- - option -droptypes modified (INCOMPATIBILITY)
- - return code of -dropovercmd modified
- bit 'ok' and bit 'recall' reverted
- (INCOMPATIBILITY in -dropovercmd command)
- - new command: setoperation
-
-* DragSite:
- - Drag now initiates while <ButtonPress-x> followed by <Bx-Motion> of
- 4 pixels, so it is possible to have a <ButtonPress-x> event and
- drag event on the same button.
- - -dragevent option modified: must be the number of the button: 1, 2 or 3
- Option is now defaulted to 1, but Entry widget keep it to 3.
- (INCOMPATIBILITY)
- - return result of -draginitcmd modified (INCOMPATIBILITY)
-
-* ListBox:
- - edit command improved.
- new arguments: initial text, and command to verify the text before accept it.
- (INCOMPATIBILITY in call to edit)
- - Drag and Drop modified
- (INCOMPATIBILITY in -dropovercmd command)
- - new command: reorder
-
-* Tree:
- - edit command improved.
- new arguments: initial text, and command to verify the text before accept it.
- (INCOMPATIBILITY in call to edit)
- - Drag and Drop modified
- (INCOMPATIBILITY in -dropovercmd command)
- - new command: reorder
- - new command: visible
- - less full-redraw
-
-* NoteBook:
- - relief reworked
- - added option -leavecmd on pages
- - option -image implemented
- - new command: move
- - delete command now accept an optionnal argument specifying
- whether the frame of the page should be destroyed or not.
- If not, this frame is reused by insert command for the same page.
-
-* Entry and LabelEntry:
- - direct access to entry command
- - bind command added on the entry subwidget
-
-* ComboBox:
- - option -postcommand added
- - bind command added on the entry subwidget
-
-* SpinBox:
- - bind command added on the entry subwidget
- - floating point fixed - work needed
-
-* ProgressBar:
- - now can be incremental or not limited ('unknow-time' processing)
-
-* Bitmap:
- - xpm image type added with use of xpm-to-image by Roger E. Critchlow Jr.
-
-* Lots of focus problem solved
-
-* ...and bugs corrected.
-
-
-INCOMPATIBILITIES
-
- Incompatibilities are very localized, so we hope that it will
- not be painfull to upgrade to 1.2.
-
-* MainFrame related imcompatibilities
- - Upgrade MainFrame -menu option and change -variable option
- by -progressvar.
-
-* Drag and drop related imcompatibilities
- - Upgrade -dragevent option, and command associated to -draginitcmd
- and -dropovercmd.
- - Upgrade -dragendcmd/-dragovercmd command of Tree and ListBox widget
-
-* Edition in Tree and ListBox
- - Verify arguments passed in call to edit command of
- Tree and ListBox
-
-
-____________________________________________________________
-BWidget 1.1 (03/12/1999)
-
-CHANGES FROM 1.0 TO 1.1
-
-WHAT'S NEW
-
-The most important change in BWidget 1.1 is the support
-of tk path command, but the old syntax is always available.
-configure command now returns a valid configuration information list.
-
-(I hope that) All submitted bugs have been corrected.
-
-Following widget have been reworked:
-
-* ListBox:
- - ListBox items have now a -indent option.
- - insert command modified to look more as a tk
- listbox insert command (see INCOMPATIBILITIES)
- - item command added to retreive one or more items
-
-* Tree:
- - insert command modified to look more as a
- listbox insert command (see INCOMPATIBILITIES)
-
-* LabelEntry:
- - -value and -variable options renamed to -text and -textvariable
- (see INCOMPATIBILITIES)
-
-* SpinBox and ComboBox:
- - -value and -variable options renamed to -text and -textvariable
- (see INCOMPATIBILITIES)
- - New command getvalue and setvalue added to manipulate
- current value by index.
-
-* NoteBook:
- - Pages have now an identifier.
- - insert command modififed (see INCOMPATIBILITIES)
- - page command added to retreive one or more pages
- - getframe command added
-
-
-INCOMPATIBILITIES (sorry for this)
-
-* LabelEntry, SpinBox and ComboBox:
- - -value and -variable options renamed to -text and -textvariable
-
-* Entry and LabelEntry:
- - setfocus doesn't exist anymore. Directly use tk command focus.
-
-* NoteBook:
- - Pages have now an identifier, which modifies insert command:
- NoteBook::insert $nb index ?option value ...?
- is now
- $nb insert index page ?option value ...?
-
-* Tree:
- - insert command modified:
- Tree::insert $nb $parent $node $index ?option value ...?
- becomes
- $tree insert $index $parent $node ?option value ...?
-
-* ListBox:
- - insert command modified:
- ListBox::insert $list $item $index ?option value ...?
- becomes
- $list insert $index $item ?option value ...?
-
-
-____________________________________________________________
-BWidget 1.0 (02/19/1999)
-
- First release.
-
Copied: grass/trunk/lib/external/bwidget/CHANGES.txt (from rev 35192, grass/trunk/lib/external/bwidget/CHANGES.txt)
===================================================================
--- grass/trunk/lib/external/bwidget/CHANGES.txt (rev 0)
+++ grass/trunk/lib/external/bwidget/CHANGES.txt 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,266 @@
+____________________________________________________________
+BWidget 1.2.1 (07/09/1999)
+
+CHANGES FROM 1.2 TO 1.2.1
+
+ This version is the first patch of 1.2. It does not introduce
+ incompatibilites.
+ This patch include some new requested features, that I think
+ can't wait for 1.3:
+ - special menu handling (see MainFrame)
+ - tabs bindings in NoteBook
+ - label alignment of LabelFrame
+ - -repeatdelay and -repeatinterval options on SpinBox
+
+
+* Entry
+ - <Destroy> event added to tag BwDisabledEntry
+ - fixed bug when -textvariable use a variable containing space
+
+* MainFrame
+ - fixed bug when -textvariable use a variable containing space
+ - menubar entry creation modified to use the menuid as the
+ subpathname to permit special menu (help, system, apple)
+
+* LabelFrame
+ - LabelFrame::align command added
+
+* ScrollableFrame
+ - fixed typo bug
+
+* PagesManager
+ - fixed bug of window size
+ - 'pages' modified to optionally include first and last indices.
+ ('page' is still available but deprecated)
+
+* NoteBook
+ - new command 'bindtabs'
+ - fixed bug in handling result of -leavecmd command
+ - 'pages' modified to optionally include first and last indices.
+ ('page' is still available but deprecated)
+
+* ComboBox
+ - little border added around the popdown list, which appeared
+ to have no border under windows when popped above a widget
+ with the same background color.
+
+* SpinBox
+ - options -repeatdelay and -repeatinterval added.
+
+* Tree
+ - fixed strange behaviour when editing: 'selection range'
+ replaced by 'selection from'/'selection to'
+ - widget is redrawn if needed in 'edit' and 'see'
+ - fixed bug in see
+ - nodes modified to optionally include first and last indices.
+ - _subdelete modified to iterative method
+
+* ListBox
+ - fixed strange behaviour when editing: 'selection range'
+ replaced by 'selection from'/'selection to'
+ - ListBox is redrawn if needed in 'edit' and 'see'
+ - fixed bug in see
+ - 'items' modified to optionally include first and last indices.
+ ('item' is still available but deprecated)
+
+* SelectColor
+ - fixed bug in call to GlobalVar::trace renamed GlobalVar::tracevar
+
+* DragSite and DropSite
+ - fixed bug introduced by new button event.
+
+* DynamicHelp
+ - restored version of 1.1, due to the bug under windows
+
+* BWidget::place
+ - fixed bug when x or y is 0.
+
+* es.rc resource file included
+
+
+____________________________________________________________
+BWidget 1.2 (05/21/1999)
+
+CHANGES FROM 1.1 TO 1.2
+
+
+* 4 new widget:
+ - ScrollableFrame
+ - ScrollView
+ - PagesManager
+ - PasswdDlg (contributed by Stephane Lavirotte)
+
+* Widget:
+ - Flag option type added
+ - option resource database read while widget creation,
+ not while widget class creation.
+ - better handling of BWidget definition using another BWidget as a top pathname.
+
+* MainFrame
+ - more options included for ProgressBar
+ (INCOMPATIBILITY: option -variable renamed -progressvar)
+ - -menu option modified to have tags on entries and menu id on cascad menu
+ (INCOMPATIBILITY of option -menu)
+ - new command: getmenu
+ - new command: setmenustate
+
+* DropSite
+ - operations completly reworked
+ - option -droptypes modified (INCOMPATIBILITY)
+ - return code of -dropovercmd modified
+ bit 'ok' and bit 'recall' reverted
+ (INCOMPATIBILITY in -dropovercmd command)
+ - new command: setoperation
+
+* DragSite:
+ - Drag now initiates while <ButtonPress-x> followed by <Bx-Motion> of
+ 4 pixels, so it is possible to have a <ButtonPress-x> event and
+ drag event on the same button.
+ - -dragevent option modified: must be the number of the button: 1, 2 or 3
+ Option is now defaulted to 1, but Entry widget keep it to 3.
+ (INCOMPATIBILITY)
+ - return result of -draginitcmd modified (INCOMPATIBILITY)
+
+* ListBox:
+ - edit command improved.
+ new arguments: initial text, and command to verify the text before accept it.
+ (INCOMPATIBILITY in call to edit)
+ - Drag and Drop modified
+ (INCOMPATIBILITY in -dropovercmd command)
+ - new command: reorder
+
+* Tree:
+ - edit command improved.
+ new arguments: initial text, and command to verify the text before accept it.
+ (INCOMPATIBILITY in call to edit)
+ - Drag and Drop modified
+ (INCOMPATIBILITY in -dropovercmd command)
+ - new command: reorder
+ - new command: visible
+ - less full-redraw
+
+* NoteBook:
+ - relief reworked
+ - added option -leavecmd on pages
+ - option -image implemented
+ - new command: move
+ - delete command now accept an optionnal argument specifying
+ whether the frame of the page should be destroyed or not.
+ If not, this frame is reused by insert command for the same page.
+
+* Entry and LabelEntry:
+ - direct access to entry command
+ - bind command added on the entry subwidget
+
+* ComboBox:
+ - option -postcommand added
+ - bind command added on the entry subwidget
+
+* SpinBox:
+ - bind command added on the entry subwidget
+ - floating point fixed - work needed
+
+* ProgressBar:
+ - now can be incremental or not limited ('unknow-time' processing)
+
+* Bitmap:
+ - xpm image type added with use of xpm-to-image by Roger E. Critchlow Jr.
+
+* Lots of focus problem solved
+
+* ...and bugs corrected.
+
+
+INCOMPATIBILITIES
+
+ Incompatibilities are very localized, so we hope that it will
+ not be painfull to upgrade to 1.2.
+
+* MainFrame related imcompatibilities
+ - Upgrade MainFrame -menu option and change -variable option
+ by -progressvar.
+
+* Drag and drop related imcompatibilities
+ - Upgrade -dragevent option, and command associated to -draginitcmd
+ and -dropovercmd.
+ - Upgrade -dragendcmd/-dragovercmd command of Tree and ListBox widget
+
+* Edition in Tree and ListBox
+ - Verify arguments passed in call to edit command of
+ Tree and ListBox
+
+
+____________________________________________________________
+BWidget 1.1 (03/12/1999)
+
+CHANGES FROM 1.0 TO 1.1
+
+WHAT'S NEW
+
+The most important change in BWidget 1.1 is the support
+of tk path command, but the old syntax is always available.
+configure command now returns a valid configuration information list.
+
+(I hope that) All submitted bugs have been corrected.
+
+Following widget have been reworked:
+
+* ListBox:
+ - ListBox items have now a -indent option.
+ - insert command modified to look more as a tk
+ listbox insert command (see INCOMPATIBILITIES)
+ - item command added to retreive one or more items
+
+* Tree:
+ - insert command modified to look more as a
+ listbox insert command (see INCOMPATIBILITIES)
+
+* LabelEntry:
+ - -value and -variable options renamed to -text and -textvariable
+ (see INCOMPATIBILITIES)
+
+* SpinBox and ComboBox:
+ - -value and -variable options renamed to -text and -textvariable
+ (see INCOMPATIBILITIES)
+ - New command getvalue and setvalue added to manipulate
+ current value by index.
+
+* NoteBook:
+ - Pages have now an identifier.
+ - insert command modififed (see INCOMPATIBILITIES)
+ - page command added to retreive one or more pages
+ - getframe command added
+
+
+INCOMPATIBILITIES (sorry for this)
+
+* LabelEntry, SpinBox and ComboBox:
+ - -value and -variable options renamed to -text and -textvariable
+
+* Entry and LabelEntry:
+ - setfocus doesn't exist anymore. Directly use tk command focus.
+
+* NoteBook:
+ - Pages have now an identifier, which modifies insert command:
+ NoteBook::insert $nb index ?option value ...?
+ is now
+ $nb insert index page ?option value ...?
+
+* Tree:
+ - insert command modified:
+ Tree::insert $nb $parent $node $index ?option value ...?
+ becomes
+ $tree insert $index $parent $node ?option value ...?
+
+* ListBox:
+ - insert command modified:
+ ListBox::insert $list $item $index ?option value ...?
+ becomes
+ $list insert $index $item ?option value ...?
+
+
+____________________________________________________________
+BWidget 1.0 (02/19/1999)
+
+ First release.
+
Deleted: grass/trunk/lib/external/bwidget/LGPL.txt
===================================================================
--- grass/trunk/lib/external/bwidget/LGPL.txt 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/LGPL.txt 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,481 +0,0 @@
- GNU LIBRARY GENERAL PUBLIC LICENSE
- Version 2, June 1991
-
- Copyright (C) 1991 Free Software Foundation, Inc.
- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
- Everyone is permitted to copy and distribute verbatim copies
- of this license document, but changing it is not allowed.
-
-[This is the first released version of the library GPL. It is
- numbered 2 because it goes with version 2 of the ordinary GPL.]
-
- Preamble
-
- The licenses for most software are designed to take away your
-freedom to share and change it. By contrast, the GNU General Public
-Licenses are intended to guarantee your freedom to share and change
-free software--to make sure the software is free for all its users.
-
- This license, the Library General Public License, applies to some
-specially designated Free Software Foundation software, and to any
-other libraries whose authors decide to use it. You can use it for
-your libraries, too.
-
- When we speak of free software, we are referring to freedom, not
-price. Our General Public Licenses are designed to make sure that you
-have the freedom to distribute copies of free software (and charge for
-this service if you wish), that you receive source code or can get it
-if you want it, that you can change the software or use pieces of it
-in new free programs; and that you know you can do these things.
-
- To protect your rights, we need to make restrictions that forbid
-anyone to deny you these rights or to ask you to surrender the rights.
-These restrictions translate to certain responsibilities for you if
-you distribute copies of the library, or if you modify it.
-
- For example, if you distribute copies of the library, whether gratis
-or for a fee, you must give the recipients all the rights that we gave
-you. You must make sure that they, too, receive or can get the source
-code. If you link a program with the library, you must provide
-complete object files to the recipients so that they can relink them
-with the library, after making changes to the library and recompiling
-it. And you must show them these terms so they know their rights.
-
- Our method of protecting your rights has two steps: (1) copyright
-the library, and (2) offer you this license which gives you legal
-permission to copy, distribute and/or modify the library.
-
- Also, for each distributor's protection, we want to make certain
-that everyone understands that there is no warranty for this free
-library. If the library is modified by someone else and passed on, we
-want its recipients to know that what they have is not the original
-version, so that any problems introduced by others will not reflect on
-the original authors' reputations.
-
- Finally, any free program is threatened constantly by software
-patents. We wish to avoid the danger that companies distributing free
-software will individually obtain patent licenses, thus in effect
-transforming the program into proprietary software. To prevent this,
-we have made it clear that any patent must be licensed for everyone's
-free use or not licensed at all.
-
- Most GNU software, including some libraries, is covered by the ordinary
-GNU General Public License, which was designed for utility programs. This
-license, the GNU Library General Public License, applies to certain
-designated libraries. This license is quite different from the ordinary
-one; be sure to read it in full, and don't assume that anything in it is
-the same as in the ordinary license.
-
- The reason we have a separate public license for some libraries is that
-they blur the distinction we usually make between modifying or adding to a
-program and simply using it. Linking a program with a library, without
-changing the library, is in some sense simply using the library, and is
-analogous to running a utility program or application program. However, in
-a textual and legal sense, the linked executable is a combined work, a
-derivative of the original library, and the ordinary General Public License
-treats it as such.
-
- Because of this blurred distinction, using the ordinary General
-Public License for libraries did not effectively promote software
-sharing, because most developers did not use the libraries. We
-concluded that weaker conditions might promote sharing better.
-
- However, unrestricted linking of non-free programs would deprive the
-users of those programs of all benefit from the free status of the
-libraries themselves. This Library General Public License is intended to
-permit developers of non-free programs to use free libraries, while
-preserving your freedom as a user of such programs to change the free
-libraries that are incorporated in them. (We have not seen how to achieve
-this as regards changes in header files, but we have achieved it as regards
-changes in the actual functions of the Library.) The hope is that this
-will lead to faster development of free libraries.
-
- The precise terms and conditions for copying, distribution and
-modification follow. Pay close attention to the difference between a
-"work based on the library" and a "work that uses the library". The
-former contains code derived from the library, while the latter only
-works together with the library.
-
- Note that it is possible for a library to be covered by the ordinary
-General Public License rather than by this special one.
-
- GNU LIBRARY GENERAL PUBLIC LICENSE
- TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
-
- 0. This License Agreement applies to any software library which
-contains a notice placed by the copyright holder or other authorized
-party saying it may be distributed under the terms of this Library
-General Public License (also called "this License"). Each licensee is
-addressed as "you".
-
- A "library" means a collection of software functions and/or data
-prepared so as to be conveniently linked with application programs
-(which use some of those functions and data) to form executables.
-
- The "Library", below, refers to any such software library or work
-which has been distributed under these terms. A "work based on the
-Library" means either the Library or any derivative work under
-copyright law: that is to say, a work containing the Library or a
-portion of it, either verbatim or with modifications and/or translated
-straightforwardly into another language. (Hereinafter, translation is
-included without limitation in the term "modification".)
-
- "Source code" for a work means the preferred form of the work for
-making modifications to it. For a library, complete source code means
-all the source code for all modules it contains, plus any associated
-interface definition files, plus the scripts used to control compilation
-and installation of the library.
-
- Activities other than copying, distribution and modification are not
-covered by this License; they are outside its scope. The act of
-running a program using the Library is not restricted, and output from
-such a program is covered only if its contents constitute a work based
-on the Library (independent of the use of the Library in a tool for
-writing it). Whether that is true depends on what the Library does
-and what the program that uses the Library does.
-
- 1. You may copy and distribute verbatim copies of the Library's
-complete source code as you receive it, in any medium, provided that
-you conspicuously and appropriately publish on each copy an
-appropriate copyright notice and disclaimer of warranty; keep intact
-all the notices that refer to this License and to the absence of any
-warranty; and distribute a copy of this License along with the
-Library.
-
- You may charge a fee for the physical act of transferring a copy,
-and you may at your option offer warranty protection in exchange for a
-fee.
-
- 2. You may modify your copy or copies of the Library or any portion
-of it, thus forming a work based on the Library, and copy and
-distribute such modifications or work under the terms of Section 1
-above, provided that you also meet all of these conditions:
-
- a) The modified work must itself be a software library.
-
- b) You must cause the files modified to carry prominent notices
- stating that you changed the files and the date of any change.
-
- c) You must cause the whole of the work to be licensed at no
- charge to all third parties under the terms of this License.
-
- d) If a facility in the modified Library refers to a function or a
- table of data to be supplied by an application program that uses
- the facility, other than as an argument passed when the facility
- is invoked, then you must make a good faith effort to ensure that,
- in the event an application does not supply such function or
- table, the facility still operates, and performs whatever part of
- its purpose remains meaningful.
-
- (For example, a function in a library to compute square roots has
- a purpose that is entirely well-defined independent of the
- application. Therefore, Subsection 2d requires that any
- application-supplied function or table used by this function must
- be optional: if the application does not supply it, the square
- root function must still compute square roots.)
-
-These requirements apply to the modified work as a whole. If
-identifiable sections of that work are not derived from the Library,
-and can be reasonably considered independent and separate works in
-themselves, then this License, and its terms, do not apply to those
-sections when you distribute them as separate works. But when you
-distribute the same sections as part of a whole which is a work based
-on the Library, the distribution of the whole must be on the terms of
-this License, whose permissions for other licensees extend to the
-entire whole, and thus to each and every part regardless of who wrote
-it.
-
-Thus, it is not the intent of this section to claim rights or contest
-your rights to work written entirely by you; rather, the intent is to
-exercise the right to control the distribution of derivative or
-collective works based on the Library.
-
-In addition, mere aggregation of another work not based on the Library
-with the Library (or with a work based on the Library) on a volume of
-a storage or distribution medium does not bring the other work under
-the scope of this License.
-
- 3. You may opt to apply the terms of the ordinary GNU General Public
-License instead of this License to a given copy of the Library. To do
-this, you must alter all the notices that refer to this License, so
-that they refer to the ordinary GNU General Public License, version 2,
-instead of to this License. (If a newer version than version 2 of the
-ordinary GNU General Public License has appeared, then you can specify
-that version instead if you wish.) Do not make any other change in
-these notices.
-
- Once this change is made in a given copy, it is irreversible for
-that copy, so the ordinary GNU General Public License applies to all
-subsequent copies and derivative works made from that copy.
-
- This option is useful when you wish to copy part of the code of
-the Library into a program that is not a library.
-
- 4. You may copy and distribute the Library (or a portion or
-derivative of it, under Section 2) in object code or executable form
-under the terms of Sections 1 and 2 above provided that you accompany
-it with the complete corresponding machine-readable source code, which
-must be distributed under the terms of Sections 1 and 2 above on a
-medium customarily used for software interchange.
-
- If distribution of object code is made by offering access to copy
-from a designated place, then offering equivalent access to copy the
-source code from the same place satisfies the requirement to
-distribute the source code, even though third parties are not
-compelled to copy the source along with the object code.
-
- 5. A program that contains no derivative of any portion of the
-Library, but is designed to work with the Library by being compiled or
-linked with it, is called a "work that uses the Library". Such a
-work, in isolation, is not a derivative work of the Library, and
-therefore falls outside the scope of this License.
-
- However, linking a "work that uses the Library" with the Library
-creates an executable that is a derivative of the Library (because it
-contains portions of the Library), rather than a "work that uses the
-library". The executable is therefore covered by this License.
-Section 6 states terms for distribution of such executables.
-
- When a "work that uses the Library" uses material from a header file
-that is part of the Library, the object code for the work may be a
-derivative work of the Library even though the source code is not.
-Whether this is true is especially significant if the work can be
-linked without the Library, or if the work is itself a library. The
-threshold for this to be true is not precisely defined by law.
-
- If such an object file uses only numerical parameters, data
-structure layouts and accessors, and small macros and small inline
-functions (ten lines or less in length), then the use of the object
-file is unrestricted, regardless of whether it is legally a derivative
-work. (Executables containing this object code plus portions of the
-Library will still fall under Section 6.)
-
- Otherwise, if the work is a derivative of the Library, you may
-distribute the object code for the work under the terms of Section 6.
-Any executables containing that work also fall under Section 6,
-whether or not they are linked directly with the Library itself.
-
- 6. As an exception to the Sections above, you may also compile or
-link a "work that uses the Library" with the Library to produce a
-work containing portions of the Library, and distribute that work
-under terms of your choice, provided that the terms permit
-modification of the work for the customer's own use and reverse
-engineering for debugging such modifications.
-
- You must give prominent notice with each copy of the work that the
-Library is used in it and that the Library and its use are covered by
-this License. You must supply a copy of this License. If the work
-during execution displays copyright notices, you must include the
-copyright notice for the Library among them, as well as a reference
-directing the user to the copy of this License. Also, you must do one
-of these things:
-
- a) Accompany the work with the complete corresponding
- machine-readable source code for the Library including whatever
- changes were used in the work (which must be distributed under
- Sections 1 and 2 above); and, if the work is an executable linked
- with the Library, with the complete machine-readable "work that
- uses the Library", as object code and/or source code, so that the
- user can modify the Library and then relink to produce a modified
- executable containing the modified Library. (It is understood
- that the user who changes the contents of definitions files in the
- Library will not necessarily be able to recompile the application
- to use the modified definitions.)
-
- b) Accompany the work with a written offer, valid for at
- least three years, to give the same user the materials
- specified in Subsection 6a, above, for a charge no more
- than the cost of performing this distribution.
-
- c) If distribution of the work is made by offering access to copy
- from a designated place, offer equivalent access to copy the above
- specified materials from the same place.
-
- d) Verify that the user has already received a copy of these
- materials or that you have already sent this user a copy.
-
- For an executable, the required form of the "work that uses the
-Library" must include any data and utility programs needed for
-reproducing the executable from it. However, as a special exception,
-the source code distributed need not include anything that is normally
-distributed (in either source or binary form) with the major
-components (compiler, kernel, and so on) of the operating system on
-which the executable runs, unless that component itself accompanies
-the executable.
-
- It may happen that this requirement contradicts the license
-restrictions of other proprietary libraries that do not normally
-accompany the operating system. Such a contradiction means you cannot
-use both them and the Library together in an executable that you
-distribute.
-
- 7. You may place library facilities that are a work based on the
-Library side-by-side in a single library together with other library
-facilities not covered by this License, and distribute such a combined
-library, provided that the separate distribution of the work based on
-the Library and of the other library facilities is otherwise
-permitted, and provided that you do these two things:
-
- a) Accompany the combined library with a copy of the same work
- based on the Library, uncombined with any other library
- facilities. This must be distributed under the terms of the
- Sections above.
-
- b) Give prominent notice with the combined library of the fact
- that part of it is a work based on the Library, and explaining
- where to find the accompanying uncombined form of the same work.
-
- 8. You may not copy, modify, sublicense, link with, or distribute
-the Library except as expressly provided under this License. Any
-attempt otherwise to copy, modify, sublicense, link with, or
-distribute the Library is void, and will automatically terminate your
-rights under this License. However, parties who have received copies,
-or rights, from you under this License will not have their licenses
-terminated so long as such parties remain in full compliance.
-
- 9. You are not required to accept this License, since you have not
-signed it. However, nothing else grants you permission to modify or
-distribute the Library or its derivative works. These actions are
-prohibited by law if you do not accept this License. Therefore, by
-modifying or distributing the Library (or any work based on the
-Library), you indicate your acceptance of this License to do so, and
-all its terms and conditions for copying, distributing or modifying
-the Library or works based on it.
-
- 10. Each time you redistribute the Library (or any work based on the
-Library), the recipient automatically receives a license from the
-original licensor to copy, distribute, link with or modify the Library
-subject to these terms and conditions. You may not impose any further
-restrictions on the recipients' exercise of the rights granted herein.
-You are not responsible for enforcing compliance by third parties to
-this License.
-
- 11. If, as a consequence of a court judgment or allegation of patent
-infringement or for any other reason (not limited to patent issues),
-conditions are imposed on you (whether by court order, agreement or
-otherwise) that contradict the conditions of this License, they do not
-excuse you from the conditions of this License. If you cannot
-distribute so as to satisfy simultaneously your obligations under this
-License and any other pertinent obligations, then as a consequence you
-may not distribute the Library at all. For example, if a patent
-license would not permit royalty-free redistribution of the Library by
-all those who receive copies directly or indirectly through you, then
-the only way you could satisfy both it and this License would be to
-refrain entirely from distribution of the Library.
-
-If any portion of this section is held invalid or unenforceable under any
-particular circumstance, the balance of the section is intended to apply,
-and the section as a whole is intended to apply in other circumstances.
-
-It is not the purpose of this section to induce you to infringe any
-patents or other property right claims or to contest validity of any
-such claims; this section has the sole purpose of protecting the
-integrity of the free software distribution system which is
-implemented by public license practices. Many people have made
-generous contributions to the wide range of software distributed
-through that system in reliance on consistent application of that
-system; it is up to the author/donor to decide if he or she is willing
-to distribute software through any other system and a licensee cannot
-impose that choice.
-
-This section is intended to make thoroughly clear what is believed to
-be a consequence of the rest of this License.
-
- 12. If the distribution and/or use of the Library is restricted in
-certain countries either by patents or by copyrighted interfaces, the
-original copyright holder who places the Library under this License may add
-an explicit geographical distribution limitation excluding those countries,
-so that distribution is permitted only in or among countries not thus
-excluded. In such case, this License incorporates the limitation as if
-written in the body of this License.
-
- 13. The Free Software Foundation may publish revised and/or new
-versions of the Library General Public License from time to time.
-Such new versions will be similar in spirit to the present version,
-but may differ in detail to address new problems or concerns.
-
-Each version is given a distinguishing version number. If the Library
-specifies a version number of this License which applies to it and
-"any later version", you have the option of following the terms and
-conditions either of that version or of any later version published by
-the Free Software Foundation. If the Library does not specify a
-license version number, you may choose any version ever published by
-the Free Software Foundation.
-
- 14. If you wish to incorporate parts of the Library into other free
-programs whose distribution conditions are incompatible with these,
-write to the author to ask for permission. For software which is
-copyrighted by the Free Software Foundation, write to the Free
-Software Foundation; we sometimes make exceptions for this. Our
-decision will be guided by the two goals of preserving the free status
-of all derivatives of our free software and of promoting the sharing
-and reuse of software generally.
-
- NO WARRANTY
-
- 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO
-WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.
-EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR
-OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY
-KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
-IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
-PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
-LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME
-THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
-
- 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN
-WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY
-AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU
-FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR
-CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE
-LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
-RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
-FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
-SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
-DAMAGES.
-
- END OF TERMS AND CONDITIONS
-
- How to Apply These Terms to Your New Libraries
-
- If you develop a new library, and you want it to be of the greatest
-possible use to the public, we recommend making it free software that
-everyone can redistribute and change. You can do so by permitting
-redistribution under these terms (or, alternatively, under the terms of the
-ordinary General Public License).
-
- To apply these terms, attach the following notices to the library. It is
-safest to attach them to the start of each source file to most effectively
-convey the exclusion of warranty; and each file should have at least the
-"copyright" line and a pointer to where the full notice is found.
-
- <one line to give the library's name and a brief idea of what it does.>
- Copyright (C) <year> <name of author>
-
- This library is free software; you can redistribute it and/or
- modify it under the terms of the GNU Library General Public
- License as published by the Free Software Foundation; either
- version 2 of the License, or (at your option) any later version.
-
- This library is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- Library General Public License for more details.
-
- You should have received a copy of the GNU Library General Public
- License along with this library; if not, write to the Free
- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-
-Also add information on how to contact you by electronic and paper mail.
-
-You should also get your employer (if you work as a programmer) or your
-school, if any, to sign a "copyright disclaimer" for the library, if
-necessary. Here is a sample; alter the names:
-
- Yoyodyne, Inc., hereby disclaims all copyright interest in the
- library `Frob' (a library for tweaking knobs) written by James Random Hacker.
-
- <signature of Ty Coon>, 1 April 1990
- Ty Coon, President of Vice
-
-That's all there is to it!
Copied: grass/trunk/lib/external/bwidget/LGPL.txt (from rev 35192, grass/trunk/lib/external/bwidget/LGPL.txt)
===================================================================
--- grass/trunk/lib/external/bwidget/LGPL.txt (rev 0)
+++ grass/trunk/lib/external/bwidget/LGPL.txt 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,481 @@
+ GNU LIBRARY GENERAL PUBLIC LICENSE
+ Version 2, June 1991
+
+ Copyright (C) 1991 Free Software Foundation, Inc.
+ 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+[This is the first released version of the library GPL. It is
+ numbered 2 because it goes with version 2 of the ordinary GPL.]
+
+ Preamble
+
+ The licenses for most software are designed to take away your
+freedom to share and change it. By contrast, the GNU General Public
+Licenses are intended to guarantee your freedom to share and change
+free software--to make sure the software is free for all its users.
+
+ This license, the Library General Public License, applies to some
+specially designated Free Software Foundation software, and to any
+other libraries whose authors decide to use it. You can use it for
+your libraries, too.
+
+ When we speak of free software, we are referring to freedom, not
+price. Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+this service if you wish), that you receive source code or can get it
+if you want it, that you can change the software or use pieces of it
+in new free programs; and that you know you can do these things.
+
+ To protect your rights, we need to make restrictions that forbid
+anyone to deny you these rights or to ask you to surrender the rights.
+These restrictions translate to certain responsibilities for you if
+you distribute copies of the library, or if you modify it.
+
+ For example, if you distribute copies of the library, whether gratis
+or for a fee, you must give the recipients all the rights that we gave
+you. You must make sure that they, too, receive or can get the source
+code. If you link a program with the library, you must provide
+complete object files to the recipients so that they can relink them
+with the library, after making changes to the library and recompiling
+it. And you must show them these terms so they know their rights.
+
+ Our method of protecting your rights has two steps: (1) copyright
+the library, and (2) offer you this license which gives you legal
+permission to copy, distribute and/or modify the library.
+
+ Also, for each distributor's protection, we want to make certain
+that everyone understands that there is no warranty for this free
+library. If the library is modified by someone else and passed on, we
+want its recipients to know that what they have is not the original
+version, so that any problems introduced by others will not reflect on
+the original authors' reputations.
+
+ Finally, any free program is threatened constantly by software
+patents. We wish to avoid the danger that companies distributing free
+software will individually obtain patent licenses, thus in effect
+transforming the program into proprietary software. To prevent this,
+we have made it clear that any patent must be licensed for everyone's
+free use or not licensed at all.
+
+ Most GNU software, including some libraries, is covered by the ordinary
+GNU General Public License, which was designed for utility programs. This
+license, the GNU Library General Public License, applies to certain
+designated libraries. This license is quite different from the ordinary
+one; be sure to read it in full, and don't assume that anything in it is
+the same as in the ordinary license.
+
+ The reason we have a separate public license for some libraries is that
+they blur the distinction we usually make between modifying or adding to a
+program and simply using it. Linking a program with a library, without
+changing the library, is in some sense simply using the library, and is
+analogous to running a utility program or application program. However, in
+a textual and legal sense, the linked executable is a combined work, a
+derivative of the original library, and the ordinary General Public License
+treats it as such.
+
+ Because of this blurred distinction, using the ordinary General
+Public License for libraries did not effectively promote software
+sharing, because most developers did not use the libraries. We
+concluded that weaker conditions might promote sharing better.
+
+ However, unrestricted linking of non-free programs would deprive the
+users of those programs of all benefit from the free status of the
+libraries themselves. This Library General Public License is intended to
+permit developers of non-free programs to use free libraries, while
+preserving your freedom as a user of such programs to change the free
+libraries that are incorporated in them. (We have not seen how to achieve
+this as regards changes in header files, but we have achieved it as regards
+changes in the actual functions of the Library.) The hope is that this
+will lead to faster development of free libraries.
+
+ The precise terms and conditions for copying, distribution and
+modification follow. Pay close attention to the difference between a
+"work based on the library" and a "work that uses the library". The
+former contains code derived from the library, while the latter only
+works together with the library.
+
+ Note that it is possible for a library to be covered by the ordinary
+General Public License rather than by this special one.
+
+ GNU LIBRARY GENERAL PUBLIC LICENSE
+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+ 0. This License Agreement applies to any software library which
+contains a notice placed by the copyright holder or other authorized
+party saying it may be distributed under the terms of this Library
+General Public License (also called "this License"). Each licensee is
+addressed as "you".
+
+ A "library" means a collection of software functions and/or data
+prepared so as to be conveniently linked with application programs
+(which use some of those functions and data) to form executables.
+
+ The "Library", below, refers to any such software library or work
+which has been distributed under these terms. A "work based on the
+Library" means either the Library or any derivative work under
+copyright law: that is to say, a work containing the Library or a
+portion of it, either verbatim or with modifications and/or translated
+straightforwardly into another language. (Hereinafter, translation is
+included without limitation in the term "modification".)
+
+ "Source code" for a work means the preferred form of the work for
+making modifications to it. For a library, complete source code means
+all the source code for all modules it contains, plus any associated
+interface definition files, plus the scripts used to control compilation
+and installation of the library.
+
+ Activities other than copying, distribution and modification are not
+covered by this License; they are outside its scope. The act of
+running a program using the Library is not restricted, and output from
+such a program is covered only if its contents constitute a work based
+on the Library (independent of the use of the Library in a tool for
+writing it). Whether that is true depends on what the Library does
+and what the program that uses the Library does.
+
+ 1. You may copy and distribute verbatim copies of the Library's
+complete source code as you receive it, in any medium, provided that
+you conspicuously and appropriately publish on each copy an
+appropriate copyright notice and disclaimer of warranty; keep intact
+all the notices that refer to this License and to the absence of any
+warranty; and distribute a copy of this License along with the
+Library.
+
+ You may charge a fee for the physical act of transferring a copy,
+and you may at your option offer warranty protection in exchange for a
+fee.
+
+ 2. You may modify your copy or copies of the Library or any portion
+of it, thus forming a work based on the Library, and copy and
+distribute such modifications or work under the terms of Section 1
+above, provided that you also meet all of these conditions:
+
+ a) The modified work must itself be a software library.
+
+ b) You must cause the files modified to carry prominent notices
+ stating that you changed the files and the date of any change.
+
+ c) You must cause the whole of the work to be licensed at no
+ charge to all third parties under the terms of this License.
+
+ d) If a facility in the modified Library refers to a function or a
+ table of data to be supplied by an application program that uses
+ the facility, other than as an argument passed when the facility
+ is invoked, then you must make a good faith effort to ensure that,
+ in the event an application does not supply such function or
+ table, the facility still operates, and performs whatever part of
+ its purpose remains meaningful.
+
+ (For example, a function in a library to compute square roots has
+ a purpose that is entirely well-defined independent of the
+ application. Therefore, Subsection 2d requires that any
+ application-supplied function or table used by this function must
+ be optional: if the application does not supply it, the square
+ root function must still compute square roots.)
+
+These requirements apply to the modified work as a whole. If
+identifiable sections of that work are not derived from the Library,
+and can be reasonably considered independent and separate works in
+themselves, then this License, and its terms, do not apply to those
+sections when you distribute them as separate works. But when you
+distribute the same sections as part of a whole which is a work based
+on the Library, the distribution of the whole must be on the terms of
+this License, whose permissions for other licensees extend to the
+entire whole, and thus to each and every part regardless of who wrote
+it.
+
+Thus, it is not the intent of this section to claim rights or contest
+your rights to work written entirely by you; rather, the intent is to
+exercise the right to control the distribution of derivative or
+collective works based on the Library.
+
+In addition, mere aggregation of another work not based on the Library
+with the Library (or with a work based on the Library) on a volume of
+a storage or distribution medium does not bring the other work under
+the scope of this License.
+
+ 3. You may opt to apply the terms of the ordinary GNU General Public
+License instead of this License to a given copy of the Library. To do
+this, you must alter all the notices that refer to this License, so
+that they refer to the ordinary GNU General Public License, version 2,
+instead of to this License. (If a newer version than version 2 of the
+ordinary GNU General Public License has appeared, then you can specify
+that version instead if you wish.) Do not make any other change in
+these notices.
+
+ Once this change is made in a given copy, it is irreversible for
+that copy, so the ordinary GNU General Public License applies to all
+subsequent copies and derivative works made from that copy.
+
+ This option is useful when you wish to copy part of the code of
+the Library into a program that is not a library.
+
+ 4. You may copy and distribute the Library (or a portion or
+derivative of it, under Section 2) in object code or executable form
+under the terms of Sections 1 and 2 above provided that you accompany
+it with the complete corresponding machine-readable source code, which
+must be distributed under the terms of Sections 1 and 2 above on a
+medium customarily used for software interchange.
+
+ If distribution of object code is made by offering access to copy
+from a designated place, then offering equivalent access to copy the
+source code from the same place satisfies the requirement to
+distribute the source code, even though third parties are not
+compelled to copy the source along with the object code.
+
+ 5. A program that contains no derivative of any portion of the
+Library, but is designed to work with the Library by being compiled or
+linked with it, is called a "work that uses the Library". Such a
+work, in isolation, is not a derivative work of the Library, and
+therefore falls outside the scope of this License.
+
+ However, linking a "work that uses the Library" with the Library
+creates an executable that is a derivative of the Library (because it
+contains portions of the Library), rather than a "work that uses the
+library". The executable is therefore covered by this License.
+Section 6 states terms for distribution of such executables.
+
+ When a "work that uses the Library" uses material from a header file
+that is part of the Library, the object code for the work may be a
+derivative work of the Library even though the source code is not.
+Whether this is true is especially significant if the work can be
+linked without the Library, or if the work is itself a library. The
+threshold for this to be true is not precisely defined by law.
+
+ If such an object file uses only numerical parameters, data
+structure layouts and accessors, and small macros and small inline
+functions (ten lines or less in length), then the use of the object
+file is unrestricted, regardless of whether it is legally a derivative
+work. (Executables containing this object code plus portions of the
+Library will still fall under Section 6.)
+
+ Otherwise, if the work is a derivative of the Library, you may
+distribute the object code for the work under the terms of Section 6.
+Any executables containing that work also fall under Section 6,
+whether or not they are linked directly with the Library itself.
+
+ 6. As an exception to the Sections above, you may also compile or
+link a "work that uses the Library" with the Library to produce a
+work containing portions of the Library, and distribute that work
+under terms of your choice, provided that the terms permit
+modification of the work for the customer's own use and reverse
+engineering for debugging such modifications.
+
+ You must give prominent notice with each copy of the work that the
+Library is used in it and that the Library and its use are covered by
+this License. You must supply a copy of this License. If the work
+during execution displays copyright notices, you must include the
+copyright notice for the Library among them, as well as a reference
+directing the user to the copy of this License. Also, you must do one
+of these things:
+
+ a) Accompany the work with the complete corresponding
+ machine-readable source code for the Library including whatever
+ changes were used in the work (which must be distributed under
+ Sections 1 and 2 above); and, if the work is an executable linked
+ with the Library, with the complete machine-readable "work that
+ uses the Library", as object code and/or source code, so that the
+ user can modify the Library and then relink to produce a modified
+ executable containing the modified Library. (It is understood
+ that the user who changes the contents of definitions files in the
+ Library will not necessarily be able to recompile the application
+ to use the modified definitions.)
+
+ b) Accompany the work with a written offer, valid for at
+ least three years, to give the same user the materials
+ specified in Subsection 6a, above, for a charge no more
+ than the cost of performing this distribution.
+
+ c) If distribution of the work is made by offering access to copy
+ from a designated place, offer equivalent access to copy the above
+ specified materials from the same place.
+
+ d) Verify that the user has already received a copy of these
+ materials or that you have already sent this user a copy.
+
+ For an executable, the required form of the "work that uses the
+Library" must include any data and utility programs needed for
+reproducing the executable from it. However, as a special exception,
+the source code distributed need not include anything that is normally
+distributed (in either source or binary form) with the major
+components (compiler, kernel, and so on) of the operating system on
+which the executable runs, unless that component itself accompanies
+the executable.
+
+ It may happen that this requirement contradicts the license
+restrictions of other proprietary libraries that do not normally
+accompany the operating system. Such a contradiction means you cannot
+use both them and the Library together in an executable that you
+distribute.
+
+ 7. You may place library facilities that are a work based on the
+Library side-by-side in a single library together with other library
+facilities not covered by this License, and distribute such a combined
+library, provided that the separate distribution of the work based on
+the Library and of the other library facilities is otherwise
+permitted, and provided that you do these two things:
+
+ a) Accompany the combined library with a copy of the same work
+ based on the Library, uncombined with any other library
+ facilities. This must be distributed under the terms of the
+ Sections above.
+
+ b) Give prominent notice with the combined library of the fact
+ that part of it is a work based on the Library, and explaining
+ where to find the accompanying uncombined form of the same work.
+
+ 8. You may not copy, modify, sublicense, link with, or distribute
+the Library except as expressly provided under this License. Any
+attempt otherwise to copy, modify, sublicense, link with, or
+distribute the Library is void, and will automatically terminate your
+rights under this License. However, parties who have received copies,
+or rights, from you under this License will not have their licenses
+terminated so long as such parties remain in full compliance.
+
+ 9. You are not required to accept this License, since you have not
+signed it. However, nothing else grants you permission to modify or
+distribute the Library or its derivative works. These actions are
+prohibited by law if you do not accept this License. Therefore, by
+modifying or distributing the Library (or any work based on the
+Library), you indicate your acceptance of this License to do so, and
+all its terms and conditions for copying, distributing or modifying
+the Library or works based on it.
+
+ 10. Each time you redistribute the Library (or any work based on the
+Library), the recipient automatically receives a license from the
+original licensor to copy, distribute, link with or modify the Library
+subject to these terms and conditions. You may not impose any further
+restrictions on the recipients' exercise of the rights granted herein.
+You are not responsible for enforcing compliance by third parties to
+this License.
+
+ 11. If, as a consequence of a court judgment or allegation of patent
+infringement or for any other reason (not limited to patent issues),
+conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License. If you cannot
+distribute so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you
+may not distribute the Library at all. For example, if a patent
+license would not permit royalty-free redistribution of the Library by
+all those who receive copies directly or indirectly through you, then
+the only way you could satisfy both it and this License would be to
+refrain entirely from distribution of the Library.
+
+If any portion of this section is held invalid or unenforceable under any
+particular circumstance, the balance of the section is intended to apply,
+and the section as a whole is intended to apply in other circumstances.
+
+It is not the purpose of this section to induce you to infringe any
+patents or other property right claims or to contest validity of any
+such claims; this section has the sole purpose of protecting the
+integrity of the free software distribution system which is
+implemented by public license practices. Many people have made
+generous contributions to the wide range of software distributed
+through that system in reliance on consistent application of that
+system; it is up to the author/donor to decide if he or she is willing
+to distribute software through any other system and a licensee cannot
+impose that choice.
+
+This section is intended to make thoroughly clear what is believed to
+be a consequence of the rest of this License.
+
+ 12. If the distribution and/or use of the Library is restricted in
+certain countries either by patents or by copyrighted interfaces, the
+original copyright holder who places the Library under this License may add
+an explicit geographical distribution limitation excluding those countries,
+so that distribution is permitted only in or among countries not thus
+excluded. In such case, this License incorporates the limitation as if
+written in the body of this License.
+
+ 13. The Free Software Foundation may publish revised and/or new
+versions of the Library General Public License from time to time.
+Such new versions will be similar in spirit to the present version,
+but may differ in detail to address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Library
+specifies a version number of this License which applies to it and
+"any later version", you have the option of following the terms and
+conditions either of that version or of any later version published by
+the Free Software Foundation. If the Library does not specify a
+license version number, you may choose any version ever published by
+the Free Software Foundation.
+
+ 14. If you wish to incorporate parts of the Library into other free
+programs whose distribution conditions are incompatible with these,
+write to the author to ask for permission. For software which is
+copyrighted by the Free Software Foundation, write to the Free
+Software Foundation; we sometimes make exceptions for this. Our
+decision will be guided by the two goals of preserving the free status
+of all derivatives of our free software and of promoting the sharing
+and reuse of software generally.
+
+ NO WARRANTY
+
+ 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO
+WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.
+EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR
+OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY
+KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
+LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME
+THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+ 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN
+WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY
+AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU
+FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR
+CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE
+LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
+RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
+FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
+SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
+DAMAGES.
+
+ END OF TERMS AND CONDITIONS
+
+ How to Apply These Terms to Your New Libraries
+
+ If you develop a new library, and you want it to be of the greatest
+possible use to the public, we recommend making it free software that
+everyone can redistribute and change. You can do so by permitting
+redistribution under these terms (or, alternatively, under the terms of the
+ordinary General Public License).
+
+ To apply these terms, attach the following notices to the library. It is
+safest to attach them to the start of each source file to most effectively
+convey the exclusion of warranty; and each file should have at least the
+"copyright" line and a pointer to where the full notice is found.
+
+ <one line to give the library's name and a brief idea of what it does.>
+ Copyright (C) <year> <name of author>
+
+ This library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Library General Public
+ License as published by the Free Software Foundation; either
+ version 2 of the License, or (at your option) any later version.
+
+ This library is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ Library General Public License for more details.
+
+ You should have received a copy of the GNU Library General Public
+ License along with this library; if not, write to the Free
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+Also add information on how to contact you by electronic and paper mail.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the library, if
+necessary. Here is a sample; alter the names:
+
+ Yoyodyne, Inc., hereby disclaims all copyright interest in the
+ library `Frob' (a library for tweaking knobs) written by James Random Hacker.
+
+ <signature of Ty Coon>, 1 April 1990
+ Ty Coon, President of Vice
+
+That's all there is to it!
Deleted: grass/trunk/lib/external/bwidget/LICENSE.txt
===================================================================
--- grass/trunk/lib/external/bwidget/LICENSE.txt 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/LICENSE.txt 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,17 +0,0 @@
-BWidget ToolKit
-Copyright (c) 1998-1999 UNIFIX.
-
-This library is free software; you can redistribute it and/or
-modify it under the terms of the GNU Library General Public
-License as published by the Free Software Foundation; either
-version 2 of the License, or (at your option) any later version.
-
-This library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-Library General Public License for more details.
-
-You should have received a copy of the GNU Library General Public
-License along with this library; if not, write to the
-Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA.
Copied: grass/trunk/lib/external/bwidget/LICENSE.txt (from rev 35192, grass/trunk/lib/external/bwidget/LICENSE.txt)
===================================================================
--- grass/trunk/lib/external/bwidget/LICENSE.txt (rev 0)
+++ grass/trunk/lib/external/bwidget/LICENSE.txt 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,17 @@
+BWidget ToolKit
+Copyright (c) 1998-1999 UNIFIX.
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the GNU Library General Public
+License as published by the Free Software Foundation; either
+version 2 of the License, or (at your option) any later version.
+
+This library is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+Library General Public License for more details.
+
+You should have received a copy of the GNU Library General Public
+License along with this library; if not, write to the
+Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.
Deleted: grass/trunk/lib/external/bwidget/Makefile
===================================================================
--- grass/trunk/lib/external/bwidget/Makefile 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/Makefile 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,17 +0,0 @@
-MODULE_TOPDIR = ../../..
-
-include $(MODULE_TOPDIR)/include/Make/Other.make
-
-BWIDGETDIR = $(ARCH_DISTDIR)/bwidget
-
-SRCFILES := $(wildcard images/*.* lang/*.* *.tcl *.txt) README.grass
-DSTFILES := $(patsubst %,$(BWIDGETDIR)/%,$(SRCFILES))
-
-default:
- if [ ! -d $(BWIDGETDIR) ]; then $(MKDIR) $(BWIDGETDIR); fi
- if [ ! -d $(BWIDGETDIR)/images ]; then $(MKDIR) $(BWIDGETDIR)/images; fi
- if [ ! -d $(BWIDGETDIR)/lang ]; then $(MKDIR) $(BWIDGETDIR)/lang; fi
- $(MAKE) $(DSTFILES)
-
-$(BWIDGETDIR)/%: %
- $(INSTALL_DATA) $< $@
Copied: grass/trunk/lib/external/bwidget/Makefile (from rev 35192, grass/trunk/lib/external/bwidget/Makefile)
===================================================================
--- grass/trunk/lib/external/bwidget/Makefile (rev 0)
+++ grass/trunk/lib/external/bwidget/Makefile 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,17 @@
+MODULE_TOPDIR = ../../..
+
+include $(MODULE_TOPDIR)/include/Make/Other.make
+
+BWIDGETDIR = $(ARCH_DISTDIR)/bwidget
+
+SRCFILES := $(wildcard images/*.* lang/*.* *.tcl *.txt) README.grass
+DSTFILES := $(patsubst %,$(BWIDGETDIR)/%,$(SRCFILES))
+
+default:
+ if [ ! -d $(BWIDGETDIR) ]; then $(MKDIR) $(BWIDGETDIR); fi
+ if [ ! -d $(BWIDGETDIR)/images ]; then $(MKDIR) $(BWIDGETDIR)/images; fi
+ if [ ! -d $(BWIDGETDIR)/lang ]; then $(MKDIR) $(BWIDGETDIR)/lang; fi
+ $(MAKE) $(DSTFILES)
+
+$(BWIDGETDIR)/%: %
+ $(INSTALL_DATA) $< $@
Deleted: grass/trunk/lib/external/bwidget/README
===================================================================
--- grass/trunk/lib/external/bwidget/README 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/README 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,149 +0,0 @@
-07/09/1999
-BWidget ToolKit 1.2.1
-Copyright (c) 1998-1999 UNIFIX.
-
---------------------------------------------------------------------------
-WHAT IS BWIDGET ?
-
-The BWidget Toolkit is a high-level Widgets Set for Tcl/Tk built using
-native Tcl/Tk 8.x namespaces.
-
-The BWidgets have a professional look&feel as in other well known Toolkits
-(Tix or Incr Widget) but the concept is radically different because everything is
-native so no platform compilation, no compiled extension library are needed.
-The code is 100% Pure Tcl/Tk.
-
-
---------------------------------------------------------------------------
-WIDGET LIST (1.2.1)
-
-Simple Widgets
- Label Extended Label widget
- Entry Extended Entry widget
- Button Extended Button widget
- ArrowButton Button widget with an arrow shape.
- ProgressBar Progress indicator widget
- ScrollView Display the visible area of a scrolled window
- Separator 3D separator widget
-
-Manager Widgets
- MainFrame Manage toplevel with menu, toolbar and statusbar
- LabelFrame Frame with a Label
- TitleFrame Frame with a title
- ScrolledWindow Generic scrolled widget
- ScrollableFrame Scrollable frame containing widget
- PanedWindow Tiled layout manager widget
- ButtonBox Set of buttons with horizontal or vertical layout
- PagesManager Pages manager widget
- NoteBook Notebook manager widget
- Dialog Dialog abstraction with custom buttons
-
-Composite Widgets
- LabelEntry LabelFrame containing an Entry widget.
- ComboBox ComboBox widget
- SpinBox SpinBox widget
- Tree Tree widget
- ListBox ListBox widget
- MessageDlg Message dialog box
- ProgressDlg Progress indicator dialog box
- PasswdDlg Login/Password dialog box (contributed by Stephane Lavirotte)
- SelectFont Font selection widget
- SelectColor Color selection widget
-
-Commands Classes
- Widget The Widget base class
- DynamicHelp Provide help to Tk widget or BWidget
- DragSite Commands set for Drag facilities
- DropSite Commands set for Drop facilities
- BWidget Utilities
-
---------------------------------------------------------------------------
-INSTALLATION AND USE
-
-- On Unix Platform:
- Uncompress the file BWidget-1.2.1.tar.Z or BWidget-1.2.1.tar.gz
-
- To use the BWidget:
- - If you have uncompressed the archive file under the Tcl Library Path
- directory, you only need to do:
- % package require BWidget
- - If not, you have to specify the BWidget installation path in auto_path
- global variable:
- % lappend auto_path <install_path>
- % package require BWidget
-
- To launch the demo, you need to cd into the demo subdirectory:
- $ cd <install_path>/demo
- $ wish demo.tcl
-
-- On Windows and others Platforms:
- Uncompress the file BWidget-1.2.1.zip
-
- To use the BWidget:
- - If you uncompressed the archive file under the Tcl Library Path
- directory, you only need to do:
- % package require BWidget
- - If not, you have to specify the BWidget installation path in auto_path
- global variable:
- % lappend auto_path your_path
- % package require BWidget
-
- To launch the demo :
- Double click on demo.tcl in the demo subdirectory
-
-
-Distribution contains these directories:
-
-BWidget-1.2 Root directory and BWidget Tcl sources
- BWman HTML manual pages
- images images used by BWidget
- lang Resources for language customization
- demo Demo sources
-
-
---------------------------------------------------------------------------
-DOCUMENTATION
-
-HTML manual pages are available in the BWman subdirectory.
-Points to index.html for frame version with tree navigation,
-or to contents.html for no frame version.
-
-Look at http://www.unifix-online.com/BWidget for last revision
-of manual pages.
-
-
---------------------------------------------------------------------------
-LICENSE
-
-BWidget ToolKit 1.2.1
-Copyright (c) 1998-1999 UNIFIX.
-
-This library is free software; you can redistribute it and/or
-modify it under the terms of the GNU Library General Public
-License as published by the Free Software Foundation; either
-version 2 of the License, or (at your option) any later version.
-
-This library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-Library General Public License for more details.
-
-You should have received a copy of the GNU Library General Public
-License along with this library; if not, write to the
-Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA.
-
-
-License is also in LICENSE.txt. You can find LGPL.txt too.
-
---------------------------------------------------------------------------
-CONTACTS
-
-Old Mail mailto:bwidget at unifix-online.com
-Old Home page http://www.unifix-online.com/BWidget/
-New Home page https://sourceforge.net/project/showfiles.php?group_id=12883
-
-Bug Report and FAQ : See Home Page
-
-
-
Copied: grass/trunk/lib/external/bwidget/README (from rev 35192, grass/trunk/lib/external/bwidget/README)
===================================================================
--- grass/trunk/lib/external/bwidget/README (rev 0)
+++ grass/trunk/lib/external/bwidget/README 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,149 @@
+07/09/1999
+BWidget ToolKit 1.2.1
+Copyright (c) 1998-1999 UNIFIX.
+
+--------------------------------------------------------------------------
+WHAT IS BWIDGET ?
+
+The BWidget Toolkit is a high-level Widgets Set for Tcl/Tk built using
+native Tcl/Tk 8.x namespaces.
+
+The BWidgets have a professional look&feel as in other well known Toolkits
+(Tix or Incr Widget) but the concept is radically different because everything is
+native so no platform compilation, no compiled extension library are needed.
+The code is 100% Pure Tcl/Tk.
+
+
+--------------------------------------------------------------------------
+WIDGET LIST (1.2.1)
+
+Simple Widgets
+ Label Extended Label widget
+ Entry Extended Entry widget
+ Button Extended Button widget
+ ArrowButton Button widget with an arrow shape.
+ ProgressBar Progress indicator widget
+ ScrollView Display the visible area of a scrolled window
+ Separator 3D separator widget
+
+Manager Widgets
+ MainFrame Manage toplevel with menu, toolbar and statusbar
+ LabelFrame Frame with a Label
+ TitleFrame Frame with a title
+ ScrolledWindow Generic scrolled widget
+ ScrollableFrame Scrollable frame containing widget
+ PanedWindow Tiled layout manager widget
+ ButtonBox Set of buttons with horizontal or vertical layout
+ PagesManager Pages manager widget
+ NoteBook Notebook manager widget
+ Dialog Dialog abstraction with custom buttons
+
+Composite Widgets
+ LabelEntry LabelFrame containing an Entry widget.
+ ComboBox ComboBox widget
+ SpinBox SpinBox widget
+ Tree Tree widget
+ ListBox ListBox widget
+ MessageDlg Message dialog box
+ ProgressDlg Progress indicator dialog box
+ PasswdDlg Login/Password dialog box (contributed by Stephane Lavirotte)
+ SelectFont Font selection widget
+ SelectColor Color selection widget
+
+Commands Classes
+ Widget The Widget base class
+ DynamicHelp Provide help to Tk widget or BWidget
+ DragSite Commands set for Drag facilities
+ DropSite Commands set for Drop facilities
+ BWidget Utilities
+
+--------------------------------------------------------------------------
+INSTALLATION AND USE
+
+- On Unix Platform:
+ Uncompress the file BWidget-1.2.1.tar.Z or BWidget-1.2.1.tar.gz
+
+ To use the BWidget:
+ - If you have uncompressed the archive file under the Tcl Library Path
+ directory, you only need to do:
+ % package require BWidget
+ - If not, you have to specify the BWidget installation path in auto_path
+ global variable:
+ % lappend auto_path <install_path>
+ % package require BWidget
+
+ To launch the demo, you need to cd into the demo subdirectory:
+ $ cd <install_path>/demo
+ $ wish demo.tcl
+
+- On Windows and others Platforms:
+ Uncompress the file BWidget-1.2.1.zip
+
+ To use the BWidget:
+ - If you uncompressed the archive file under the Tcl Library Path
+ directory, you only need to do:
+ % package require BWidget
+ - If not, you have to specify the BWidget installation path in auto_path
+ global variable:
+ % lappend auto_path your_path
+ % package require BWidget
+
+ To launch the demo :
+ Double click on demo.tcl in the demo subdirectory
+
+
+Distribution contains these directories:
+
+BWidget-1.2 Root directory and BWidget Tcl sources
+ BWman HTML manual pages
+ images images used by BWidget
+ lang Resources for language customization
+ demo Demo sources
+
+
+--------------------------------------------------------------------------
+DOCUMENTATION
+
+HTML manual pages are available in the BWman subdirectory.
+Points to index.html for frame version with tree navigation,
+or to contents.html for no frame version.
+
+Look at http://www.unifix-online.com/BWidget for last revision
+of manual pages.
+
+
+--------------------------------------------------------------------------
+LICENSE
+
+BWidget ToolKit 1.2.1
+Copyright (c) 1998-1999 UNIFIX.
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the GNU Library General Public
+License as published by the Free Software Foundation; either
+version 2 of the License, or (at your option) any later version.
+
+This library is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+Library General Public License for more details.
+
+You should have received a copy of the GNU Library General Public
+License along with this library; if not, write to the
+Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.
+
+
+License is also in LICENSE.txt. You can find LGPL.txt too.
+
+--------------------------------------------------------------------------
+CONTACTS
+
+Old Mail mailto:bwidget at unifix-online.com
+Old Home page http://www.unifix-online.com/BWidget/
+New Home page https://sourceforge.net/project/showfiles.php?group_id=12883
+
+Bug Report and FAQ : See Home Page
+
+
+
Deleted: grass/trunk/lib/external/bwidget/README.grass
===================================================================
--- grass/trunk/lib/external/bwidget/README.grass 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/README.grass 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,38 +0,0 @@
-README.grass - written by Justin Hickey - jhickey at hpcc.nectec.or.th
-
-This directory contains an extension to Tcl/Tk (called BWidget) that provides
-new and enhanced widgets. It is not a new interpreter but simply Tcl/Tk files
-that provide the functionality. Therefore, there is nothing to compile and it
-only requires 2 lines of code in your Tcl/Tk script to use the new widgets.
-Some of the new widgets include
-
- On mouse over help balloons
- Tabbed notebook panes - like worksheets in Excel
- Directory tree listing
- Combination box or drop down option list
- Progress bar
- Many others
-
-For a demonstration of the new widgets available perform the following
-
- cd demo
- wish demo.tcl
-
-It may take some time to load, but it demonstrates all or most of the new
-features.
-
-To use these widgets with GRASS Tcl/Tk scripts (including tcltkgrass) then add
-the following two lines to your main Tcl/Tk script
-
- lappend auto_path $env(GISBASE)/bwidget
- package require BWidget
-
-Then simply use the new widgets as if they were already part of Tcl/Tk. To find
-out more information on using the new widgets see the manual pages in
-./BWman/index.html
-
-For more information on BWidget see their home page at
-
-http://www.unifix-online.com/BWidget/
-
-or read the README file in this directory.
Copied: grass/trunk/lib/external/bwidget/README.grass (from rev 35192, grass/trunk/lib/external/bwidget/README.grass)
===================================================================
--- grass/trunk/lib/external/bwidget/README.grass (rev 0)
+++ grass/trunk/lib/external/bwidget/README.grass 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,38 @@
+README.grass - written by Justin Hickey - jhickey at hpcc.nectec.or.th
+
+This directory contains an extension to Tcl/Tk (called BWidget) that provides
+new and enhanced widgets. It is not a new interpreter but simply Tcl/Tk files
+that provide the functionality. Therefore, there is nothing to compile and it
+only requires 2 lines of code in your Tcl/Tk script to use the new widgets.
+Some of the new widgets include
+
+ On mouse over help balloons
+ Tabbed notebook panes - like worksheets in Excel
+ Directory tree listing
+ Combination box or drop down option list
+ Progress bar
+ Many others
+
+For a demonstration of the new widgets available perform the following
+
+ cd demo
+ wish demo.tcl
+
+It may take some time to load, but it demonstrates all or most of the new
+features.
+
+To use these widgets with GRASS Tcl/Tk scripts (including tcltkgrass) then add
+the following two lines to your main Tcl/Tk script
+
+ lappend auto_path $env(GISBASE)/bwidget
+ package require BWidget
+
+Then simply use the new widgets as if they were already part of Tcl/Tk. To find
+out more information on using the new widgets see the manual pages in
+./BWman/index.html
+
+For more information on BWidget see their home page at
+
+http://www.unifix-online.com/BWidget/
+
+or read the README file in this directory.
Deleted: grass/trunk/lib/external/bwidget/arrow.tcl
===================================================================
--- grass/trunk/lib/external/bwidget/arrow.tcl 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/arrow.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,548 +0,0 @@
-# ------------------------------------------------------------------------------
-# arrow.tcl
-# This file is part of Unifix BWidget Toolkit
-# ------------------------------------------------------------------------------
-# Index of commands:
-# Public commands
-# - ArrowButton::create
-# - ArrowButton::configure
-# - ArrowButton::cget
-# - ArrowButton::invoke
-# Private commands (redraw commands)
-# - ArrowButton::_redraw
-# - ArrowButton::_redraw_state
-# - ArrowButton::_redraw_relief
-# - ArrowButton::_redraw_whole
-# Private commands (event bindings)
-# - ArrowButton::_destroy
-# - ArrowButton::_enter
-# - ArrowButton::_leave
-# - ArrowButton::_press
-# - ArrowButton::_release
-# - ArrowButton::_repeat
-# ------------------------------------------------------------------------------
-
-namespace eval ArrowButton {
-
- Widget::tkinclude ArrowButton button :cmd \
- include {
- -borderwidth -bd -background -bg -relief
- -highlightbackground -highlightcolor -highlightthickness -takefocus}
-
- Widget::declare ArrowButton {
- {-type Enum button 0 {arrow button}}
- {-dir Enum top 0 {top bottom left right}}
- {-width Int 15 0 {=0}}
- {-height Int 15 0 {=0}}
- {-ipadx Int 0 0 {=0}}
- {-ipady Int 0 0 {=0}}
- {-clean Int 2 0 {=0 =2}}
- {-activeforeground TkResource "" 0 button}
- {-activebackground TkResource "" 0 button}
- {-disabledforeground TkResource "" 0 button}
- {-foreground TkResource "" 0 button}
- {-state TkResource "" 0 button}
-
- {-troughcolor TkResource "" 0 scrollbar}
- {-arrowbd Int 1 0 {=1 =2}}
- {-arrowrelief Enum raised 0 {raised sunken}}
-
- {-command String "" 0}
- {-armcommand String "" 0}
- {-disarmcommand String "" 0}
- {-repeatdelay Int 0 0 {=0}}
- {-repeatinterval Int 0 0 {=0}}
-
- {-bd Synonym -borderwidth}
- {-fg Synonym -foreground}
- }
- DynamicHelp::include ArrowButton balloon
-
- proc ::ArrowButton { path args } { return [eval ArrowButton::create $path $args] }
-
- proc use {} {}
-
- bind BwArrowButton <Enter> {ArrowButton::_enter %W}
- bind BwArrowButton <Leave> {ArrowButton::_leave %W}
- bind BwArrowButton <ButtonPress-1> {ArrowButton::_press %W}
- bind BwArrowButton <ButtonRelease-1> {ArrowButton::_release %W}
- bind BwArrowButton <Key-space> {ArrowButton::invoke %W; break}
- bind BwArrowButton <Return> {ArrowButton::invoke %W; break}
- bind BwArrowButton <Configure> {ArrowButton::_redraw_whole %W %w %h}
- bind BwArrowButton <Destroy> {ArrowButton::_destroy %W}
-
- variable _grab
- variable _moved
-
- array set _grab {current "" pressed "" oldstate "" oldrelief ""}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ArrowButton::create
-# ------------------------------------------------------------------------------
-proc ArrowButton::create { path args } {
- variable _moved
-
- Widget::init ArrowButton $path $args
-
- set w [Widget::getoption $path -width]
- set h [Widget::getoption $path -height]
- set bd [Widget::getoption $path -borderwidth]
- set ht [Widget::getoption $path -highlightthickness]
- set pad [expr {2*($bd+$ht)}]
-
- eval canvas $path [Widget::subcget $path :cmd] \
- -width [expr {$w-$pad}] -height [expr {$h-$pad}]
- bindtags $path [list $path BwArrowButton [winfo toplevel $path] all]
-
- DynamicHelp::sethelp $path $path 1
-
- set _moved($path) 0
-
- rename $path ::$path:cmd
- proc ::$path { cmd args } "return \[eval ArrowButton::\$cmd $path \$args\]"
-
- return $path
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ArrowButton::configure
-# ------------------------------------------------------------------------------
-proc ArrowButton::configure { path args } {
- set res [Widget::configure $path $args]
-
- set ch1 [expr {[Widget::hasChanged $path -width w] |
- [Widget::hasChanged $path -height h] |
- [Widget::hasChanged $path -borderwidth bd] |
- [Widget::hasChanged $path -highlightthickness ht]}]
- set ch2 [expr {[Widget::hasChanged $path -type val] |
- [Widget::hasChanged $path -ipadx val] |
- [Widget::hasChanged $path -ipady val] |
- [Widget::hasChanged $path -arrowbd val] |
- [Widget::hasChanged $path -clean val] |
- [Widget::hasChanged $path -dir val]}]
-
- if { $ch1 } {
- set pad [expr {2*($bd+$ht)}]
- $path:cmd configure \
- -width [expr {$w-$pad}] -height [expr {$h-$pad}] \
- -borderwidth $bd -highlightthickness $ht
- } elseif { $ch2 } {
- _redraw_whole $path [winfo width $path] [winfo height $path]
- } else {
- _redraw_relief $path
- _redraw_state $path
- }
- DynamicHelp::sethelp $path $path
-
- return $res
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ArrowButton::cget
-# ------------------------------------------------------------------------------
-proc ArrowButton::cget { path option } {
- return [Widget::cget $path $option]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ArrowButton::invoke
-# ------------------------------------------------------------------------------
-proc ArrowButton::invoke { path } {
- if { [string compare [Widget::getoption $path -state] "disabled"] } {
- set oldstate [Widget::getoption $path -state]
- if { ![string compare [Widget::getoption $path -type] "button"] } {
- set oldrelief [Widget::getoption $path -relief]
- configure $path -state active -relief sunken
- } else {
- set oldrelief [Widget::getoption $path -arrowrelief]
- configure $path -state active -arrowrelief sunken
- }
- update idletasks
- if { [set cmd [Widget::getoption $path -armcommand]] != "" } {
- uplevel \#0 $cmd
- }
- after 10
- if { ![string compare [Widget::getoption $path -type] "button"] } {
- configure $path -state $oldstate -relief $oldrelief
- } else {
- configure $path -state $oldstate -arrowrelief $oldrelief
- }
- if { [set cmd [Widget::getoption $path -disarmcommand]] != "" } {
- uplevel \#0 $cmd
- }
- if { [set cmd [Widget::getoption $path -command]] != "" } {
- uplevel \#0 $cmd
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ArrowButton::_redraw
-# ------------------------------------------------------------------------------
-proc ArrowButton::_redraw { path width height } {
- variable _moved
-
- set _moved($path) 0
- set type [Widget::getoption $path -type]
- set dir [Widget::getoption $path -dir]
- set bd [expr {[$path:cmd cget -borderwidth] + [$path:cmd cget -highlightthickness] + 1}]
- set clean [Widget::getoption $path -clean]
- if { ![string compare $type "arrow"] } {
- if { [set id [$path:cmd find withtag rect]] == "" } {
- $path:cmd create rectangle $bd $bd [expr {$width-$bd-1}] [expr {$height-$bd-1}] -tags rect
- } else {
- $path:cmd coords $id $bd $bd [expr {$width-$bd-1}] [expr {$height-$bd-1}]
- }
- $path:cmd lower rect
- set arrbd [Widget::getoption $path -arrowbd]
- set bd [expr {$bd+$arrbd-1}]
- } else {
- $path:cmd delete rect
- }
- # w and h are max width and max height of arrow
- set w [expr {$width - 2*([Widget::getoption $path -ipadx]+$bd)}]
- set h [expr {$height - 2*([Widget::getoption $path -ipady]+$bd)}]
-
- if { $w < 2 } {set w 2}
- if { $h < 2 } {set h 2}
-
- if { $clean > 0 } {
- # arrange for base to be odd
- if { ![string compare $dir "top"] ||
- ![string compare $dir "bottom"] } {
- if { !($w % 2) } {
- incr w -1
- }
- if { $clean == 2 } {
- # arrange for h = (w+1)/2
- set h2 [expr {($w+1)/2}]
- if { $h2 > $h } {
- set w [expr {2*$h-1}]
- } else {
- set h $h2
- }
- }
- } else {
- if { !($h % 2) } {
- incr h -1
- }
- if { $clean == 2 } {
- # arrange for w = (h+1)/2
- set w2 [expr {($h+1)/2}]
- if { $w2 > $w } {
- set h [expr {2*$w-1}]
- } else {
- set w $w2
- }
- }
- }
- }
-
- set x0 [expr {($width-$w)/2}]
- set y0 [expr {($height-$h)/2}]
- set x1 [expr {$x0+$w-1}]
- set y1 [expr {$y0+$h-1}]
-
- switch $dir {
- top {
- set xd [expr {($x0+$x1)/2}]
- if { [set id [$path:cmd find withtag poly]] == "" } {
- $path:cmd create polygon $x0 $y1 $x1 $y1 $xd $y0 -tags poly
- } else {
- $path:cmd coords $id $x0 $y1 $x1 $y1 $xd $y0
- }
- if { ![string compare $type "arrow"] } {
- if { [set id [$path:cmd find withtag bot]] == "" } {
- $path:cmd create line $x0 $y1 $x1 $y1 $xd $y0 -tags bot
- } else {
- $path:cmd coords $id $x0 $y1 $x1 $y1 $xd $y0
- }
- if { [set id [$path:cmd find withtag top]] == "" } {
- $path:cmd create line $x0 $y1 $xd $y0 -tags top
- } else {
- $path:cmd coords $id $x0 $y1 $xd $y0
- }
- $path:cmd itemconfigure top -width $arrbd
- $path:cmd itemconfigure bot -width $arrbd
- } else {
- $path:cmd delete top
- $path:cmd delete bot
- }
- }
- bottom {
- set xd [expr {($x0+$x1)/2}]
- if { [set id [$path:cmd find withtag poly]] == "" } {
- $path:cmd create polygon $x1 $y0 $x0 $y0 $xd $y1 -tags poly
- } else {
- $path:cmd coords $id $x1 $y0 $x0 $y0 $xd $y1
- }
- if { ![string compare $type "arrow"] } {
- if { [set id [$path:cmd find withtag top]] == "" } {
- $path:cmd create line $x1 $y0 $x0 $y0 $xd $y1 -tags top
- } else {
- $path:cmd coords $id $x1 $y0 $x0 $y0 $xd $y1
- }
- if { [set id [$path:cmd find withtag bot]] == "" } {
- $path:cmd create line $x1 $y0 $xd $y1 -tags bot
- } else {
- $path:cmd coords $id $x1 $y0 $xd $y1
- }
- $path:cmd itemconfigure top -width $arrbd
- $path:cmd itemconfigure bot -width $arrbd
- } else {
- $path:cmd delete top
- $path:cmd delete bot
- }
- }
- left {
- set yd [expr {($y0+$y1)/2}]
- if { [set id [$path:cmd find withtag poly]] == "" } {
- $path:cmd create polygon $x1 $y0 $x1 $y1 $x0 $yd -tags poly
- } else {
- $path:cmd coords $id $x1 $y0 $x1 $y1 $x0 $yd
- }
- if { ![string compare $type "arrow"] } {
- if { [set id [$path:cmd find withtag bot]] == "" } {
- $path:cmd create line $x1 $y0 $x1 $y1 $x0 $yd -tags bot
- } else {
- $path:cmd coords $id $x1 $y0 $x1 $y1 $x0 $yd
- }
- if { [set id [$path:cmd find withtag top]] == "" } {
- $path:cmd create line $x1 $y0 $x0 $yd -tags top
- } else {
- $path:cmd coords $id $x1 $y0 $x0 $yd
- }
- $path:cmd itemconfigure top -width $arrbd
- $path:cmd itemconfigure bot -width $arrbd
- } else {
- $path:cmd delete top
- $path:cmd delete bot
- }
- }
- right {
- set yd [expr {($y0+$y1)/2}]
- if { [set id [$path:cmd find withtag poly]] == "" } {
- $path:cmd create polygon $x0 $y1 $x0 $y0 $x1 $yd -tags poly
- } else {
- $path:cmd coords $id $x0 $y1 $x0 $y0 $x1 $yd
- }
- if { ![string compare $type "arrow"] } {
- if { [set id [$path:cmd find withtag top]] == "" } {
- $path:cmd create line $x0 $y1 $x0 $y0 $x1 $yd -tags top
- } else {
- $path:cmd coords $id $x0 $y1 $x0 $y0 $x1 $yd
- }
- if { [set id [$path:cmd find withtag bot]] == "" } {
- $path:cmd create line $x0 $y1 $x1 $yd -tags bot
- } else {
- $path:cmd coords $id $x0 $y1 $x1 $yd
- }
- $path:cmd itemconfigure top -width $arrbd
- $path:cmd itemconfigure bot -width $arrbd
- } else {
- $path:cmd delete top
- $path:cmd delete bot
- }
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ArrowButton::_redraw_state
-# ------------------------------------------------------------------------------
-proc ArrowButton::_redraw_state { path } {
- set state [Widget::getoption $path -state]
- if { ![string compare [Widget::getoption $path -type] "button"] } {
- switch $state {
- normal {set bg -background; set fg -foreground}
- active {set bg -activebackground; set fg -activeforeground}
- disabled {set bg -background; set fg -disabledforeground}
- }
- set fg [Widget::getoption $path $fg]
- $path:cmd configure -background [Widget::getoption $path $bg]
- $path:cmd itemconfigure poly -fill $fg -outline $fg
- } else {
- switch $state {
- normal {set stipple ""; set bg [Widget::getoption $path -background] }
- active {set stipple ""; set bg [Widget::getoption $path -activebackground] }
- disabled {set stipple gray50; set bg black }
- }
- set thrc [Widget::getoption $path -troughcolor]
- $path:cmd configure -background [Widget::getoption $path -background]
- $path:cmd itemconfigure rect -fill $thrc -outline $thrc
- $path:cmd itemconfigure poly -fill $bg -outline $bg -stipple $stipple
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ArrowButton::_redraw_relief
-# ------------------------------------------------------------------------------
-proc ArrowButton::_redraw_relief { path } {
- variable _moved
-
- if { ![string compare [Widget::getoption $path -type] "button"] } {
- if { ![string compare [Widget::getoption $path -relief] "sunken"] } {
- if { !$_moved($path) } {
- $path:cmd move poly 1 1
- set _moved($path) 1
- }
- } else {
- if { $_moved($path) } {
- $path:cmd move poly -1 -1
- set _moved($path) 0
- }
- }
- } else {
- set col3d [BWidget::get3dcolor $path [Widget::getoption $path -background]]
- switch [Widget::getoption $path -arrowrelief] {
- raised {set top [lindex $col3d 1]; set bot [lindex $col3d 0]}
- sunken {set top [lindex $col3d 0]; set bot [lindex $col3d 1]}
- }
- $path:cmd itemconfigure top -fill $top
- $path:cmd itemconfigure bot -fill $bot
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ArrowButton::_redraw_whole
-# ------------------------------------------------------------------------------
-proc ArrowButton::_redraw_whole { path width height } {
- _redraw $path $width $height
- _redraw_relief $path
- _redraw_state $path
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ArrowButton::_destroy
-# ------------------------------------------------------------------------------
-proc ArrowButton::_destroy { path } {
- variable _moved
-
- Widget::destroy $path
- unset _moved($path)
- rename $path {}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ArrowButton::_enter
-# ------------------------------------------------------------------------------
-proc ArrowButton::_enter { path } {
- variable _grab
-
- set _grab(current) $path
- if { [string compare [Widget::getoption $path -state] "disabled"] } {
- set _grab(oldstate) [Widget::getoption $path -state]
- configure $path -state active
- if { $_grab(pressed) == $path } {
- if { ![string compare [Widget::getoption $path -type] "button"] } {
- set _grab(oldrelief) [Widget::getoption $path -relief]
- configure $path -relief sunken
- } else {
- set _grab(oldrelief) [Widget::getoption $path -arrowrelief]
- configure $path -arrowrelief sunken
- }
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ArrowButton::_leave
-# ------------------------------------------------------------------------------
-proc ArrowButton::_leave { path } {
- variable _grab
-
- set _grab(current) ""
- if { [string compare [Widget::getoption $path -state] "disabled"] } {
- configure $path -state $_grab(oldstate)
- if { $_grab(pressed) == $path } {
- if { ![string compare [Widget::getoption $path -type] "button"] } {
- configure $path -relief $_grab(oldrelief)
- } else {
- configure $path -arrowrelief $_grab(oldrelief)
- }
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ArrowButton::_press
-# ------------------------------------------------------------------------------
-proc ArrowButton::_press { path } {
- variable _grab
-
- if { [string compare [Widget::getoption $path -state] "disabled"] } {
- set _grab(pressed) $path
- if { ![string compare [Widget::getoption $path -type] "button"] } {
- set _grab(oldrelief) [Widget::getoption $path -relief]
- configure $path -relief sunken
- } else {
- set _grab(oldrelief) [Widget::getoption $path -arrowrelief]
- configure $path -arrowrelief sunken
- }
- if { [set cmd [Widget::getoption $path -armcommand]] != "" } {
- uplevel \#0 $cmd
- if { [set delay [Widget::getoption $path -repeatdelay]] > 0 ||
- [set delay [Widget::getoption $path -repeatinterval]] > 0 } {
- after $delay "ArrowButton::_repeat $path"
- }
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ArrowButton::_release
-# ------------------------------------------------------------------------------
-proc ArrowButton::_release { path } {
- variable _grab
-
- if { $_grab(pressed) == $path } {
- set _grab(pressed) ""
- if { ![string compare [Widget::getoption $path -type] "button"] } {
- configure $path -relief $_grab(oldrelief)
- } else {
- configure $path -arrowrelief $_grab(oldrelief)
- }
- if { [set cmd [Widget::getoption $path -disarmcommand]] != "" } {
- uplevel \#0 $cmd
- }
- if { $_grab(current) == $path &&
- [string compare [Widget::getoption $path -state] "disabled"] &&
- [set cmd [Widget::getoption $path -command]] != "" } {
- uplevel \#0 $cmd
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ArrowButton::_repeat
-# ------------------------------------------------------------------------------
-proc ArrowButton::_repeat { path } {
- variable _grab
-
- if { $_grab(current) == $path && $_grab(pressed) == $path &&
- [string compare [Widget::getoption $path -state] "disabled"] &&
- [set cmd [Widget::getoption $path -armcommand]] != "" } {
- uplevel \#0 $cmd
- }
- if { $_grab(pressed) == $path &&
- ([set delay [Widget::getoption $path -repeatinterval]] > 0 ||
- [set delay [Widget::getoption $path -repeatdelay]] > 0) } {
- after $delay "ArrowButton::_repeat $path"
- }
-}
-
Copied: grass/trunk/lib/external/bwidget/arrow.tcl (from rev 35192, grass/trunk/lib/external/bwidget/arrow.tcl)
===================================================================
--- grass/trunk/lib/external/bwidget/arrow.tcl (rev 0)
+++ grass/trunk/lib/external/bwidget/arrow.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,548 @@
+# ------------------------------------------------------------------------------
+# arrow.tcl
+# This file is part of Unifix BWidget Toolkit
+# ------------------------------------------------------------------------------
+# Index of commands:
+# Public commands
+# - ArrowButton::create
+# - ArrowButton::configure
+# - ArrowButton::cget
+# - ArrowButton::invoke
+# Private commands (redraw commands)
+# - ArrowButton::_redraw
+# - ArrowButton::_redraw_state
+# - ArrowButton::_redraw_relief
+# - ArrowButton::_redraw_whole
+# Private commands (event bindings)
+# - ArrowButton::_destroy
+# - ArrowButton::_enter
+# - ArrowButton::_leave
+# - ArrowButton::_press
+# - ArrowButton::_release
+# - ArrowButton::_repeat
+# ------------------------------------------------------------------------------
+
+namespace eval ArrowButton {
+
+ Widget::tkinclude ArrowButton button :cmd \
+ include {
+ -borderwidth -bd -background -bg -relief
+ -highlightbackground -highlightcolor -highlightthickness -takefocus}
+
+ Widget::declare ArrowButton {
+ {-type Enum button 0 {arrow button}}
+ {-dir Enum top 0 {top bottom left right}}
+ {-width Int 15 0 {=0}}
+ {-height Int 15 0 {=0}}
+ {-ipadx Int 0 0 {=0}}
+ {-ipady Int 0 0 {=0}}
+ {-clean Int 2 0 {=0 =2}}
+ {-activeforeground TkResource "" 0 button}
+ {-activebackground TkResource "" 0 button}
+ {-disabledforeground TkResource "" 0 button}
+ {-foreground TkResource "" 0 button}
+ {-state TkResource "" 0 button}
+
+ {-troughcolor TkResource "" 0 scrollbar}
+ {-arrowbd Int 1 0 {=1 =2}}
+ {-arrowrelief Enum raised 0 {raised sunken}}
+
+ {-command String "" 0}
+ {-armcommand String "" 0}
+ {-disarmcommand String "" 0}
+ {-repeatdelay Int 0 0 {=0}}
+ {-repeatinterval Int 0 0 {=0}}
+
+ {-bd Synonym -borderwidth}
+ {-fg Synonym -foreground}
+ }
+ DynamicHelp::include ArrowButton balloon
+
+ proc ::ArrowButton { path args } { return [eval ArrowButton::create $path $args] }
+
+ proc use {} {}
+
+ bind BwArrowButton <Enter> {ArrowButton::_enter %W}
+ bind BwArrowButton <Leave> {ArrowButton::_leave %W}
+ bind BwArrowButton <ButtonPress-1> {ArrowButton::_press %W}
+ bind BwArrowButton <ButtonRelease-1> {ArrowButton::_release %W}
+ bind BwArrowButton <Key-space> {ArrowButton::invoke %W; break}
+ bind BwArrowButton <Return> {ArrowButton::invoke %W; break}
+ bind BwArrowButton <Configure> {ArrowButton::_redraw_whole %W %w %h}
+ bind BwArrowButton <Destroy> {ArrowButton::_destroy %W}
+
+ variable _grab
+ variable _moved
+
+ array set _grab {current "" pressed "" oldstate "" oldrelief ""}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ArrowButton::create
+# ------------------------------------------------------------------------------
+proc ArrowButton::create { path args } {
+ variable _moved
+
+ Widget::init ArrowButton $path $args
+
+ set w [Widget::getoption $path -width]
+ set h [Widget::getoption $path -height]
+ set bd [Widget::getoption $path -borderwidth]
+ set ht [Widget::getoption $path -highlightthickness]
+ set pad [expr {2*($bd+$ht)}]
+
+ eval canvas $path [Widget::subcget $path :cmd] \
+ -width [expr {$w-$pad}] -height [expr {$h-$pad}]
+ bindtags $path [list $path BwArrowButton [winfo toplevel $path] all]
+
+ DynamicHelp::sethelp $path $path 1
+
+ set _moved($path) 0
+
+ rename $path ::$path:cmd
+ proc ::$path { cmd args } "return \[eval ArrowButton::\$cmd $path \$args\]"
+
+ return $path
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ArrowButton::configure
+# ------------------------------------------------------------------------------
+proc ArrowButton::configure { path args } {
+ set res [Widget::configure $path $args]
+
+ set ch1 [expr {[Widget::hasChanged $path -width w] |
+ [Widget::hasChanged $path -height h] |
+ [Widget::hasChanged $path -borderwidth bd] |
+ [Widget::hasChanged $path -highlightthickness ht]}]
+ set ch2 [expr {[Widget::hasChanged $path -type val] |
+ [Widget::hasChanged $path -ipadx val] |
+ [Widget::hasChanged $path -ipady val] |
+ [Widget::hasChanged $path -arrowbd val] |
+ [Widget::hasChanged $path -clean val] |
+ [Widget::hasChanged $path -dir val]}]
+
+ if { $ch1 } {
+ set pad [expr {2*($bd+$ht)}]
+ $path:cmd configure \
+ -width [expr {$w-$pad}] -height [expr {$h-$pad}] \
+ -borderwidth $bd -highlightthickness $ht
+ } elseif { $ch2 } {
+ _redraw_whole $path [winfo width $path] [winfo height $path]
+ } else {
+ _redraw_relief $path
+ _redraw_state $path
+ }
+ DynamicHelp::sethelp $path $path
+
+ return $res
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ArrowButton::cget
+# ------------------------------------------------------------------------------
+proc ArrowButton::cget { path option } {
+ return [Widget::cget $path $option]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ArrowButton::invoke
+# ------------------------------------------------------------------------------
+proc ArrowButton::invoke { path } {
+ if { [string compare [Widget::getoption $path -state] "disabled"] } {
+ set oldstate [Widget::getoption $path -state]
+ if { ![string compare [Widget::getoption $path -type] "button"] } {
+ set oldrelief [Widget::getoption $path -relief]
+ configure $path -state active -relief sunken
+ } else {
+ set oldrelief [Widget::getoption $path -arrowrelief]
+ configure $path -state active -arrowrelief sunken
+ }
+ update idletasks
+ if { [set cmd [Widget::getoption $path -armcommand]] != "" } {
+ uplevel \#0 $cmd
+ }
+ after 10
+ if { ![string compare [Widget::getoption $path -type] "button"] } {
+ configure $path -state $oldstate -relief $oldrelief
+ } else {
+ configure $path -state $oldstate -arrowrelief $oldrelief
+ }
+ if { [set cmd [Widget::getoption $path -disarmcommand]] != "" } {
+ uplevel \#0 $cmd
+ }
+ if { [set cmd [Widget::getoption $path -command]] != "" } {
+ uplevel \#0 $cmd
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ArrowButton::_redraw
+# ------------------------------------------------------------------------------
+proc ArrowButton::_redraw { path width height } {
+ variable _moved
+
+ set _moved($path) 0
+ set type [Widget::getoption $path -type]
+ set dir [Widget::getoption $path -dir]
+ set bd [expr {[$path:cmd cget -borderwidth] + [$path:cmd cget -highlightthickness] + 1}]
+ set clean [Widget::getoption $path -clean]
+ if { ![string compare $type "arrow"] } {
+ if { [set id [$path:cmd find withtag rect]] == "" } {
+ $path:cmd create rectangle $bd $bd [expr {$width-$bd-1}] [expr {$height-$bd-1}] -tags rect
+ } else {
+ $path:cmd coords $id $bd $bd [expr {$width-$bd-1}] [expr {$height-$bd-1}]
+ }
+ $path:cmd lower rect
+ set arrbd [Widget::getoption $path -arrowbd]
+ set bd [expr {$bd+$arrbd-1}]
+ } else {
+ $path:cmd delete rect
+ }
+ # w and h are max width and max height of arrow
+ set w [expr {$width - 2*([Widget::getoption $path -ipadx]+$bd)}]
+ set h [expr {$height - 2*([Widget::getoption $path -ipady]+$bd)}]
+
+ if { $w < 2 } {set w 2}
+ if { $h < 2 } {set h 2}
+
+ if { $clean > 0 } {
+ # arrange for base to be odd
+ if { ![string compare $dir "top"] ||
+ ![string compare $dir "bottom"] } {
+ if { !($w % 2) } {
+ incr w -1
+ }
+ if { $clean == 2 } {
+ # arrange for h = (w+1)/2
+ set h2 [expr {($w+1)/2}]
+ if { $h2 > $h } {
+ set w [expr {2*$h-1}]
+ } else {
+ set h $h2
+ }
+ }
+ } else {
+ if { !($h % 2) } {
+ incr h -1
+ }
+ if { $clean == 2 } {
+ # arrange for w = (h+1)/2
+ set w2 [expr {($h+1)/2}]
+ if { $w2 > $w } {
+ set h [expr {2*$w-1}]
+ } else {
+ set w $w2
+ }
+ }
+ }
+ }
+
+ set x0 [expr {($width-$w)/2}]
+ set y0 [expr {($height-$h)/2}]
+ set x1 [expr {$x0+$w-1}]
+ set y1 [expr {$y0+$h-1}]
+
+ switch $dir {
+ top {
+ set xd [expr {($x0+$x1)/2}]
+ if { [set id [$path:cmd find withtag poly]] == "" } {
+ $path:cmd create polygon $x0 $y1 $x1 $y1 $xd $y0 -tags poly
+ } else {
+ $path:cmd coords $id $x0 $y1 $x1 $y1 $xd $y0
+ }
+ if { ![string compare $type "arrow"] } {
+ if { [set id [$path:cmd find withtag bot]] == "" } {
+ $path:cmd create line $x0 $y1 $x1 $y1 $xd $y0 -tags bot
+ } else {
+ $path:cmd coords $id $x0 $y1 $x1 $y1 $xd $y0
+ }
+ if { [set id [$path:cmd find withtag top]] == "" } {
+ $path:cmd create line $x0 $y1 $xd $y0 -tags top
+ } else {
+ $path:cmd coords $id $x0 $y1 $xd $y0
+ }
+ $path:cmd itemconfigure top -width $arrbd
+ $path:cmd itemconfigure bot -width $arrbd
+ } else {
+ $path:cmd delete top
+ $path:cmd delete bot
+ }
+ }
+ bottom {
+ set xd [expr {($x0+$x1)/2}]
+ if { [set id [$path:cmd find withtag poly]] == "" } {
+ $path:cmd create polygon $x1 $y0 $x0 $y0 $xd $y1 -tags poly
+ } else {
+ $path:cmd coords $id $x1 $y0 $x0 $y0 $xd $y1
+ }
+ if { ![string compare $type "arrow"] } {
+ if { [set id [$path:cmd find withtag top]] == "" } {
+ $path:cmd create line $x1 $y0 $x0 $y0 $xd $y1 -tags top
+ } else {
+ $path:cmd coords $id $x1 $y0 $x0 $y0 $xd $y1
+ }
+ if { [set id [$path:cmd find withtag bot]] == "" } {
+ $path:cmd create line $x1 $y0 $xd $y1 -tags bot
+ } else {
+ $path:cmd coords $id $x1 $y0 $xd $y1
+ }
+ $path:cmd itemconfigure top -width $arrbd
+ $path:cmd itemconfigure bot -width $arrbd
+ } else {
+ $path:cmd delete top
+ $path:cmd delete bot
+ }
+ }
+ left {
+ set yd [expr {($y0+$y1)/2}]
+ if { [set id [$path:cmd find withtag poly]] == "" } {
+ $path:cmd create polygon $x1 $y0 $x1 $y1 $x0 $yd -tags poly
+ } else {
+ $path:cmd coords $id $x1 $y0 $x1 $y1 $x0 $yd
+ }
+ if { ![string compare $type "arrow"] } {
+ if { [set id [$path:cmd find withtag bot]] == "" } {
+ $path:cmd create line $x1 $y0 $x1 $y1 $x0 $yd -tags bot
+ } else {
+ $path:cmd coords $id $x1 $y0 $x1 $y1 $x0 $yd
+ }
+ if { [set id [$path:cmd find withtag top]] == "" } {
+ $path:cmd create line $x1 $y0 $x0 $yd -tags top
+ } else {
+ $path:cmd coords $id $x1 $y0 $x0 $yd
+ }
+ $path:cmd itemconfigure top -width $arrbd
+ $path:cmd itemconfigure bot -width $arrbd
+ } else {
+ $path:cmd delete top
+ $path:cmd delete bot
+ }
+ }
+ right {
+ set yd [expr {($y0+$y1)/2}]
+ if { [set id [$path:cmd find withtag poly]] == "" } {
+ $path:cmd create polygon $x0 $y1 $x0 $y0 $x1 $yd -tags poly
+ } else {
+ $path:cmd coords $id $x0 $y1 $x0 $y0 $x1 $yd
+ }
+ if { ![string compare $type "arrow"] } {
+ if { [set id [$path:cmd find withtag top]] == "" } {
+ $path:cmd create line $x0 $y1 $x0 $y0 $x1 $yd -tags top
+ } else {
+ $path:cmd coords $id $x0 $y1 $x0 $y0 $x1 $yd
+ }
+ if { [set id [$path:cmd find withtag bot]] == "" } {
+ $path:cmd create line $x0 $y1 $x1 $yd -tags bot
+ } else {
+ $path:cmd coords $id $x0 $y1 $x1 $yd
+ }
+ $path:cmd itemconfigure top -width $arrbd
+ $path:cmd itemconfigure bot -width $arrbd
+ } else {
+ $path:cmd delete top
+ $path:cmd delete bot
+ }
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ArrowButton::_redraw_state
+# ------------------------------------------------------------------------------
+proc ArrowButton::_redraw_state { path } {
+ set state [Widget::getoption $path -state]
+ if { ![string compare [Widget::getoption $path -type] "button"] } {
+ switch $state {
+ normal {set bg -background; set fg -foreground}
+ active {set bg -activebackground; set fg -activeforeground}
+ disabled {set bg -background; set fg -disabledforeground}
+ }
+ set fg [Widget::getoption $path $fg]
+ $path:cmd configure -background [Widget::getoption $path $bg]
+ $path:cmd itemconfigure poly -fill $fg -outline $fg
+ } else {
+ switch $state {
+ normal {set stipple ""; set bg [Widget::getoption $path -background] }
+ active {set stipple ""; set bg [Widget::getoption $path -activebackground] }
+ disabled {set stipple gray50; set bg black }
+ }
+ set thrc [Widget::getoption $path -troughcolor]
+ $path:cmd configure -background [Widget::getoption $path -background]
+ $path:cmd itemconfigure rect -fill $thrc -outline $thrc
+ $path:cmd itemconfigure poly -fill $bg -outline $bg -stipple $stipple
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ArrowButton::_redraw_relief
+# ------------------------------------------------------------------------------
+proc ArrowButton::_redraw_relief { path } {
+ variable _moved
+
+ if { ![string compare [Widget::getoption $path -type] "button"] } {
+ if { ![string compare [Widget::getoption $path -relief] "sunken"] } {
+ if { !$_moved($path) } {
+ $path:cmd move poly 1 1
+ set _moved($path) 1
+ }
+ } else {
+ if { $_moved($path) } {
+ $path:cmd move poly -1 -1
+ set _moved($path) 0
+ }
+ }
+ } else {
+ set col3d [BWidget::get3dcolor $path [Widget::getoption $path -background]]
+ switch [Widget::getoption $path -arrowrelief] {
+ raised {set top [lindex $col3d 1]; set bot [lindex $col3d 0]}
+ sunken {set top [lindex $col3d 0]; set bot [lindex $col3d 1]}
+ }
+ $path:cmd itemconfigure top -fill $top
+ $path:cmd itemconfigure bot -fill $bot
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ArrowButton::_redraw_whole
+# ------------------------------------------------------------------------------
+proc ArrowButton::_redraw_whole { path width height } {
+ _redraw $path $width $height
+ _redraw_relief $path
+ _redraw_state $path
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ArrowButton::_destroy
+# ------------------------------------------------------------------------------
+proc ArrowButton::_destroy { path } {
+ variable _moved
+
+ Widget::destroy $path
+ unset _moved($path)
+ rename $path {}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ArrowButton::_enter
+# ------------------------------------------------------------------------------
+proc ArrowButton::_enter { path } {
+ variable _grab
+
+ set _grab(current) $path
+ if { [string compare [Widget::getoption $path -state] "disabled"] } {
+ set _grab(oldstate) [Widget::getoption $path -state]
+ configure $path -state active
+ if { $_grab(pressed) == $path } {
+ if { ![string compare [Widget::getoption $path -type] "button"] } {
+ set _grab(oldrelief) [Widget::getoption $path -relief]
+ configure $path -relief sunken
+ } else {
+ set _grab(oldrelief) [Widget::getoption $path -arrowrelief]
+ configure $path -arrowrelief sunken
+ }
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ArrowButton::_leave
+# ------------------------------------------------------------------------------
+proc ArrowButton::_leave { path } {
+ variable _grab
+
+ set _grab(current) ""
+ if { [string compare [Widget::getoption $path -state] "disabled"] } {
+ configure $path -state $_grab(oldstate)
+ if { $_grab(pressed) == $path } {
+ if { ![string compare [Widget::getoption $path -type] "button"] } {
+ configure $path -relief $_grab(oldrelief)
+ } else {
+ configure $path -arrowrelief $_grab(oldrelief)
+ }
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ArrowButton::_press
+# ------------------------------------------------------------------------------
+proc ArrowButton::_press { path } {
+ variable _grab
+
+ if { [string compare [Widget::getoption $path -state] "disabled"] } {
+ set _grab(pressed) $path
+ if { ![string compare [Widget::getoption $path -type] "button"] } {
+ set _grab(oldrelief) [Widget::getoption $path -relief]
+ configure $path -relief sunken
+ } else {
+ set _grab(oldrelief) [Widget::getoption $path -arrowrelief]
+ configure $path -arrowrelief sunken
+ }
+ if { [set cmd [Widget::getoption $path -armcommand]] != "" } {
+ uplevel \#0 $cmd
+ if { [set delay [Widget::getoption $path -repeatdelay]] > 0 ||
+ [set delay [Widget::getoption $path -repeatinterval]] > 0 } {
+ after $delay "ArrowButton::_repeat $path"
+ }
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ArrowButton::_release
+# ------------------------------------------------------------------------------
+proc ArrowButton::_release { path } {
+ variable _grab
+
+ if { $_grab(pressed) == $path } {
+ set _grab(pressed) ""
+ if { ![string compare [Widget::getoption $path -type] "button"] } {
+ configure $path -relief $_grab(oldrelief)
+ } else {
+ configure $path -arrowrelief $_grab(oldrelief)
+ }
+ if { [set cmd [Widget::getoption $path -disarmcommand]] != "" } {
+ uplevel \#0 $cmd
+ }
+ if { $_grab(current) == $path &&
+ [string compare [Widget::getoption $path -state] "disabled"] &&
+ [set cmd [Widget::getoption $path -command]] != "" } {
+ uplevel \#0 $cmd
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ArrowButton::_repeat
+# ------------------------------------------------------------------------------
+proc ArrowButton::_repeat { path } {
+ variable _grab
+
+ if { $_grab(current) == $path && $_grab(pressed) == $path &&
+ [string compare [Widget::getoption $path -state] "disabled"] &&
+ [set cmd [Widget::getoption $path -armcommand]] != "" } {
+ uplevel \#0 $cmd
+ }
+ if { $_grab(pressed) == $path &&
+ ([set delay [Widget::getoption $path -repeatinterval]] > 0 ||
+ [set delay [Widget::getoption $path -repeatdelay]] > 0) } {
+ after $delay "ArrowButton::_repeat $path"
+ }
+}
+
Deleted: grass/trunk/lib/external/bwidget/bitmap.tcl
===================================================================
--- grass/trunk/lib/external/bwidget/bitmap.tcl 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/bitmap.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,92 +0,0 @@
-# ------------------------------------------------------------------------------
-# bitmap.tcl
-# This file is part of Unifix BWidget Toolkit
-# $Id$
-# ------------------------------------------------------------------------------
-# Index of commands:
-# - Bitmap::get
-# - Bitmap::_init
-# ------------------------------------------------------------------------------
-namespace eval Bitmap {
- variable path
- variable _bmp
- variable _types {
- photo .gif
- photo .ppm
- bitmap .xbm
- photo .xpm
- }
-
- proc use {} {}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Bitmap::get
-# ------------------------------------------------------------------------------
-proc Bitmap::get { name } {
- variable path
- variable _bmp
- variable _types
-
- if {[info exists _bmp($name)]} {
- return $_bmp($name)
- }
-
- # --- Nom de fichier avec extension ------------------------------------------------------
- set ext [file extension $name]
- if { $ext != "" } {
- if { ![info exists _bmp($ext)] } {
- error "$ext not supported"
- }
-
- if { [file exists $name] } {
- if {![string compare $ext ".xpm"]} {
- set _bmp($name) [xpm-to-image $name]
- return $_bmp($name)
- }
- if {![catch {set _bmp($name) [image create $_bmp($ext) -file $name]}]} {
- return $_bmp($name)
- }
- }
- }
-
- foreach dir $path {
- foreach {type ext} $_types {
- if { [file exists [file join $dir $name$ext]] } {
- if {![string compare $ext ".xpm"]} {
- set _bmp($name) [xpm-to-image [file join $dir $name$ext]]
- return $_bmp($name)
- } else {
- if {![catch {set _bmp($name) [image create $type -file [file join $dir $name$ext]]}]} {
- return $_bmp($name)
- }
- }
- }
- }
- }
-
- return -code error "$name not found"
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Bitmap::_init
-# ------------------------------------------------------------------------------
-proc Bitmap::_init { } {
- global env
- variable path
- variable _bmp
- variable _types
-
- set path [list "." [file join $env(BWIDGET_LIBRARY) images]]
- set supp [image types]
- foreach {type ext} $_types {
- if { [lsearch $supp $type] != -1} {
- set _bmp($ext) $type
- }
- }
-}
-
-
-Bitmap::_init
Copied: grass/trunk/lib/external/bwidget/bitmap.tcl (from rev 35192, grass/trunk/lib/external/bwidget/bitmap.tcl)
===================================================================
--- grass/trunk/lib/external/bwidget/bitmap.tcl (rev 0)
+++ grass/trunk/lib/external/bwidget/bitmap.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,92 @@
+# ------------------------------------------------------------------------------
+# bitmap.tcl
+# This file is part of Unifix BWidget Toolkit
+# $Id$
+# ------------------------------------------------------------------------------
+# Index of commands:
+# - Bitmap::get
+# - Bitmap::_init
+# ------------------------------------------------------------------------------
+namespace eval Bitmap {
+ variable path
+ variable _bmp
+ variable _types {
+ photo .gif
+ photo .ppm
+ bitmap .xbm
+ photo .xpm
+ }
+
+ proc use {} {}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Bitmap::get
+# ------------------------------------------------------------------------------
+proc Bitmap::get { name } {
+ variable path
+ variable _bmp
+ variable _types
+
+ if {[info exists _bmp($name)]} {
+ return $_bmp($name)
+ }
+
+ # --- Nom de fichier avec extension ------------------------------------------------------
+ set ext [file extension $name]
+ if { $ext != "" } {
+ if { ![info exists _bmp($ext)] } {
+ error "$ext not supported"
+ }
+
+ if { [file exists $name] } {
+ if {![string compare $ext ".xpm"]} {
+ set _bmp($name) [xpm-to-image $name]
+ return $_bmp($name)
+ }
+ if {![catch {set _bmp($name) [image create $_bmp($ext) -file $name]}]} {
+ return $_bmp($name)
+ }
+ }
+ }
+
+ foreach dir $path {
+ foreach {type ext} $_types {
+ if { [file exists [file join $dir $name$ext]] } {
+ if {![string compare $ext ".xpm"]} {
+ set _bmp($name) [xpm-to-image [file join $dir $name$ext]]
+ return $_bmp($name)
+ } else {
+ if {![catch {set _bmp($name) [image create $type -file [file join $dir $name$ext]]}]} {
+ return $_bmp($name)
+ }
+ }
+ }
+ }
+ }
+
+ return -code error "$name not found"
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Bitmap::_init
+# ------------------------------------------------------------------------------
+proc Bitmap::_init { } {
+ global env
+ variable path
+ variable _bmp
+ variable _types
+
+ set path [list "." [file join $env(BWIDGET_LIBRARY) images]]
+ set supp [image types]
+ foreach {type ext} $_types {
+ if { [lsearch $supp $type] != -1} {
+ set _bmp($ext) $type
+ }
+ }
+}
+
+
+Bitmap::_init
Deleted: grass/trunk/lib/external/bwidget/button.tcl
===================================================================
--- grass/trunk/lib/external/bwidget/button.tcl 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/button.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,302 +0,0 @@
-# ------------------------------------------------------------------------------
-# button.tcl
-# This file is part of Unifix BWidget Toolkit
-# ------------------------------------------------------------------------------
-# Index of commands:
-# Public commands
-# - Button::create
-# - Button::configure
-# - Button::cget
-# - Button::invoke
-# Private commands (event bindings)
-# - Button::_destroy
-# - Button::_enter
-# - Button::_leave
-# - Button::_press
-# - Button::_release
-# - Button::_repeat
-# ------------------------------------------------------------------------------
-
-namespace eval Button {
- Widget::tkinclude Button button :cmd \
- remove {-command -relief -text -textvariable -underline}
-
- Widget::declare Button {
- {-name String "" 0}
- {-text String "" 0}
- {-textvariable String "" 0}
- {-underline Int -1 0 {=-1}}
- {-armcommand String "" 0}
- {-disarmcommand String "" 0}
- {-command String "" 0}
- {-repeatdelay Int 0 0 {=0 ""}}
- {-repeatinterval Int 0 0 {=0 ""}}
- {-relief Enum raised 0 {raised sunken flat ridge solid groove link}}
- }
-
- DynamicHelp::include Button balloon
-
- Widget::syncoptions Button "" :cmd {-text {} -underline {}}
-
- variable _current ""
- variable _pressed ""
-
- bind BwButton <Enter> {Button::_enter %W}
- bind BwButton <Leave> {Button::_leave %W}
- bind BwButton <ButtonPress-1> {Button::_press %W}
- bind BwButton <ButtonRelease-1> {Button::_release %W}
- bind BwButton <Key-space> {Button::invoke %W; break}
- bind BwButton <Return> {Button::invoke %W; break}
- bind BwButton <Destroy> {Widget::destroy %W; rename %W {}}
-
- proc ::Button { path args } { return [eval Button::create $path $args] }
- proc use {} {}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Button::create
-# ------------------------------------------------------------------------------
-proc Button::create { path args } {
- Widget::init Button $path $args
-
- set relief [Widget::getoption $path -relief]
- if { ![string compare $relief "link"] } {
- set relief "flat"
- }
-
- set var [Widget::getoption $path -textvariable]
- if { ![string length $var] } {
- set desc [BWidget::getname [Widget::getoption $path -name]]
- if { [llength $desc] } {
- set text [lindex $desc 0]
- set under [lindex $desc 1]
- Widget::setoption $path -text $text
- Widget::setoption $path -underline $under
- } else {
- set text [Widget::getoption $path -text]
- set under [Widget::getoption $path -underline]
- }
- } else {
- set under -1
- set text ""
- Widget::setoption $path -underline $under
- }
-
- eval button $path [Widget::subcget $path :cmd] \
- [list -relief $relief -text $text -underline $under -textvariable $var]
- bindtags $path [list $path BwButton [winfo toplevel $path] all]
-
- set accel [string tolower [string index $text $under]]
- if { $accel != "" } {
- bind [winfo toplevel $path] <Alt-$accel> "Button::invoke $path"
- }
-
- DynamicHelp::sethelp $path $path 1
-
- rename $path ::$path:cmd
- proc ::$path { cmd args } "return \[eval Button::\$cmd $path \$args\]"
-
- return $path
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Button::configure
-# ------------------------------------------------------------------------------
-proc Button::configure { path args } {
- set oldunder [$path:cmd cget -underline]
- if { $oldunder != -1 } {
- set oldaccel [string tolower [string index [$path:cmd cget -text] $oldunder]]
- } else {
- set oldaccel ""
- }
- set res [Widget::configure $path $args]
-
- set rc [Widget::hasChanged $path -relief relief]
- set sc [Widget::hasChanged $path -state state]
-
- if { $rc || $sc } {
- if { ![string compare $relief "link"] } {
- if { ![string compare $state "active"] } {
- set relief "raised"
- } else {
- set relief "flat"
- }
- }
- $path:cmd configure -relief $relief -state $state
- }
-
- set cv [Widget::hasChanged $path -textvariable var]
- set cn [Widget::hasChanged $path -name name]
- set ct [Widget::hasChanged $path -text text]
- set cu [Widget::hasChanged $path -underline under]
-
- if { $cv || $cn || $ct || $cu } {
- if { ![string length $var] } {
- set desc [BWidget::getname $name]
- if { [llength $desc] } {
- set text [lindex $desc 0]
- set under [lindex $desc 1]
- }
- } else {
- set under -1
- set text ""
- }
- set top [winfo toplevel $path]
- bind $top <Alt-$oldaccel> {}
- set accel [string tolower [string index $text $under]]
- if { $accel != "" } {
- bind $top <Alt-$accel> "Button::invoke $path"
- }
- $path:cmd configure -text $text -underline $under -textvariable $var
- }
- DynamicHelp::sethelp $path $path
-
- return $res
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Button::cget
-# ------------------------------------------------------------------------------
-proc Button::cget { path option } {
- return [Widget::cget $path $option]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Button::invoke
-# ------------------------------------------------------------------------------
-proc Button::invoke { path } {
- if { [string compare [$path:cmd cget -state] "disabled"] } {
- $path:cmd configure -state active -relief sunken
- update idletasks
- if { [set cmd [Widget::getoption $path -armcommand]] != "" } {
- uplevel \#0 $cmd
- }
- after 100
- set relief [Widget::getoption $path -relief]
- if { ![string compare $relief "link"] } {
- set relief flat
- }
- $path:cmd configure \
- -state [Widget::getoption $path -state] \
- -relief $relief
- if { [set cmd [Widget::getoption $path -disarmcommand]] != "" } {
- uplevel \#0 $cmd
- }
- if { [set cmd [Widget::getoption $path -command]] != "" } {
- uplevel \#0 $cmd
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Button::_enter
-# ------------------------------------------------------------------------------
-proc Button::_enter { path } {
- variable _current
- variable _pressed
-
- set _current $path
- if { [string compare [$path:cmd cget -state] "disabled"] } {
- $path:cmd configure -state active
- if { $_pressed == $path } {
- $path:cmd configure -relief sunken
- } elseif { ![string compare [Widget::getoption $path -relief] "link"] } {
- $path:cmd configure -relief raised
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Button::_leave
-# ------------------------------------------------------------------------------
-proc Button::_leave { path } {
- variable _current
- variable _pressed
-
- set _current ""
- if { [string compare [$path:cmd cget -state] "disabled"] } {
- $path:cmd configure -state [Widget::getoption $path -state]
- set relief [Widget::getoption $path -relief]
- if { $_pressed == $path } {
- if { ![string compare $relief "link"] } {
- set relief raised
- }
- $path:cmd configure -relief $relief
- } elseif { ![string compare $relief "link"] } {
- $path:cmd configure -relief flat
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Button::_press
-# ------------------------------------------------------------------------------
-proc Button::_press { path } {
- variable _pressed
-
- if { [string compare [$path:cmd cget -state] "disabled"] } {
- set _pressed $path
- $path:cmd configure -relief sunken
- if { [set cmd [Widget::getoption $path -armcommand]] != "" } {
- uplevel \#0 $cmd
- if { [set delay [Widget::getoption $path -repeatdelay]] > 0 ||
- [set delay [Widget::getoption $path -repeatinterval]] > 0 } {
- after $delay "Button::_repeat $path"
- }
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Button::_release
-# ------------------------------------------------------------------------------
-proc Button::_release { path } {
- variable _current
- variable _pressed
-
- if { $_pressed == $path } {
- set _pressed ""
- set relief [Widget::getoption $path -relief]
- if { ![string compare $relief "link"] } {
- set relief raised
- }
- $path:cmd configure -relief $relief
- if { [set cmd [Widget::getoption $path -disarmcommand]] != "" } {
- uplevel \#0 $cmd
- }
- if { $_current == $path &&
- [string compare [$path:cmd cget -state] "disabled"] &&
- [set cmd [Widget::getoption $path -command]] != "" } {
- uplevel \#0 $cmd
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Button::_repeat
-# ------------------------------------------------------------------------------
-proc Button::_repeat { path } {
- variable _current
- variable _pressed
-
- if { $_current == $path && $_pressed == $path &&
- [string compare [$path:cmd cget -state] "disabled"] &&
- [set cmd [Widget::getoption $path -armcommand]] != "" } {
- uplevel \#0 $cmd
- }
- if { $_pressed == $path &&
- ([set delay [Widget::getoption $path -repeatinterval]] > 0 ||
- [set delay [Widget::getoption $path -repeatdelay]] > 0) } {
- after $delay "Button::_repeat $path"
- }
-}
-
Copied: grass/trunk/lib/external/bwidget/button.tcl (from rev 35192, grass/trunk/lib/external/bwidget/button.tcl)
===================================================================
--- grass/trunk/lib/external/bwidget/button.tcl (rev 0)
+++ grass/trunk/lib/external/bwidget/button.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,302 @@
+# ------------------------------------------------------------------------------
+# button.tcl
+# This file is part of Unifix BWidget Toolkit
+# ------------------------------------------------------------------------------
+# Index of commands:
+# Public commands
+# - Button::create
+# - Button::configure
+# - Button::cget
+# - Button::invoke
+# Private commands (event bindings)
+# - Button::_destroy
+# - Button::_enter
+# - Button::_leave
+# - Button::_press
+# - Button::_release
+# - Button::_repeat
+# ------------------------------------------------------------------------------
+
+namespace eval Button {
+ Widget::tkinclude Button button :cmd \
+ remove {-command -relief -text -textvariable -underline}
+
+ Widget::declare Button {
+ {-name String "" 0}
+ {-text String "" 0}
+ {-textvariable String "" 0}
+ {-underline Int -1 0 {=-1}}
+ {-armcommand String "" 0}
+ {-disarmcommand String "" 0}
+ {-command String "" 0}
+ {-repeatdelay Int 0 0 {=0 ""}}
+ {-repeatinterval Int 0 0 {=0 ""}}
+ {-relief Enum raised 0 {raised sunken flat ridge solid groove link}}
+ }
+
+ DynamicHelp::include Button balloon
+
+ Widget::syncoptions Button "" :cmd {-text {} -underline {}}
+
+ variable _current ""
+ variable _pressed ""
+
+ bind BwButton <Enter> {Button::_enter %W}
+ bind BwButton <Leave> {Button::_leave %W}
+ bind BwButton <ButtonPress-1> {Button::_press %W}
+ bind BwButton <ButtonRelease-1> {Button::_release %W}
+ bind BwButton <Key-space> {Button::invoke %W; break}
+ bind BwButton <Return> {Button::invoke %W; break}
+ bind BwButton <Destroy> {Widget::destroy %W; rename %W {}}
+
+ proc ::Button { path args } { return [eval Button::create $path $args] }
+ proc use {} {}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Button::create
+# ------------------------------------------------------------------------------
+proc Button::create { path args } {
+ Widget::init Button $path $args
+
+ set relief [Widget::getoption $path -relief]
+ if { ![string compare $relief "link"] } {
+ set relief "flat"
+ }
+
+ set var [Widget::getoption $path -textvariable]
+ if { ![string length $var] } {
+ set desc [BWidget::getname [Widget::getoption $path -name]]
+ if { [llength $desc] } {
+ set text [lindex $desc 0]
+ set under [lindex $desc 1]
+ Widget::setoption $path -text $text
+ Widget::setoption $path -underline $under
+ } else {
+ set text [Widget::getoption $path -text]
+ set under [Widget::getoption $path -underline]
+ }
+ } else {
+ set under -1
+ set text ""
+ Widget::setoption $path -underline $under
+ }
+
+ eval button $path [Widget::subcget $path :cmd] \
+ [list -relief $relief -text $text -underline $under -textvariable $var]
+ bindtags $path [list $path BwButton [winfo toplevel $path] all]
+
+ set accel [string tolower [string index $text $under]]
+ if { $accel != "" } {
+ bind [winfo toplevel $path] <Alt-$accel> "Button::invoke $path"
+ }
+
+ DynamicHelp::sethelp $path $path 1
+
+ rename $path ::$path:cmd
+ proc ::$path { cmd args } "return \[eval Button::\$cmd $path \$args\]"
+
+ return $path
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Button::configure
+# ------------------------------------------------------------------------------
+proc Button::configure { path args } {
+ set oldunder [$path:cmd cget -underline]
+ if { $oldunder != -1 } {
+ set oldaccel [string tolower [string index [$path:cmd cget -text] $oldunder]]
+ } else {
+ set oldaccel ""
+ }
+ set res [Widget::configure $path $args]
+
+ set rc [Widget::hasChanged $path -relief relief]
+ set sc [Widget::hasChanged $path -state state]
+
+ if { $rc || $sc } {
+ if { ![string compare $relief "link"] } {
+ if { ![string compare $state "active"] } {
+ set relief "raised"
+ } else {
+ set relief "flat"
+ }
+ }
+ $path:cmd configure -relief $relief -state $state
+ }
+
+ set cv [Widget::hasChanged $path -textvariable var]
+ set cn [Widget::hasChanged $path -name name]
+ set ct [Widget::hasChanged $path -text text]
+ set cu [Widget::hasChanged $path -underline under]
+
+ if { $cv || $cn || $ct || $cu } {
+ if { ![string length $var] } {
+ set desc [BWidget::getname $name]
+ if { [llength $desc] } {
+ set text [lindex $desc 0]
+ set under [lindex $desc 1]
+ }
+ } else {
+ set under -1
+ set text ""
+ }
+ set top [winfo toplevel $path]
+ bind $top <Alt-$oldaccel> {}
+ set accel [string tolower [string index $text $under]]
+ if { $accel != "" } {
+ bind $top <Alt-$accel> "Button::invoke $path"
+ }
+ $path:cmd configure -text $text -underline $under -textvariable $var
+ }
+ DynamicHelp::sethelp $path $path
+
+ return $res
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Button::cget
+# ------------------------------------------------------------------------------
+proc Button::cget { path option } {
+ return [Widget::cget $path $option]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Button::invoke
+# ------------------------------------------------------------------------------
+proc Button::invoke { path } {
+ if { [string compare [$path:cmd cget -state] "disabled"] } {
+ $path:cmd configure -state active -relief sunken
+ update idletasks
+ if { [set cmd [Widget::getoption $path -armcommand]] != "" } {
+ uplevel \#0 $cmd
+ }
+ after 100
+ set relief [Widget::getoption $path -relief]
+ if { ![string compare $relief "link"] } {
+ set relief flat
+ }
+ $path:cmd configure \
+ -state [Widget::getoption $path -state] \
+ -relief $relief
+ if { [set cmd [Widget::getoption $path -disarmcommand]] != "" } {
+ uplevel \#0 $cmd
+ }
+ if { [set cmd [Widget::getoption $path -command]] != "" } {
+ uplevel \#0 $cmd
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Button::_enter
+# ------------------------------------------------------------------------------
+proc Button::_enter { path } {
+ variable _current
+ variable _pressed
+
+ set _current $path
+ if { [string compare [$path:cmd cget -state] "disabled"] } {
+ $path:cmd configure -state active
+ if { $_pressed == $path } {
+ $path:cmd configure -relief sunken
+ } elseif { ![string compare [Widget::getoption $path -relief] "link"] } {
+ $path:cmd configure -relief raised
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Button::_leave
+# ------------------------------------------------------------------------------
+proc Button::_leave { path } {
+ variable _current
+ variable _pressed
+
+ set _current ""
+ if { [string compare [$path:cmd cget -state] "disabled"] } {
+ $path:cmd configure -state [Widget::getoption $path -state]
+ set relief [Widget::getoption $path -relief]
+ if { $_pressed == $path } {
+ if { ![string compare $relief "link"] } {
+ set relief raised
+ }
+ $path:cmd configure -relief $relief
+ } elseif { ![string compare $relief "link"] } {
+ $path:cmd configure -relief flat
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Button::_press
+# ------------------------------------------------------------------------------
+proc Button::_press { path } {
+ variable _pressed
+
+ if { [string compare [$path:cmd cget -state] "disabled"] } {
+ set _pressed $path
+ $path:cmd configure -relief sunken
+ if { [set cmd [Widget::getoption $path -armcommand]] != "" } {
+ uplevel \#0 $cmd
+ if { [set delay [Widget::getoption $path -repeatdelay]] > 0 ||
+ [set delay [Widget::getoption $path -repeatinterval]] > 0 } {
+ after $delay "Button::_repeat $path"
+ }
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Button::_release
+# ------------------------------------------------------------------------------
+proc Button::_release { path } {
+ variable _current
+ variable _pressed
+
+ if { $_pressed == $path } {
+ set _pressed ""
+ set relief [Widget::getoption $path -relief]
+ if { ![string compare $relief "link"] } {
+ set relief raised
+ }
+ $path:cmd configure -relief $relief
+ if { [set cmd [Widget::getoption $path -disarmcommand]] != "" } {
+ uplevel \#0 $cmd
+ }
+ if { $_current == $path &&
+ [string compare [$path:cmd cget -state] "disabled"] &&
+ [set cmd [Widget::getoption $path -command]] != "" } {
+ uplevel \#0 $cmd
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Button::_repeat
+# ------------------------------------------------------------------------------
+proc Button::_repeat { path } {
+ variable _current
+ variable _pressed
+
+ if { $_current == $path && $_pressed == $path &&
+ [string compare [$path:cmd cget -state] "disabled"] &&
+ [set cmd [Widget::getoption $path -armcommand]] != "" } {
+ uplevel \#0 $cmd
+ }
+ if { $_pressed == $path &&
+ ([set delay [Widget::getoption $path -repeatinterval]] > 0 ||
+ [set delay [Widget::getoption $path -repeatdelay]] > 0) } {
+ after $delay "Button::_repeat $path"
+ }
+}
+
Deleted: grass/trunk/lib/external/bwidget/buttonbox.tcl
===================================================================
--- grass/trunk/lib/external/bwidget/buttonbox.tcl 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/buttonbox.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,226 +0,0 @@
-# ------------------------------------------------------------------------------
-# buttonbox.tcl
-# This file is part of Unifix BWidget Toolkit
-# ------------------------------------------------------------------------------
-# Index of commands:
-# - ButtonBox::create
-# - ButtonBox::configure
-# - ButtonBox::cget
-# - ButtonBox::add
-# - ButtonBox::itemconfigure
-# - ButtonBox::itemcget
-# - ButtonBox::setfocus
-# - ButtonBox::invoke
-# - ButtonBox::index
-# - ButtonBox::_destroy
-# ------------------------------------------------------------------------------
-
-namespace eval ButtonBox {
- Button::use
-
- Widget::declare ButtonBox {
- {-background TkResource "" 0 frame}
- {-orient Enum horizontal 1 {horizontal vertical}}
- {-homogeneous Boolean 1 1}
- {-spacing Int 10 0 {=0}}
- {-padx TkResource "" 0 button}
- {-pady TkResource "" 0 button}
- {-default Int -1 0 {=-1}}
- {-bg Synonym -background}
- }
-
- Widget::addmap ButtonBox "" :cmd {-background {}}
-
- proc ::ButtonBox { path args } { return [eval ButtonBox::create $path $args] }
- proc use {} {}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ButtonBox::create
-# ------------------------------------------------------------------------------
-proc ButtonBox::create { path args } {
- Widget::init ButtonBox $path $args
-
- variable $path
- upvar 0 $path data
-
- eval frame $path [Widget::subcget $path :cmd] -takefocus 0 -highlightthickness 0
-
- set data(default) [Widget::getoption $path -default]
- set data(nbuttons) 0
- set data(max) 0
-
- bind $path <Destroy> "ButtonBox::_destroy $path"
-
- rename $path ::$path:cmd
- proc ::$path { cmd args } "return \[eval ButtonBox::\$cmd $path \$args\]"
-
- return $path
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ButtonBox::configure
-# ------------------------------------------------------------------------------
-proc ButtonBox::configure { path args } {
- variable $path
- upvar 0 $path data
-
- set res [Widget::configure $path $args]
-
- if { [Widget::hasChanged $path -default val] } {
- if { $data(default) != -1 && $val != -1 } {
- set but $path.b$data(default)
- if { [winfo exists $but] } {
- $but configure -default normal
- }
- set but $path.b$val
- if { [winfo exists $but] } {
- $but configure -default active
- }
- set data(default) $val
- } else {
- Widget::setoption $path -default $data(default)
- }
- }
-
- return $res
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ButtonBox::cget
-# ------------------------------------------------------------------------------
-proc ButtonBox::cget { path option } {
- return [Widget::cget $path $option]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ButtonBox::add
-# ------------------------------------------------------------------------------
-proc ButtonBox::add { path args } {
- variable $path
- upvar 0 $path data
-
- set but $path.b$data(nbuttons)
- set spacing [Widget::getoption $path -spacing]
-
- if { $data(nbuttons) == $data(default) } {
- set style active
- } elseif { $data(default) == -1 } {
- set style disabled
- } else {
- set style normal
- }
-
- eval Button::create $but \
- -background [Widget::getoption $path -background]\
- -padx [Widget::getoption $path -padx] \
- -pady [Widget::getoption $path -pady] \
- $args \
- -default $style
-
- set idx [expr {2*$data(nbuttons)}]
- if { ![string compare [Widget::getoption $path -orient] "horizontal"] } {
- grid $but -column $idx -row 0 -sticky nsew
- if { [Widget::getoption $path -homogeneous] } {
- set req [winfo reqwidth $but]
- if { $req > $data(max) } {
- for {set i 0} {$i < $data(nbuttons)} {incr i} {
- grid columnconfigure $path [expr {2*$i}] -minsize $req
- }
- set data(max) $req
- }
- grid columnconfigure $path $idx -minsize $data(max) -weight 1
- } else {
- grid columnconfigure $path $idx -weight 0
- }
- if { $data(nbuttons) > 0 } {
- grid columnconfigure $path [expr {$idx-1}] -minsize $spacing
- }
- } else {
- grid $but -column 0 -row $idx -sticky nsew
- grid rowconfigure $path $idx -weight 0
- if { $data(nbuttons) > 0 } {
- grid rowconfigure $path [expr {$idx-1}] -minsize $spacing
- }
- }
-
- incr data(nbuttons)
-
- return $but
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ButtonBox::itemconfigure
-# ------------------------------------------------------------------------------
-proc ButtonBox::itemconfigure { path index args } {
- if { [set idx [lsearch $args -default]] != -1 } {
- set args [lreplace $args $idx [expr {$idx+1}]]
- }
- return [eval Button::configure $path.b[index $path $index] $args]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ButtonBox::itemcget
-# ------------------------------------------------------------------------------
-proc ButtonBox::itemcget { path index option } {
- return [Button::cget $path.b[index $path $index] $option]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ButtonBox::setfocus
-# ------------------------------------------------------------------------------
-proc ButtonBox::setfocus { path index } {
- set but $path.b[index $path $index]
- if { [winfo exists $but] } {
- focus $but
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ButtonBox::invoke
-# ------------------------------------------------------------------------------
-proc ButtonBox::invoke { path index } {
- set but $path.b[index $path $index]
- if { [winfo exists $but] } {
- Button::invoke $but
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ButtonBox::index
-# ------------------------------------------------------------------------------
-proc ButtonBox::index { path index } {
- if { ![string compare $index "default"] } {
- set res [Widget::getoption $path -default]
- } elseif { ![string compare $index "end"] || ![string compare $index "last"] } {
- variable $path
- upvar 0 $path data
-
- set res [expr {$data(nbuttons)-1}]
- } else {
- set res $index
- }
- return $res
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ButtonBox::_destroy
-# ------------------------------------------------------------------------------
-proc ButtonBox::_destroy { path } {
- variable $path
- upvar 0 $path data
-
- Widget::destroy $path
- unset data
- rename $path {}
-}
Copied: grass/trunk/lib/external/bwidget/buttonbox.tcl (from rev 35192, grass/trunk/lib/external/bwidget/buttonbox.tcl)
===================================================================
--- grass/trunk/lib/external/bwidget/buttonbox.tcl (rev 0)
+++ grass/trunk/lib/external/bwidget/buttonbox.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,226 @@
+# ------------------------------------------------------------------------------
+# buttonbox.tcl
+# This file is part of Unifix BWidget Toolkit
+# ------------------------------------------------------------------------------
+# Index of commands:
+# - ButtonBox::create
+# - ButtonBox::configure
+# - ButtonBox::cget
+# - ButtonBox::add
+# - ButtonBox::itemconfigure
+# - ButtonBox::itemcget
+# - ButtonBox::setfocus
+# - ButtonBox::invoke
+# - ButtonBox::index
+# - ButtonBox::_destroy
+# ------------------------------------------------------------------------------
+
+namespace eval ButtonBox {
+ Button::use
+
+ Widget::declare ButtonBox {
+ {-background TkResource "" 0 frame}
+ {-orient Enum horizontal 1 {horizontal vertical}}
+ {-homogeneous Boolean 1 1}
+ {-spacing Int 10 0 {=0}}
+ {-padx TkResource "" 0 button}
+ {-pady TkResource "" 0 button}
+ {-default Int -1 0 {=-1}}
+ {-bg Synonym -background}
+ }
+
+ Widget::addmap ButtonBox "" :cmd {-background {}}
+
+ proc ::ButtonBox { path args } { return [eval ButtonBox::create $path $args] }
+ proc use {} {}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ButtonBox::create
+# ------------------------------------------------------------------------------
+proc ButtonBox::create { path args } {
+ Widget::init ButtonBox $path $args
+
+ variable $path
+ upvar 0 $path data
+
+ eval frame $path [Widget::subcget $path :cmd] -takefocus 0 -highlightthickness 0
+
+ set data(default) [Widget::getoption $path -default]
+ set data(nbuttons) 0
+ set data(max) 0
+
+ bind $path <Destroy> "ButtonBox::_destroy $path"
+
+ rename $path ::$path:cmd
+ proc ::$path { cmd args } "return \[eval ButtonBox::\$cmd $path \$args\]"
+
+ return $path
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ButtonBox::configure
+# ------------------------------------------------------------------------------
+proc ButtonBox::configure { path args } {
+ variable $path
+ upvar 0 $path data
+
+ set res [Widget::configure $path $args]
+
+ if { [Widget::hasChanged $path -default val] } {
+ if { $data(default) != -1 && $val != -1 } {
+ set but $path.b$data(default)
+ if { [winfo exists $but] } {
+ $but configure -default normal
+ }
+ set but $path.b$val
+ if { [winfo exists $but] } {
+ $but configure -default active
+ }
+ set data(default) $val
+ } else {
+ Widget::setoption $path -default $data(default)
+ }
+ }
+
+ return $res
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ButtonBox::cget
+# ------------------------------------------------------------------------------
+proc ButtonBox::cget { path option } {
+ return [Widget::cget $path $option]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ButtonBox::add
+# ------------------------------------------------------------------------------
+proc ButtonBox::add { path args } {
+ variable $path
+ upvar 0 $path data
+
+ set but $path.b$data(nbuttons)
+ set spacing [Widget::getoption $path -spacing]
+
+ if { $data(nbuttons) == $data(default) } {
+ set style active
+ } elseif { $data(default) == -1 } {
+ set style disabled
+ } else {
+ set style normal
+ }
+
+ eval Button::create $but \
+ -background [Widget::getoption $path -background]\
+ -padx [Widget::getoption $path -padx] \
+ -pady [Widget::getoption $path -pady] \
+ $args \
+ -default $style
+
+ set idx [expr {2*$data(nbuttons)}]
+ if { ![string compare [Widget::getoption $path -orient] "horizontal"] } {
+ grid $but -column $idx -row 0 -sticky nsew
+ if { [Widget::getoption $path -homogeneous] } {
+ set req [winfo reqwidth $but]
+ if { $req > $data(max) } {
+ for {set i 0} {$i < $data(nbuttons)} {incr i} {
+ grid columnconfigure $path [expr {2*$i}] -minsize $req
+ }
+ set data(max) $req
+ }
+ grid columnconfigure $path $idx -minsize $data(max) -weight 1
+ } else {
+ grid columnconfigure $path $idx -weight 0
+ }
+ if { $data(nbuttons) > 0 } {
+ grid columnconfigure $path [expr {$idx-1}] -minsize $spacing
+ }
+ } else {
+ grid $but -column 0 -row $idx -sticky nsew
+ grid rowconfigure $path $idx -weight 0
+ if { $data(nbuttons) > 0 } {
+ grid rowconfigure $path [expr {$idx-1}] -minsize $spacing
+ }
+ }
+
+ incr data(nbuttons)
+
+ return $but
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ButtonBox::itemconfigure
+# ------------------------------------------------------------------------------
+proc ButtonBox::itemconfigure { path index args } {
+ if { [set idx [lsearch $args -default]] != -1 } {
+ set args [lreplace $args $idx [expr {$idx+1}]]
+ }
+ return [eval Button::configure $path.b[index $path $index] $args]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ButtonBox::itemcget
+# ------------------------------------------------------------------------------
+proc ButtonBox::itemcget { path index option } {
+ return [Button::cget $path.b[index $path $index] $option]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ButtonBox::setfocus
+# ------------------------------------------------------------------------------
+proc ButtonBox::setfocus { path index } {
+ set but $path.b[index $path $index]
+ if { [winfo exists $but] } {
+ focus $but
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ButtonBox::invoke
+# ------------------------------------------------------------------------------
+proc ButtonBox::invoke { path index } {
+ set but $path.b[index $path $index]
+ if { [winfo exists $but] } {
+ Button::invoke $but
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ButtonBox::index
+# ------------------------------------------------------------------------------
+proc ButtonBox::index { path index } {
+ if { ![string compare $index "default"] } {
+ set res [Widget::getoption $path -default]
+ } elseif { ![string compare $index "end"] || ![string compare $index "last"] } {
+ variable $path
+ upvar 0 $path data
+
+ set res [expr {$data(nbuttons)-1}]
+ } else {
+ set res $index
+ }
+ return $res
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ButtonBox::_destroy
+# ------------------------------------------------------------------------------
+proc ButtonBox::_destroy { path } {
+ variable $path
+ upvar 0 $path data
+
+ Widget::destroy $path
+ unset data
+ rename $path {}
+}
Deleted: grass/trunk/lib/external/bwidget/color.tcl
===================================================================
--- grass/trunk/lib/external/bwidget/color.tcl 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/color.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,314 +0,0 @@
-# ------------------------------------------------------------------------------
-# color.tcl
-# This file is part of Unifix BWidget Toolkit
-# ------------------------------------------------------------------------------
-# Index of commands:
-# - SelectColor::create
-# - SelectColor::setcolor
-# - SelectColor::_destroy
-# - SelectColor::_update_var
-# - SelectColor::_post_menu
-# - SelectColor::_tk_choose_color
-# - SelectColor::_activate
-# ------------------------------------------------------------------------------
-
-namespace eval SelectColor {
- Widget::declare SelectColor {
- {-title String "" 0}
- {-parent String "" 0}
- {-type Enum dialog 1 {dialog menubutton}}
- {-command String "" 0}
- {-color TkResource "" 0 {label -background}}
- {-variable String "" 0}
- {-width TkResource 15 0 frame}
- {-height TkResource 15 0 frame}
- }
-
- Widget::addmap SelectColor "" :cmd {-width {} -height {}}
- Widget::syncoptions SelectColor "" :cmd {-color -background}
-
- variable _tabcolors {
- \#0000ff \#000099 \#000000 white
- \#00ff00 \#009900 \#333333 white
- \#00ffff \#009999 \#666666 white
- \#ff0000 \#990000 \#999999 white
- \#ff00ff \#990099 \#cccccc white
- \#ffff00 \#999900 \#ffffff
- }
-
- # bindings
- bind SelectColor <ButtonPress-1> {SelectColor::_post_menu %W %X %Y}
- bind SelectColor <Destroy> {SelectColor::_destroy %W}
-
- variable _widget
-
- proc ::SelectColor { path args } { return [eval SelectColor::create $path $args] }
- proc use {} {}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command SelectColor::create
-# ------------------------------------------------------------------------------
-proc SelectColor::create { path args } {
- variable _tabcolors
- variable _widget
-
- Widget::init SelectColor $path $args
-
- if { ![string compare [Widget::getoption $path -type] "menubutton"] } {
- if { [set var [Widget::getoption $path -variable]] != "" } {
- set _widget($path,var) $var
- if { [GlobalVar::exists $var] } {
- Widget::setoption $path -color [GlobalVar::getvar $var]
- } else {
- GlobalVar::setvar $var [Widget::getoption $path -color]
- }
- GlobalVar::tracevar variable $var w "SelectColor::_update_var $path"
- } else {
- set _widget($path,var) ""
- }
-
- eval frame $path [Widget::subcget $path :cmd] \
- -background [Widget::getoption $path -color] \
- -relief raised -borderwidth 2 -highlightthickness 0
- bindtags $path [list $path SelectColor . all]
- set _widget($path,idx) 0
-
- rename $path ::$path:cmd
- proc ::$path { cmd args } "return \[eval SelectColor::\$cmd $path \$args\]"
- } else {
- set parent [Widget::getoption $path -parent]
- set title [Widget::getoption $path -title]
- set lopt [list -initialcolor [Widget::getoption $path -color]]
- if { [winfo exists $parent] } {
- lappend lopt -parent $parent
- }
- if { $title != "" } {
- lappend lopt -title $title
- }
- set col [eval tk_chooseColor $lopt]
- Widget::destroy $path
- return $col
- }
-
- return $path
-}
-
-
-# ------------------------------------------------------------------------------
-# Command SelectColor::configure
-# ------------------------------------------------------------------------------
-proc SelectColor::configure { path args } {
- variable _widget
-
- set res [Widget::configure $path $args]
-
- if { [Widget::hasChanged $path -variable var] } {
- if { [string length $_widget($path,var)] } {
- GlobalVar::tracevar vdelete $_widget($path,var) w "SelectColor::_update_var $path"
- }
- set _widget($path,var) $var
- if { [string length $_widget($path,var)] } {
- Widget::hasChanged $path -color curval
- if { [GlobalVar::exists $_widget($path,var)] } {
- Widget::setoption $path -color [set curval [GlobalVar::getvar $_widget($path,var)]]
- } else {
- GlobalVar::setvar $_widget($path,var) $curval
- }
- GlobalVar::tracevar variable $_widget($path,var) w "SelectColor::_update_var $path"
- $path:cmd configure -background $curval
- }
- }
-
- if { [Widget::hasChanged $path -color curval] } {
- if { [string length $_widget($path,var)] } {
- Widget::setoption $path -color [GlobalVar::getvar $_widget($path,var)]
- } else {
- $path:cmd configure -background $curval
- }
- }
- return $res
-}
-
-
-# ------------------------------------------------------------------------------
-# Command SelectColor::cget
-# ------------------------------------------------------------------------------
-proc SelectColor::cget { path option } {
- return [Widget::cget $path $option]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command SelectColor::setcolor
-# ------------------------------------------------------------------------------
-proc SelectColor::setcolor { index color } {
- variable _tabcolors
- variable _widget
-
- if { $index >= 1 && $index <= 5 } {
- set idx [expr {int($idx) * 3}]
- set _tabcolors [lreplace $_tabcolors $idx $idx $color]
- return 1
- }
- return 0
-}
-
-
-# ------------------------------------------------------------------------------
-# Command SelectColor::_destroy
-# ------------------------------------------------------------------------------
-proc SelectColor::_destroy { path } {
- variable _widget
-
- if { [string length $_widget($path,var)] } {
- GlobalVar::tracevar vdelete $_widget($path,var) w "SelectColor::_update_var $path"
- }
- unset _widget($path,var)
- unset _widget($path,idx)
- Widget::destroy $path
- rename $path {}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command SelectColor::_update_var
-# ------------------------------------------------------------------------------
-proc SelectColor::_update_var { path args } {
- variable _tabcolors
- variable _widget
-
- set col [GlobalVar::getvar $_widget($path,var)]
- $path:cmd configure -background $col
- Widget::setoption $path -color $col
- set _widget($path,idx) [lsearch $_tabcolors $col]
- if { $_widget($path,idx) == -1 } {
- set _widget($path,idx) 0
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command SelectColor::_post_menu
-# ------------------------------------------------------------------------------
-proc SelectColor::_post_menu { path X Y } {
- global env
- variable _tabcolors
- variable _widget
-
- if { [winfo exists $path.menu] } {
- if { [string compare [winfo containing $X $Y] $path] } {
- BWidget::grab release $path
- destroy $path.menu
- }
- return
- }
-
- set top [menu $path.menu]
- wm withdraw $top
- wm transient $top [winfo toplevel $path]
- set col 0
- set row 0
- set count 0
- set frame [frame $top.frame -highlightthickness 0 -relief raised -borderwidth 2]
- foreach color $_tabcolors {
- set f [frame $frame.c$count \
- -relief flat -bd 0 -highlightthickness 1 \
- -width 16 -height 16 -background $color]
- bind $f <ButtonRelease-1> "SelectColor::_activate $path %W"
- bind $f <Enter> {focus %W}
- grid $f -column $col -row $row -padx 1 -pady 1
- bindtags $f $f
- incr row
- incr count
- if { $row == 4 } {
- set row 0
- incr col
- }
- }
- set f [label $frame.c$count \
- -relief flat -bd 0 -highlightthickness 1 \
- -width 16 -height 16 -image [Bitmap::get palette]]
- grid $f -column $col -row $row -padx 1 -pady 1
- bind $f <ButtonRelease-1> "SelectColor::_tk_choose_color $path"
- bind $f <Enter> {focus %W}
- pack $frame
-
- BWidget::place $top 0 0 below $path
-
- wm deiconify $top
- raise $top
- focus $frame
- focus $top.frame.c$_widget($path,idx)
- BWidget::grab set $path
-}
-
-
-# ------------------------------------------------------------------------------
-# Command SelectColor::_tk_choose_color
-# ------------------------------------------------------------------------------
-proc SelectColor::_tk_choose_color { path } {
- variable _tabcolors
- variable _widget
-
- BWidget::grab release $path
- destroy $path.menu
- set parent [Widget::getoption $path -parent]
- set title [Widget::getoption $path -title]
- set lopt [list -initialcolor [$path:cmd cget -background]]
- if { [winfo exists $parent] } {
- lappend lopt -parent $parent
- }
- if { $title != "" } {
- lappend lopt -title $title
- }
- set col [eval tk_chooseColor $lopt]
- if { $col != "" } {
- if { $_widget($path,idx) % 4 == 3 } {
- set idx $_widget($path,idx)
- } else {
- set idx -1
- for {set i 3} {$i < 15} {incr i 4} {
- if { [lindex $_tabcolors $i] == "white" } {
- set idx $i
- break
- }
- }
- }
- if { $idx != -1 } {
- set _tabcolors [lreplace $_tabcolors $idx $idx $col]
- set _widget($path,idx) $idx
- }
- if { [info exists _widget($path,var)] } {
- GlobalVar::setvar $_widget($path,var) $col
- }
- if { [set cmd [Widget::getoption $path -command]] != "" } {
- uplevel \#0 $cmd
- }
- $path:cmd configure -background $col
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command SelectColor::_activate
-# ------------------------------------------------------------------------------
-proc SelectColor::_activate { path cell } {
- variable _tabcolors
- variable _widget
-
- BWidget::grab release $path
- set col [$cell cget -background]
- destroy $path.menu
- if { [string length $_widget($path,var)] } {
- GlobalVar::setvar $_widget($path,var) $col
- }
- Widget::setoption $path -color $col
- $path:cmd configure -background $col
-
- if { [set cmd [Widget::getoption $path -command]] != "" } {
- uplevel \#0 $cmd
- }
- set _widget($path,idx) [string range [lindex [split $cell "."] end] 1 end]
-}
Copied: grass/trunk/lib/external/bwidget/color.tcl (from rev 35192, grass/trunk/lib/external/bwidget/color.tcl)
===================================================================
--- grass/trunk/lib/external/bwidget/color.tcl (rev 0)
+++ grass/trunk/lib/external/bwidget/color.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,314 @@
+# ------------------------------------------------------------------------------
+# color.tcl
+# This file is part of Unifix BWidget Toolkit
+# ------------------------------------------------------------------------------
+# Index of commands:
+# - SelectColor::create
+# - SelectColor::setcolor
+# - SelectColor::_destroy
+# - SelectColor::_update_var
+# - SelectColor::_post_menu
+# - SelectColor::_tk_choose_color
+# - SelectColor::_activate
+# ------------------------------------------------------------------------------
+
+namespace eval SelectColor {
+ Widget::declare SelectColor {
+ {-title String "" 0}
+ {-parent String "" 0}
+ {-type Enum dialog 1 {dialog menubutton}}
+ {-command String "" 0}
+ {-color TkResource "" 0 {label -background}}
+ {-variable String "" 0}
+ {-width TkResource 15 0 frame}
+ {-height TkResource 15 0 frame}
+ }
+
+ Widget::addmap SelectColor "" :cmd {-width {} -height {}}
+ Widget::syncoptions SelectColor "" :cmd {-color -background}
+
+ variable _tabcolors {
+ \#0000ff \#000099 \#000000 white
+ \#00ff00 \#009900 \#333333 white
+ \#00ffff \#009999 \#666666 white
+ \#ff0000 \#990000 \#999999 white
+ \#ff00ff \#990099 \#cccccc white
+ \#ffff00 \#999900 \#ffffff
+ }
+
+ # bindings
+ bind SelectColor <ButtonPress-1> {SelectColor::_post_menu %W %X %Y}
+ bind SelectColor <Destroy> {SelectColor::_destroy %W}
+
+ variable _widget
+
+ proc ::SelectColor { path args } { return [eval SelectColor::create $path $args] }
+ proc use {} {}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command SelectColor::create
+# ------------------------------------------------------------------------------
+proc SelectColor::create { path args } {
+ variable _tabcolors
+ variable _widget
+
+ Widget::init SelectColor $path $args
+
+ if { ![string compare [Widget::getoption $path -type] "menubutton"] } {
+ if { [set var [Widget::getoption $path -variable]] != "" } {
+ set _widget($path,var) $var
+ if { [GlobalVar::exists $var] } {
+ Widget::setoption $path -color [GlobalVar::getvar $var]
+ } else {
+ GlobalVar::setvar $var [Widget::getoption $path -color]
+ }
+ GlobalVar::tracevar variable $var w "SelectColor::_update_var $path"
+ } else {
+ set _widget($path,var) ""
+ }
+
+ eval frame $path [Widget::subcget $path :cmd] \
+ -background [Widget::getoption $path -color] \
+ -relief raised -borderwidth 2 -highlightthickness 0
+ bindtags $path [list $path SelectColor . all]
+ set _widget($path,idx) 0
+
+ rename $path ::$path:cmd
+ proc ::$path { cmd args } "return \[eval SelectColor::\$cmd $path \$args\]"
+ } else {
+ set parent [Widget::getoption $path -parent]
+ set title [Widget::getoption $path -title]
+ set lopt [list -initialcolor [Widget::getoption $path -color]]
+ if { [winfo exists $parent] } {
+ lappend lopt -parent $parent
+ }
+ if { $title != "" } {
+ lappend lopt -title $title
+ }
+ set col [eval tk_chooseColor $lopt]
+ Widget::destroy $path
+ return $col
+ }
+
+ return $path
+}
+
+
+# ------------------------------------------------------------------------------
+# Command SelectColor::configure
+# ------------------------------------------------------------------------------
+proc SelectColor::configure { path args } {
+ variable _widget
+
+ set res [Widget::configure $path $args]
+
+ if { [Widget::hasChanged $path -variable var] } {
+ if { [string length $_widget($path,var)] } {
+ GlobalVar::tracevar vdelete $_widget($path,var) w "SelectColor::_update_var $path"
+ }
+ set _widget($path,var) $var
+ if { [string length $_widget($path,var)] } {
+ Widget::hasChanged $path -color curval
+ if { [GlobalVar::exists $_widget($path,var)] } {
+ Widget::setoption $path -color [set curval [GlobalVar::getvar $_widget($path,var)]]
+ } else {
+ GlobalVar::setvar $_widget($path,var) $curval
+ }
+ GlobalVar::tracevar variable $_widget($path,var) w "SelectColor::_update_var $path"
+ $path:cmd configure -background $curval
+ }
+ }
+
+ if { [Widget::hasChanged $path -color curval] } {
+ if { [string length $_widget($path,var)] } {
+ Widget::setoption $path -color [GlobalVar::getvar $_widget($path,var)]
+ } else {
+ $path:cmd configure -background $curval
+ }
+ }
+ return $res
+}
+
+
+# ------------------------------------------------------------------------------
+# Command SelectColor::cget
+# ------------------------------------------------------------------------------
+proc SelectColor::cget { path option } {
+ return [Widget::cget $path $option]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command SelectColor::setcolor
+# ------------------------------------------------------------------------------
+proc SelectColor::setcolor { index color } {
+ variable _tabcolors
+ variable _widget
+
+ if { $index >= 1 && $index <= 5 } {
+ set idx [expr {int($idx) * 3}]
+ set _tabcolors [lreplace $_tabcolors $idx $idx $color]
+ return 1
+ }
+ return 0
+}
+
+
+# ------------------------------------------------------------------------------
+# Command SelectColor::_destroy
+# ------------------------------------------------------------------------------
+proc SelectColor::_destroy { path } {
+ variable _widget
+
+ if { [string length $_widget($path,var)] } {
+ GlobalVar::tracevar vdelete $_widget($path,var) w "SelectColor::_update_var $path"
+ }
+ unset _widget($path,var)
+ unset _widget($path,idx)
+ Widget::destroy $path
+ rename $path {}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command SelectColor::_update_var
+# ------------------------------------------------------------------------------
+proc SelectColor::_update_var { path args } {
+ variable _tabcolors
+ variable _widget
+
+ set col [GlobalVar::getvar $_widget($path,var)]
+ $path:cmd configure -background $col
+ Widget::setoption $path -color $col
+ set _widget($path,idx) [lsearch $_tabcolors $col]
+ if { $_widget($path,idx) == -1 } {
+ set _widget($path,idx) 0
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command SelectColor::_post_menu
+# ------------------------------------------------------------------------------
+proc SelectColor::_post_menu { path X Y } {
+ global env
+ variable _tabcolors
+ variable _widget
+
+ if { [winfo exists $path.menu] } {
+ if { [string compare [winfo containing $X $Y] $path] } {
+ BWidget::grab release $path
+ destroy $path.menu
+ }
+ return
+ }
+
+ set top [menu $path.menu]
+ wm withdraw $top
+ wm transient $top [winfo toplevel $path]
+ set col 0
+ set row 0
+ set count 0
+ set frame [frame $top.frame -highlightthickness 0 -relief raised -borderwidth 2]
+ foreach color $_tabcolors {
+ set f [frame $frame.c$count \
+ -relief flat -bd 0 -highlightthickness 1 \
+ -width 16 -height 16 -background $color]
+ bind $f <ButtonRelease-1> "SelectColor::_activate $path %W"
+ bind $f <Enter> {focus %W}
+ grid $f -column $col -row $row -padx 1 -pady 1
+ bindtags $f $f
+ incr row
+ incr count
+ if { $row == 4 } {
+ set row 0
+ incr col
+ }
+ }
+ set f [label $frame.c$count \
+ -relief flat -bd 0 -highlightthickness 1 \
+ -width 16 -height 16 -image [Bitmap::get palette]]
+ grid $f -column $col -row $row -padx 1 -pady 1
+ bind $f <ButtonRelease-1> "SelectColor::_tk_choose_color $path"
+ bind $f <Enter> {focus %W}
+ pack $frame
+
+ BWidget::place $top 0 0 below $path
+
+ wm deiconify $top
+ raise $top
+ focus $frame
+ focus $top.frame.c$_widget($path,idx)
+ BWidget::grab set $path
+}
+
+
+# ------------------------------------------------------------------------------
+# Command SelectColor::_tk_choose_color
+# ------------------------------------------------------------------------------
+proc SelectColor::_tk_choose_color { path } {
+ variable _tabcolors
+ variable _widget
+
+ BWidget::grab release $path
+ destroy $path.menu
+ set parent [Widget::getoption $path -parent]
+ set title [Widget::getoption $path -title]
+ set lopt [list -initialcolor [$path:cmd cget -background]]
+ if { [winfo exists $parent] } {
+ lappend lopt -parent $parent
+ }
+ if { $title != "" } {
+ lappend lopt -title $title
+ }
+ set col [eval tk_chooseColor $lopt]
+ if { $col != "" } {
+ if { $_widget($path,idx) % 4 == 3 } {
+ set idx $_widget($path,idx)
+ } else {
+ set idx -1
+ for {set i 3} {$i < 15} {incr i 4} {
+ if { [lindex $_tabcolors $i] == "white" } {
+ set idx $i
+ break
+ }
+ }
+ }
+ if { $idx != -1 } {
+ set _tabcolors [lreplace $_tabcolors $idx $idx $col]
+ set _widget($path,idx) $idx
+ }
+ if { [info exists _widget($path,var)] } {
+ GlobalVar::setvar $_widget($path,var) $col
+ }
+ if { [set cmd [Widget::getoption $path -command]] != "" } {
+ uplevel \#0 $cmd
+ }
+ $path:cmd configure -background $col
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command SelectColor::_activate
+# ------------------------------------------------------------------------------
+proc SelectColor::_activate { path cell } {
+ variable _tabcolors
+ variable _widget
+
+ BWidget::grab release $path
+ set col [$cell cget -background]
+ destroy $path.menu
+ if { [string length $_widget($path,var)] } {
+ GlobalVar::setvar $_widget($path,var) $col
+ }
+ Widget::setoption $path -color $col
+ $path:cmd configure -background $col
+
+ if { [set cmd [Widget::getoption $path -command]] != "" } {
+ uplevel \#0 $cmd
+ }
+ set _widget($path,idx) [string range [lindex [split $cell "."] end] 1 end]
+}
Deleted: grass/trunk/lib/external/bwidget/combobox.tcl
===================================================================
--- grass/trunk/lib/external/bwidget/combobox.tcl 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/combobox.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,340 +0,0 @@
-# ------------------------------------------------------------------------------
-# combobox.tcl
-# This file is part of Unifix BWidget Toolkit
-# $Id$
-# ------------------------------------------------------------------------------
-# Index of commands:
-# - ComboBox::create
-# - ComboBox::configure
-# - ComboBox::cget
-# - ComboBox::setvalue
-# - ComboBox::getvalue
-# - ComboBox::_create_popup
-# - ComboBox::_mapliste
-# - ComboBox::_unmapliste
-# - ComboBox::_select
-# - ComboBox::_modify_value
-# ------------------------------------------------------------------------------
-
-namespace eval ComboBox {
- ArrowButton::use
- Entry::use
- LabelFrame::use
-
- Widget::bwinclude ComboBox LabelFrame .labf \
- rename {-text -label} \
- remove {-focus} \
- prefix {label -justify -width -anchor -height -font} \
- initialize {-relief sunken -borderwidth 2}
-
- Widget::bwinclude ComboBox Entry .e \
- remove {-relief -bd -borderwidth -bg -fg} \
- rename {-foreground -entryfg -background -entrybg}
-
- Widget::declare ComboBox {
- {-height TkResource 0 0 listbox}
- {-values String "" 0}
- {-modifycmd String "" 0}
- {-postcommand String "" 0}
- }
-
- Widget::addmap ComboBox "" :cmd {-background {}}
- Widget::addmap ComboBox ArrowButton .a \
- {-foreground {} -background {} -disabledforeground {} -state {}}
-
- Widget::syncoptions ComboBox Entry .e {-text {}}
- Widget::syncoptions ComboBox LabelFrame .labf {-label -text -underline {}}
-
- ::bind BwComboBox <FocusIn> {focus %W.labf}
- ::bind BwComboBox <Destroy> {Widget::destroy %W; rename %W {}}
-
- proc ::ComboBox { path args } { return [eval ComboBox::create $path $args] }
- proc use {} {}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ComboBox::create
-# ------------------------------------------------------------------------------
-proc ComboBox::create { path args } {
- Widget::init ComboBox $path $args
-
- frame $path -background [Widget::getoption $path -background] \
- -highlightthickness 0 -bd 0 -relief flat -takefocus 0
-
- bindtags $path [list $path BwComboBox [winfo toplevel $path] all]
-
- set labf [eval LabelFrame::create $path.labf [Widget::subcget $path .labf] \
- -focus $path.e]
- set entry [eval Entry::create $path.e [Widget::subcget $path .e] \
- -relief flat -borderwidth 0]
-
- set width 11
- set height [winfo reqheight $entry]
- set arrow [eval ArrowButton::create $path.a [Widget::subcget $path .a] \
- -width $width -height $height \
- -highlightthickness 0 -borderwidth 1 -takefocus 0 \
- -dir bottom \
- -type button \
- -command [list "ComboBox::_mapliste $path"]]
-
- set frame [LabelFrame::getframe $labf]
-
- pack $arrow -in $frame -side right -fill y
- pack $entry -in $frame -side left -fill both -expand yes
- pack $labf -fill x -expand yes
-
- if { [Widget::getoption $path -editable] == 0 } {
- ::bind $entry <ButtonPress-1> "ArrowButton::invoke $path.a"
- } else {
- ::bind $entry <ButtonPress-1> "ComboBox::_unmapliste $path"
- }
-
- ::bind $path <ButtonPress-1> "ComboBox::_unmapliste $path"
- ::bind $entry <Key-Up> "ComboBox::_modify_value $path previous"
- ::bind $entry <Key-Down> "ComboBox::_modify_value $path next"
- ::bind $entry <Key-Prior> "ComboBox::_modify_value $path first"
- ::bind $entry <Key-Next> "ComboBox::_modify_value $path last"
-
- rename $path ::$path:cmd
- proc ::$path { cmd args } "return \[eval ComboBox::\$cmd $path \$args\]"
-
- return $path
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ComboBox::configure
-# ------------------------------------------------------------------------------
-proc ComboBox::configure { path args } {
- set res [Widget::configure $path $args]
-
- if { [Widget::hasChanged $path -values values] |
- [Widget::hasChanged $path -height h] |
- [Widget::hasChanged $path -font f] } {
- destroy $path.shell.listb
- }
-
- if { [Widget::hasChanged $path -editable ed] } {
- if { $ed } {
- ::bind $path.e <ButtonPress-1> "ComboBox::_unmapliste $path"
- } else {
- ::bind $path.e <ButtonPress-1> "ArrowButton::invoke $path.a"
- }
- }
-
- return $res
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ComboBox::cget
-# ------------------------------------------------------------------------------
-proc ComboBox::cget { path option } {
- Widget::setoption $path -text [Entry::cget $path.e -text]
- return [Widget::cget $path $option]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ComboBox::setvalue
-# ------------------------------------------------------------------------------
-proc ComboBox::setvalue { path index } {
- set values [Widget::getoption $path -values]
- set value [Entry::cget $path.e -text]
- switch -- $index {
- next {
- if { [set idx [lsearch $values $value]] != -1 } {
- incr idx
- } else {
- set idx [lsearch $values "$value*"]
- }
- }
- previous {
- if { [set idx [lsearch $values $value]] != -1 } {
- incr idx -1
- } else {
- set idx [lsearch $values "$value*"]
- }
- }
- first {
- set idx 0
- }
- last {
- set idx [expr {[llength $values]-1}]
- }
- default {
- if { [string index $index 0] == "@" } {
- set idx [string range $index 1 end]
- if { [catch {string compare [expr {int($idx)}] $idx} res] || $res != 0 } {
- return -code error "bad index \"$index\""
- }
- } else {
- return -code error "bad index \"$index\""
- }
- }
- }
- if { $idx >= 0 && $idx < [llength $values] } {
- set newval [lindex $values $idx]
- Widget::setoption $path -text $newval
- if { [set varname [Entry::cget $path.e -textvariable]] != "" } {
- GlobalVar::setvar $varname $newval
- } else {
- Entry::configure $path.e -text $newval
- }
- return 1
- }
- return 0
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ComboBox::getvalue
-# ------------------------------------------------------------------------------
-proc ComboBox::getvalue { path } {
- set values [Widget::getoption $path -values]
- set value [Entry::cget $path.e -text]
-
- return [lsearch $values $value]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ComboBox::bind
-# ------------------------------------------------------------------------------
-proc ComboBox::bind { path args } {
- return [eval ::bind $path.e $args]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ComboBox::_create_popup
-# ------------------------------------------------------------------------------
-proc ComboBox::_create_popup { path } {
- set shell [menu $path.shell -tearoff 0 -relief flat -bd 0]
- wm overrideredirect $shell 1
- wm withdraw $shell
- wm transient $shell [winfo toplevel $path]
- wm group $shell [winfo toplevel $path]
- set lval [Widget::getoption $path -values]
- set h [Widget::getoption $path -height]
- set sb 0
- if { $h <= 0 } {
- set len [llength $lval]
- if { $len < 3 } {
- set h 3
- } elseif { $len > 10 } {
- set h 10
- set sb 1
- }
- }
- set frame [frame $shell.frame -relief sunken -bd 2]
- set listb [listbox $shell.listb -relief flat -bd 0 -highlightthickness 0 \
- -exportselection false \
- -font [Widget::getoption $path -font] \
- -height $h]
-
- if { $sb } {
- set scroll [scrollbar $shell.scroll \
- -orient vertical \
- -command "$shell.listb yview" \
- -highlightthickness 0 -takefocus 0 -width 9]
- $listb configure -yscrollcommand "$scroll set"
- }
- $listb delete 0 end
- foreach val $lval {
- $listb insert end $val
- }
-
- if { $sb } {
- pack $scroll -in $frame -side right -fill y
- }
- pack $listb -in $frame -side left -fill both -expand yes
- pack $frame -fill both -expand yes -padx 1 -padx 1
-
- ::bind $listb <ButtonRelease-1> "ComboBox::_select $path @%x,%y"
- ::bind $listb <Return> "ComboBox::_select $path active"
- ::bind $listb <Escape> "ComboBox::_unmapliste $path"
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ComboBox::_mapliste
-# ------------------------------------------------------------------------------
-proc ComboBox::_mapliste { path } {
- set listb $path.shell.listb
- if { [winfo exists $path.shell] } {
- _unmapliste $path
- return
- }
-
- if { [Widget::getoption $path -state] == "disabled" } {
- return
- }
- if { [set cmd [Widget::getoption $path -postcommand]] != "" } {
- uplevel \#0 $cmd
- }
- if { ![llength [Widget::getoption $path -values]] } {
- return
- }
- _create_popup $path
-
- ArrowButton::configure $path.a -dir top
- $listb selection clear 0 end
- set values [$listb get 0 end]
- set curval [Entry::cget $path.e -text]
- if { [set idx [lsearch $values $curval]] != -1 ||
- [set idx [lsearch $values "$curval*"]] != -1 } {
- $listb selection set $idx
- $listb activate $idx
- $listb see $idx
- } else {
- $listb activate 0
- $listb see 0
- }
-
- set frame [LabelFrame::getframe $path.labf]
- BWidget::place $path.shell [winfo width $frame] 0 below $frame
- wm deiconify $path.shell
- raise $path.shell
- BWidget::grab global $path
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ComboBox::_unmapliste
-# ------------------------------------------------------------------------------
-proc ComboBox::_unmapliste { path } {
- BWidget::grab release $path
- destroy $path.shell
- ArrowButton::configure $path.a -dir bottom
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ComboBox::_select
-# ------------------------------------------------------------------------------
-proc ComboBox::_select { path index } {
- set index [$path.shell.listb index $index]
- _unmapliste $path
- if { $index != -1 } {
- if { [setvalue $path @$index] } {
- if { [set cmd [Widget::getoption $path -modifycmd]] != "" } {
- uplevel \#0 $cmd
- }
- }
- }
- return -code break
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ComboBox::_modify_value
-# ------------------------------------------------------------------------------
-proc ComboBox::_modify_value { path direction } {
- if { [setvalue $path $direction] } {
- if { [set cmd [Widget::getoption $path -modifycmd]] != "" } {
- uplevel \#0 $cmd
- }
- }
-}
Copied: grass/trunk/lib/external/bwidget/combobox.tcl (from rev 35192, grass/trunk/lib/external/bwidget/combobox.tcl)
===================================================================
--- grass/trunk/lib/external/bwidget/combobox.tcl (rev 0)
+++ grass/trunk/lib/external/bwidget/combobox.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,340 @@
+# ------------------------------------------------------------------------------
+# combobox.tcl
+# This file is part of Unifix BWidget Toolkit
+# $Id$
+# ------------------------------------------------------------------------------
+# Index of commands:
+# - ComboBox::create
+# - ComboBox::configure
+# - ComboBox::cget
+# - ComboBox::setvalue
+# - ComboBox::getvalue
+# - ComboBox::_create_popup
+# - ComboBox::_mapliste
+# - ComboBox::_unmapliste
+# - ComboBox::_select
+# - ComboBox::_modify_value
+# ------------------------------------------------------------------------------
+
+namespace eval ComboBox {
+ ArrowButton::use
+ Entry::use
+ LabelFrame::use
+
+ Widget::bwinclude ComboBox LabelFrame .labf \
+ rename {-text -label} \
+ remove {-focus} \
+ prefix {label -justify -width -anchor -height -font} \
+ initialize {-relief sunken -borderwidth 2}
+
+ Widget::bwinclude ComboBox Entry .e \
+ remove {-relief -bd -borderwidth -bg -fg} \
+ rename {-foreground -entryfg -background -entrybg}
+
+ Widget::declare ComboBox {
+ {-height TkResource 0 0 listbox}
+ {-values String "" 0}
+ {-modifycmd String "" 0}
+ {-postcommand String "" 0}
+ }
+
+ Widget::addmap ComboBox "" :cmd {-background {}}
+ Widget::addmap ComboBox ArrowButton .a \
+ {-foreground {} -background {} -disabledforeground {} -state {}}
+
+ Widget::syncoptions ComboBox Entry .e {-text {}}
+ Widget::syncoptions ComboBox LabelFrame .labf {-label -text -underline {}}
+
+ ::bind BwComboBox <FocusIn> {focus %W.labf}
+ ::bind BwComboBox <Destroy> {Widget::destroy %W; rename %W {}}
+
+ proc ::ComboBox { path args } { return [eval ComboBox::create $path $args] }
+ proc use {} {}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ComboBox::create
+# ------------------------------------------------------------------------------
+proc ComboBox::create { path args } {
+ Widget::init ComboBox $path $args
+
+ frame $path -background [Widget::getoption $path -background] \
+ -highlightthickness 0 -bd 0 -relief flat -takefocus 0
+
+ bindtags $path [list $path BwComboBox [winfo toplevel $path] all]
+
+ set labf [eval LabelFrame::create $path.labf [Widget::subcget $path .labf] \
+ -focus $path.e]
+ set entry [eval Entry::create $path.e [Widget::subcget $path .e] \
+ -relief flat -borderwidth 0]
+
+ set width 11
+ set height [winfo reqheight $entry]
+ set arrow [eval ArrowButton::create $path.a [Widget::subcget $path .a] \
+ -width $width -height $height \
+ -highlightthickness 0 -borderwidth 1 -takefocus 0 \
+ -dir bottom \
+ -type button \
+ -command [list "ComboBox::_mapliste $path"]]
+
+ set frame [LabelFrame::getframe $labf]
+
+ pack $arrow -in $frame -side right -fill y
+ pack $entry -in $frame -side left -fill both -expand yes
+ pack $labf -fill x -expand yes
+
+ if { [Widget::getoption $path -editable] == 0 } {
+ ::bind $entry <ButtonPress-1> "ArrowButton::invoke $path.a"
+ } else {
+ ::bind $entry <ButtonPress-1> "ComboBox::_unmapliste $path"
+ }
+
+ ::bind $path <ButtonPress-1> "ComboBox::_unmapliste $path"
+ ::bind $entry <Key-Up> "ComboBox::_modify_value $path previous"
+ ::bind $entry <Key-Down> "ComboBox::_modify_value $path next"
+ ::bind $entry <Key-Prior> "ComboBox::_modify_value $path first"
+ ::bind $entry <Key-Next> "ComboBox::_modify_value $path last"
+
+ rename $path ::$path:cmd
+ proc ::$path { cmd args } "return \[eval ComboBox::\$cmd $path \$args\]"
+
+ return $path
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ComboBox::configure
+# ------------------------------------------------------------------------------
+proc ComboBox::configure { path args } {
+ set res [Widget::configure $path $args]
+
+ if { [Widget::hasChanged $path -values values] |
+ [Widget::hasChanged $path -height h] |
+ [Widget::hasChanged $path -font f] } {
+ destroy $path.shell.listb
+ }
+
+ if { [Widget::hasChanged $path -editable ed] } {
+ if { $ed } {
+ ::bind $path.e <ButtonPress-1> "ComboBox::_unmapliste $path"
+ } else {
+ ::bind $path.e <ButtonPress-1> "ArrowButton::invoke $path.a"
+ }
+ }
+
+ return $res
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ComboBox::cget
+# ------------------------------------------------------------------------------
+proc ComboBox::cget { path option } {
+ Widget::setoption $path -text [Entry::cget $path.e -text]
+ return [Widget::cget $path $option]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ComboBox::setvalue
+# ------------------------------------------------------------------------------
+proc ComboBox::setvalue { path index } {
+ set values [Widget::getoption $path -values]
+ set value [Entry::cget $path.e -text]
+ switch -- $index {
+ next {
+ if { [set idx [lsearch $values $value]] != -1 } {
+ incr idx
+ } else {
+ set idx [lsearch $values "$value*"]
+ }
+ }
+ previous {
+ if { [set idx [lsearch $values $value]] != -1 } {
+ incr idx -1
+ } else {
+ set idx [lsearch $values "$value*"]
+ }
+ }
+ first {
+ set idx 0
+ }
+ last {
+ set idx [expr {[llength $values]-1}]
+ }
+ default {
+ if { [string index $index 0] == "@" } {
+ set idx [string range $index 1 end]
+ if { [catch {string compare [expr {int($idx)}] $idx} res] || $res != 0 } {
+ return -code error "bad index \"$index\""
+ }
+ } else {
+ return -code error "bad index \"$index\""
+ }
+ }
+ }
+ if { $idx >= 0 && $idx < [llength $values] } {
+ set newval [lindex $values $idx]
+ Widget::setoption $path -text $newval
+ if { [set varname [Entry::cget $path.e -textvariable]] != "" } {
+ GlobalVar::setvar $varname $newval
+ } else {
+ Entry::configure $path.e -text $newval
+ }
+ return 1
+ }
+ return 0
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ComboBox::getvalue
+# ------------------------------------------------------------------------------
+proc ComboBox::getvalue { path } {
+ set values [Widget::getoption $path -values]
+ set value [Entry::cget $path.e -text]
+
+ return [lsearch $values $value]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ComboBox::bind
+# ------------------------------------------------------------------------------
+proc ComboBox::bind { path args } {
+ return [eval ::bind $path.e $args]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ComboBox::_create_popup
+# ------------------------------------------------------------------------------
+proc ComboBox::_create_popup { path } {
+ set shell [menu $path.shell -tearoff 0 -relief flat -bd 0]
+ wm overrideredirect $shell 1
+ wm withdraw $shell
+ wm transient $shell [winfo toplevel $path]
+ wm group $shell [winfo toplevel $path]
+ set lval [Widget::getoption $path -values]
+ set h [Widget::getoption $path -height]
+ set sb 0
+ if { $h <= 0 } {
+ set len [llength $lval]
+ if { $len < 3 } {
+ set h 3
+ } elseif { $len > 10 } {
+ set h 10
+ set sb 1
+ }
+ }
+ set frame [frame $shell.frame -relief sunken -bd 2]
+ set listb [listbox $shell.listb -relief flat -bd 0 -highlightthickness 0 \
+ -exportselection false \
+ -font [Widget::getoption $path -font] \
+ -height $h]
+
+ if { $sb } {
+ set scroll [scrollbar $shell.scroll \
+ -orient vertical \
+ -command "$shell.listb yview" \
+ -highlightthickness 0 -takefocus 0 -width 9]
+ $listb configure -yscrollcommand "$scroll set"
+ }
+ $listb delete 0 end
+ foreach val $lval {
+ $listb insert end $val
+ }
+
+ if { $sb } {
+ pack $scroll -in $frame -side right -fill y
+ }
+ pack $listb -in $frame -side left -fill both -expand yes
+ pack $frame -fill both -expand yes -padx 1 -padx 1
+
+ ::bind $listb <ButtonRelease-1> "ComboBox::_select $path @%x,%y"
+ ::bind $listb <Return> "ComboBox::_select $path active"
+ ::bind $listb <Escape> "ComboBox::_unmapliste $path"
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ComboBox::_mapliste
+# ------------------------------------------------------------------------------
+proc ComboBox::_mapliste { path } {
+ set listb $path.shell.listb
+ if { [winfo exists $path.shell] } {
+ _unmapliste $path
+ return
+ }
+
+ if { [Widget::getoption $path -state] == "disabled" } {
+ return
+ }
+ if { [set cmd [Widget::getoption $path -postcommand]] != "" } {
+ uplevel \#0 $cmd
+ }
+ if { ![llength [Widget::getoption $path -values]] } {
+ return
+ }
+ _create_popup $path
+
+ ArrowButton::configure $path.a -dir top
+ $listb selection clear 0 end
+ set values [$listb get 0 end]
+ set curval [Entry::cget $path.e -text]
+ if { [set idx [lsearch $values $curval]] != -1 ||
+ [set idx [lsearch $values "$curval*"]] != -1 } {
+ $listb selection set $idx
+ $listb activate $idx
+ $listb see $idx
+ } else {
+ $listb activate 0
+ $listb see 0
+ }
+
+ set frame [LabelFrame::getframe $path.labf]
+ BWidget::place $path.shell [winfo width $frame] 0 below $frame
+ wm deiconify $path.shell
+ raise $path.shell
+ BWidget::grab global $path
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ComboBox::_unmapliste
+# ------------------------------------------------------------------------------
+proc ComboBox::_unmapliste { path } {
+ BWidget::grab release $path
+ destroy $path.shell
+ ArrowButton::configure $path.a -dir bottom
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ComboBox::_select
+# ------------------------------------------------------------------------------
+proc ComboBox::_select { path index } {
+ set index [$path.shell.listb index $index]
+ _unmapliste $path
+ if { $index != -1 } {
+ if { [setvalue $path @$index] } {
+ if { [set cmd [Widget::getoption $path -modifycmd]] != "" } {
+ uplevel \#0 $cmd
+ }
+ }
+ }
+ return -code break
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ComboBox::_modify_value
+# ------------------------------------------------------------------------------
+proc ComboBox::_modify_value { path direction } {
+ if { [setvalue $path $direction] } {
+ if { [set cmd [Widget::getoption $path -modifycmd]] != "" } {
+ uplevel \#0 $cmd
+ }
+ }
+}
Deleted: grass/trunk/lib/external/bwidget/dialog.tcl
===================================================================
--- grass/trunk/lib/external/bwidget/dialog.tcl 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/dialog.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,290 +0,0 @@
-# ------------------------------------------------------------------------------
-# dialog.tcl
-# This file is part of Unifix BWidget Toolkit
-# $Id$
-# ------------------------------------------------------------------------------
-# Index of commands:
-# - Dialog::create
-# - Dialog::configure
-# - Dialog::cget
-# - Dialog::getframe
-# - Dialog::add
-# - Dialog::itemconfigure
-# - Dialog::itemcget
-# - Dialog::invoke
-# - Dialog::setfocus
-# - Dialog::enddialog
-# - Dialog::draw
-# - Dialog::withdraw
-# - Dialog::_destroy
-# ------------------------------------------------------------------------------
-
-namespace eval Dialog {
- ButtonBox::use
-
- Widget::bwinclude Dialog ButtonBox .bbox \
- remove {-orient} \
- initialize {-spacing 10 -padx 10}
-
- Widget::declare Dialog {
- {-title String "" 0}
- {-modal Enum local 0 {none local global}}
- {-bitmap TkResource "" 1 label}
- {-image TkResource "" 1 label}
- {-separator Boolean 0 1}
- {-cancel Int -1 0 {=-1 ""}}
- {-parent String "" 0}
- {-side Enum bottom 1 {bottom left top right}}
- {-anchor Enum c 1 {n e w s c}}
- }
-
- Widget::addmap Dialog "" :cmd {-background {}}
- Widget::addmap Dialog "" .frame {-background {}}
-
- proc ::Dialog { path args } { return [eval Dialog::create $path $args] }
- proc use {} {}
-
- bind BwDialog <Destroy> {Dialog::enddialog %W -1; Dialog::_destroy %W}
-
- variable _widget
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Dialog::create
-# ------------------------------------------------------------------------------
-proc Dialog::create { path args } {
- global tcl_platform
- variable _widget
-
- Widget::init Dialog $path $args
- set bg [Widget::getoption $path -background]
- if { ![string compare $tcl_platform(platform) "unix"] } {
- toplevel $path -relief raised -borderwidth 1 -background $bg
- } else {
- toplevel $path -relief flat -borderwidth 0 -background $bg
- }
- bindtags $path [list $path BwDialog all]
- wm overrideredirect $path 1
- wm title $path [Widget::getoption $path -title]
- set parent [Widget::getoption $path -parent]
- if { ![winfo exists $parent] } {
- set parent [winfo parent $path]
- }
- wm transient $path [winfo toplevel $parent]
- wm withdraw $path
-
- set side [Widget::getoption $path -side]
- if { ![string compare $side "left"] || ![string compare $side "right"] } {
- set orient vertical
- } else {
- set orient horizontal
- }
-
- set bbox [eval ButtonBox::create $path.bbox [Widget::subcget $path .bbox] \
- -orient $orient]
- set frame [frame $path.frame -relief flat -borderwidth 0 -background $bg]
-
- if { [set bitmap [Widget::getoption $path -image]] != "" } {
- set label [label $path.label -image $bitmap -background $bg]
- } elseif { [set bitmap [Widget::getoption $path -bitmap]] != "" } {
- set label [label $path.label -bitmap $bitmap -background $bg]
- }
- if { [Widget::getoption $path -separator] } {
- Separator::create $path.sep -orient $orient -background $bg
- }
- set _widget($path,realized) 0
- set _widget($path,nbut) 0
-
- bind $path <Escape> "ButtonBox::invoke $path.bbox [Widget::getoption $path -cancel]"
- bind $path <Return> "ButtonBox::invoke $path.bbox default"
-
- rename $path ::$path:cmd
- proc ::$path { cmd args } "return \[eval Dialog::\$cmd $path \$args\]"
-
- return $path
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Dialog::configure
-# ------------------------------------------------------------------------------
-proc Dialog::configure { path args } {
- set res [Widget::configure $path $args]
-
- if { [Widget::hasChanged $path -title title] } {
- wm title $path $title
- }
- if { [Widget::hasChanged $path -background bg] } {
- if { [winfo exists $path.label] } {
- $path.label configure -background $bg
- }
- if { [winfo exists $path.sep] } {
- Separator::configure $path.sep -background $bg
- }
- }
- return $res
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Dialog::cget
-# ------------------------------------------------------------------------------
-proc Dialog::cget { path option } {
- return [Widget::cget $path $option]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Dialog::getframe
-# ------------------------------------------------------------------------------
-proc Dialog::getframe { path } {
- return $path.frame
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Dialog::add
-# ------------------------------------------------------------------------------
-proc Dialog::add { path args } {
- variable _widget
-
- set res [eval ButtonBox::add $path.bbox \
- -command [list "Dialog::enddialog $path $_widget($path,nbut)"] $args]
- incr _widget($path,nbut)
- return $res
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Dialog::itemconfigure
-# ------------------------------------------------------------------------------
-proc Dialog::itemconfigure { path index args } {
- return [eval ButtonBox::itemconfigure $path.bbox $index $args]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Dialog::itemcget
-# ------------------------------------------------------------------------------
-proc Dialog::itemcget { path index option } {
- return [ButtonBox::itemcget $path.bbox $index $option]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Dialog::invoke
-# ------------------------------------------------------------------------------
-proc Dialog::invoke { path index } {
- ButtonBox::invoke $path.bbox $index
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Dialog::setfocus
-# ------------------------------------------------------------------------------
-proc Dialog::setfocus { path index } {
- ButtonBox::setfocus $path.bbox $index
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Dialog::enddialog
-# ------------------------------------------------------------------------------
-proc Dialog::enddialog { path result } {
- variable _widget
-
- set _widget($path,result) $result
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Dialog::draw
-# ------------------------------------------------------------------------------
-proc Dialog::draw { path {focus ""}} {
- variable _widget
-
- set parent [Widget::getoption $path -parent]
- if { !$_widget($path,realized) } {
- set _widget($path,realized) 1
- if { [llength [winfo children $path.bbox]] } {
- set side [Widget::getoption $path -side]
- if { ![string compare $side "left"] || ![string compare $side "right"] } {
- set pad -padx
- set fill y
- } else {
- set pad -pady
- set fill x
- }
- pack $path.bbox -side $side -anchor [Widget::getoption $path -anchor] -padx 1m -pady 1m
- if { [winfo exists $path.sep] } {
- pack $path.sep -side $side -fill $fill $pad 2m
- }
- }
- if { [winfo exists $path.label] } {
- pack $path.label -side left -anchor n -padx 3m -pady 3m
- }
- pack $path.frame -padx 1m -pady 1m -fill both -expand yes
- }
-
- if { [winfo exists $parent] } {
- BWidget::place $path 0 0 center $parent
- } else {
- BWidget::place $path 0 0 center
- }
- update idletasks
- wm overrideredirect $path 0
- wm deiconify $path
-
- tkwait visibility $path
- BWidget::focus set $path
- if { [winfo exists $focus] } {
- focus -force $focus
- } else {
- ButtonBox::setfocus $path.bbox default
- }
-
- if { [set grab [Widget::getoption $path -modal]] != "none" } {
- BWidget::grab $grab $path
- catch {unset _widget($path,result)}
- tkwait variable Dialog::_widget($path,result)
- if { [info exists _widget($path,result)] } {
- set res $_widget($path,result)
- unset _widget($path,result)
- } else {
- set res -1
- }
- withdraw $path
- return $res
- }
- return ""
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Dialog::withdraw
-# ------------------------------------------------------------------------------
-proc Dialog::withdraw { path } {
- BWidget::grab release $path
- BWidget::focus release $path
- if { [winfo exists $path] } {
- wm withdraw $path
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Dialog::_destroy
-# ------------------------------------------------------------------------------
-proc Dialog::_destroy { path } {
- variable _widget
-
- BWidget::grab release $path
- BWidget::focus release $path
- catch {unset _widget($path,result)}
- unset _widget($path,realized)
- unset _widget($path,nbut)
-
- Widget::destroy $path
- rename $path {}
-}
Copied: grass/trunk/lib/external/bwidget/dialog.tcl (from rev 35192, grass/trunk/lib/external/bwidget/dialog.tcl)
===================================================================
--- grass/trunk/lib/external/bwidget/dialog.tcl (rev 0)
+++ grass/trunk/lib/external/bwidget/dialog.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,290 @@
+# ------------------------------------------------------------------------------
+# dialog.tcl
+# This file is part of Unifix BWidget Toolkit
+# $Id$
+# ------------------------------------------------------------------------------
+# Index of commands:
+# - Dialog::create
+# - Dialog::configure
+# - Dialog::cget
+# - Dialog::getframe
+# - Dialog::add
+# - Dialog::itemconfigure
+# - Dialog::itemcget
+# - Dialog::invoke
+# - Dialog::setfocus
+# - Dialog::enddialog
+# - Dialog::draw
+# - Dialog::withdraw
+# - Dialog::_destroy
+# ------------------------------------------------------------------------------
+
+namespace eval Dialog {
+ ButtonBox::use
+
+ Widget::bwinclude Dialog ButtonBox .bbox \
+ remove {-orient} \
+ initialize {-spacing 10 -padx 10}
+
+ Widget::declare Dialog {
+ {-title String "" 0}
+ {-modal Enum local 0 {none local global}}
+ {-bitmap TkResource "" 1 label}
+ {-image TkResource "" 1 label}
+ {-separator Boolean 0 1}
+ {-cancel Int -1 0 {=-1 ""}}
+ {-parent String "" 0}
+ {-side Enum bottom 1 {bottom left top right}}
+ {-anchor Enum c 1 {n e w s c}}
+ }
+
+ Widget::addmap Dialog "" :cmd {-background {}}
+ Widget::addmap Dialog "" .frame {-background {}}
+
+ proc ::Dialog { path args } { return [eval Dialog::create $path $args] }
+ proc use {} {}
+
+ bind BwDialog <Destroy> {Dialog::enddialog %W -1; Dialog::_destroy %W}
+
+ variable _widget
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Dialog::create
+# ------------------------------------------------------------------------------
+proc Dialog::create { path args } {
+ global tcl_platform
+ variable _widget
+
+ Widget::init Dialog $path $args
+ set bg [Widget::getoption $path -background]
+ if { ![string compare $tcl_platform(platform) "unix"] } {
+ toplevel $path -relief raised -borderwidth 1 -background $bg
+ } else {
+ toplevel $path -relief flat -borderwidth 0 -background $bg
+ }
+ bindtags $path [list $path BwDialog all]
+ wm overrideredirect $path 1
+ wm title $path [Widget::getoption $path -title]
+ set parent [Widget::getoption $path -parent]
+ if { ![winfo exists $parent] } {
+ set parent [winfo parent $path]
+ }
+ wm transient $path [winfo toplevel $parent]
+ wm withdraw $path
+
+ set side [Widget::getoption $path -side]
+ if { ![string compare $side "left"] || ![string compare $side "right"] } {
+ set orient vertical
+ } else {
+ set orient horizontal
+ }
+
+ set bbox [eval ButtonBox::create $path.bbox [Widget::subcget $path .bbox] \
+ -orient $orient]
+ set frame [frame $path.frame -relief flat -borderwidth 0 -background $bg]
+
+ if { [set bitmap [Widget::getoption $path -image]] != "" } {
+ set label [label $path.label -image $bitmap -background $bg]
+ } elseif { [set bitmap [Widget::getoption $path -bitmap]] != "" } {
+ set label [label $path.label -bitmap $bitmap -background $bg]
+ }
+ if { [Widget::getoption $path -separator] } {
+ Separator::create $path.sep -orient $orient -background $bg
+ }
+ set _widget($path,realized) 0
+ set _widget($path,nbut) 0
+
+ bind $path <Escape> "ButtonBox::invoke $path.bbox [Widget::getoption $path -cancel]"
+ bind $path <Return> "ButtonBox::invoke $path.bbox default"
+
+ rename $path ::$path:cmd
+ proc ::$path { cmd args } "return \[eval Dialog::\$cmd $path \$args\]"
+
+ return $path
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Dialog::configure
+# ------------------------------------------------------------------------------
+proc Dialog::configure { path args } {
+ set res [Widget::configure $path $args]
+
+ if { [Widget::hasChanged $path -title title] } {
+ wm title $path $title
+ }
+ if { [Widget::hasChanged $path -background bg] } {
+ if { [winfo exists $path.label] } {
+ $path.label configure -background $bg
+ }
+ if { [winfo exists $path.sep] } {
+ Separator::configure $path.sep -background $bg
+ }
+ }
+ return $res
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Dialog::cget
+# ------------------------------------------------------------------------------
+proc Dialog::cget { path option } {
+ return [Widget::cget $path $option]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Dialog::getframe
+# ------------------------------------------------------------------------------
+proc Dialog::getframe { path } {
+ return $path.frame
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Dialog::add
+# ------------------------------------------------------------------------------
+proc Dialog::add { path args } {
+ variable _widget
+
+ set res [eval ButtonBox::add $path.bbox \
+ -command [list "Dialog::enddialog $path $_widget($path,nbut)"] $args]
+ incr _widget($path,nbut)
+ return $res
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Dialog::itemconfigure
+# ------------------------------------------------------------------------------
+proc Dialog::itemconfigure { path index args } {
+ return [eval ButtonBox::itemconfigure $path.bbox $index $args]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Dialog::itemcget
+# ------------------------------------------------------------------------------
+proc Dialog::itemcget { path index option } {
+ return [ButtonBox::itemcget $path.bbox $index $option]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Dialog::invoke
+# ------------------------------------------------------------------------------
+proc Dialog::invoke { path index } {
+ ButtonBox::invoke $path.bbox $index
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Dialog::setfocus
+# ------------------------------------------------------------------------------
+proc Dialog::setfocus { path index } {
+ ButtonBox::setfocus $path.bbox $index
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Dialog::enddialog
+# ------------------------------------------------------------------------------
+proc Dialog::enddialog { path result } {
+ variable _widget
+
+ set _widget($path,result) $result
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Dialog::draw
+# ------------------------------------------------------------------------------
+proc Dialog::draw { path {focus ""}} {
+ variable _widget
+
+ set parent [Widget::getoption $path -parent]
+ if { !$_widget($path,realized) } {
+ set _widget($path,realized) 1
+ if { [llength [winfo children $path.bbox]] } {
+ set side [Widget::getoption $path -side]
+ if { ![string compare $side "left"] || ![string compare $side "right"] } {
+ set pad -padx
+ set fill y
+ } else {
+ set pad -pady
+ set fill x
+ }
+ pack $path.bbox -side $side -anchor [Widget::getoption $path -anchor] -padx 1m -pady 1m
+ if { [winfo exists $path.sep] } {
+ pack $path.sep -side $side -fill $fill $pad 2m
+ }
+ }
+ if { [winfo exists $path.label] } {
+ pack $path.label -side left -anchor n -padx 3m -pady 3m
+ }
+ pack $path.frame -padx 1m -pady 1m -fill both -expand yes
+ }
+
+ if { [winfo exists $parent] } {
+ BWidget::place $path 0 0 center $parent
+ } else {
+ BWidget::place $path 0 0 center
+ }
+ update idletasks
+ wm overrideredirect $path 0
+ wm deiconify $path
+
+ tkwait visibility $path
+ BWidget::focus set $path
+ if { [winfo exists $focus] } {
+ focus -force $focus
+ } else {
+ ButtonBox::setfocus $path.bbox default
+ }
+
+ if { [set grab [Widget::getoption $path -modal]] != "none" } {
+ BWidget::grab $grab $path
+ catch {unset _widget($path,result)}
+ tkwait variable Dialog::_widget($path,result)
+ if { [info exists _widget($path,result)] } {
+ set res $_widget($path,result)
+ unset _widget($path,result)
+ } else {
+ set res -1
+ }
+ withdraw $path
+ return $res
+ }
+ return ""
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Dialog::withdraw
+# ------------------------------------------------------------------------------
+proc Dialog::withdraw { path } {
+ BWidget::grab release $path
+ BWidget::focus release $path
+ if { [winfo exists $path] } {
+ wm withdraw $path
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Dialog::_destroy
+# ------------------------------------------------------------------------------
+proc Dialog::_destroy { path } {
+ variable _widget
+
+ BWidget::grab release $path
+ BWidget::focus release $path
+ catch {unset _widget($path,result)}
+ unset _widget($path,realized)
+ unset _widget($path,nbut)
+
+ Widget::destroy $path
+ rename $path {}
+}
Deleted: grass/trunk/lib/external/bwidget/dragsite.tcl
===================================================================
--- grass/trunk/lib/external/bwidget/dragsite.tcl 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/dragsite.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,190 +0,0 @@
-# ------------------------------------------------------------------------------
-# dragsite.tcl
-# This file is part of Unifix BWidget Toolkit
-# $Id$
-# ------------------------------------------------------------------------------
-# Index of commands:
-# - DragSite::include
-# - DragSite::setdrag
-# - DragSite::register
-# - DragSite::_begin_drag
-# - DragSite::_init_drag
-# - DragSite::_end_drag
-# - DragSite::_update_operation
-# ------------------------------------------------------------------------------
-
-namespace eval DragSite {
- Widget::declare DragSite {
- {-dragevent Enum 1 0 {1 2 3}}
- {-draginitcmd String "" 0}
- {-dragendcmd String "" 0}
- }
-
- variable _topw ".drag"
- variable _tabops
- variable _state
- variable _x0
- variable _y0
-
- bind BwDrag1 <ButtonPress-1> {DragSite::_begin_drag press %W %s %X %Y}
- bind BwDrag1 <B1-Motion> {DragSite::_begin_drag motion %W %s %X %Y}
- bind BwDrag2 <ButtonPress-2> {DragSite::_begin_drag press %W %s %X %Y}
- bind BwDrag2 <B2-Motion> {DragSite::_begin_drag motion %W %s %X %Y}
- bind BwDrag3 <ButtonPress-3> {DragSite::_begin_drag press %W %s %X %Y}
- bind BwDrag3 <B3-Motion> {DragSite::_begin_drag motion %W %s %X %Y}
-
- proc use {} {}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command DragSite::include
-# ------------------------------------------------------------------------------
-proc DragSite::include { class type event } {
- set dragoptions {
- {-dragenabled Boolean 0 0}
- {-draginitcmd String "" 0}
- {-dragendcmd String "" 0}
- }
- lappend dragoptions \
- [list -dragtype String $type 0] \
- [list -dragevent Enum $event 0 {1 2 3}]
- Widget::declare $class $dragoptions
-}
-
-
-# ------------------------------------------------------------------------------
-# Command DragSite::setdrag
-# Widget interface to register
-# ------------------------------------------------------------------------------
-proc DragSite::setdrag { path subpath initcmd endcmd {force 0}} {
- set cen [Widget::hasChanged $path -dragenabled en]
- set cdragevt [Widget::hasChanged $path -dragevent dragevt]
- if { $en } {
- if { $force || $cen || $cdragevt } {
- register $subpath \
- -draginitcmd $initcmd \
- -dragendcmd $endcmd \
- -dragevent $dragevt
- }
- } else {
- register $subpath
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command DragSite::register
-# ------------------------------------------------------------------------------
-proc DragSite::register { path args } {
- upvar \#0 DragSite::$path drag
-
- if { [info exists drag] } {
- bind $path $drag(evt) {}
- unset drag
- }
- Widget::init DragSite .drag$path $args
- set event [Widget::getoption .drag$path -dragevent]
- set initcmd [Widget::getoption .drag$path -draginitcmd]
- set endcmd [Widget::getoption .drag$path -dragendcmd]
- set tags [bindtags $path]
- set idx [lsearch $tags "BwDrag*"]
- Widget::destroy .drag$path
- if { $initcmd != "" } {
- if { $idx != -1 } {
- bindtags $path [lreplace $tags $idx $idx BwDrag$event]
- } else {
- bindtags $path [concat $tags BwDrag$event]
- }
- set drag(initcmd) $initcmd
- set drag(endcmd) $endcmd
- set drag(evt) $event
- } elseif { $idx != -1 } {
- bindtags $path [lreplace $tags $idx $idx]
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command DragSite::_begin_drag
-# ------------------------------------------------------------------------------
-proc DragSite::_begin_drag { event source state X Y } {
- variable _x0
- variable _y0
- variable _state
-
- switch -- $event {
- press {
- set _x0 $X
- set _y0 $Y
- set _state "press"
- }
- motion {
- catch { if { ![string compare $_state "press"] } {
- if { abs($_x0-$X) > 3 || abs($_y0-$Y) > 3 } {
- set _state "done"
- _init_drag $source $state $X $Y
- }
- }
- }
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command DragSite::_init_drag
-# ------------------------------------------------------------------------------
-proc DragSite::_init_drag { source state X Y } {
- variable _topw
- upvar \#0 DragSite::$source drag
-
- destroy $_topw
- toplevel $_topw
- wm withdraw $_topw
- wm overrideredirect $_topw 1
-
- set info [uplevel \#0 $drag(initcmd) [list $source $X $Y .drag]]
- if { $info != "" } {
- set type [lindex $info 0]
- set ops [lindex $info 1]
- set data [lindex $info 2]
-
- if { [winfo children $_topw] == "" } {
- if { ![string compare $type "BITMAP"] || ![string compare $type "IMAGE"] } {
- label $_topw.l -image [Bitmap::get dragicon] -relief flat -bd 0
- } else {
- label $_topw.l -image [Bitmap::get dragfile] -relief flat -bd 0
- }
- pack $_topw.l
- }
- wm geometry $_topw +[expr $X+1]+[expr $Y+1]
- wm deiconify $_topw
- tkwait visibility $_topw
- BWidget::grab set $_topw
- BWidget::focus set $_topw
-
- bindtags $_topw [list $_topw DragTop]
- DropSite::_init_drag $_topw $drag(evt) $source $state $X $Y $type $ops $data
- } else {
- destroy $_topw
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command DragSite::_end_drag
-# ------------------------------------------------------------------------------
-proc DragSite::_end_drag { source target op type data result } {
- variable _topw
- upvar \#0 DragSite::$source drag
-
- BWidget::grab release $_topw
- BWidget::focus release $_topw
- destroy $_topw
- if { $drag(endcmd) != "" } {
- uplevel \#0 $drag(endcmd) [list $source $target $op $type $data $result]
- }
-}
-
-
Copied: grass/trunk/lib/external/bwidget/dragsite.tcl (from rev 35192, grass/trunk/lib/external/bwidget/dragsite.tcl)
===================================================================
--- grass/trunk/lib/external/bwidget/dragsite.tcl (rev 0)
+++ grass/trunk/lib/external/bwidget/dragsite.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,190 @@
+# ------------------------------------------------------------------------------
+# dragsite.tcl
+# This file is part of Unifix BWidget Toolkit
+# $Id$
+# ------------------------------------------------------------------------------
+# Index of commands:
+# - DragSite::include
+# - DragSite::setdrag
+# - DragSite::register
+# - DragSite::_begin_drag
+# - DragSite::_init_drag
+# - DragSite::_end_drag
+# - DragSite::_update_operation
+# ------------------------------------------------------------------------------
+
+namespace eval DragSite {
+ Widget::declare DragSite {
+ {-dragevent Enum 1 0 {1 2 3}}
+ {-draginitcmd String "" 0}
+ {-dragendcmd String "" 0}
+ }
+
+ variable _topw ".drag"
+ variable _tabops
+ variable _state
+ variable _x0
+ variable _y0
+
+ bind BwDrag1 <ButtonPress-1> {DragSite::_begin_drag press %W %s %X %Y}
+ bind BwDrag1 <B1-Motion> {DragSite::_begin_drag motion %W %s %X %Y}
+ bind BwDrag2 <ButtonPress-2> {DragSite::_begin_drag press %W %s %X %Y}
+ bind BwDrag2 <B2-Motion> {DragSite::_begin_drag motion %W %s %X %Y}
+ bind BwDrag3 <ButtonPress-3> {DragSite::_begin_drag press %W %s %X %Y}
+ bind BwDrag3 <B3-Motion> {DragSite::_begin_drag motion %W %s %X %Y}
+
+ proc use {} {}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command DragSite::include
+# ------------------------------------------------------------------------------
+proc DragSite::include { class type event } {
+ set dragoptions {
+ {-dragenabled Boolean 0 0}
+ {-draginitcmd String "" 0}
+ {-dragendcmd String "" 0}
+ }
+ lappend dragoptions \
+ [list -dragtype String $type 0] \
+ [list -dragevent Enum $event 0 {1 2 3}]
+ Widget::declare $class $dragoptions
+}
+
+
+# ------------------------------------------------------------------------------
+# Command DragSite::setdrag
+# Widget interface to register
+# ------------------------------------------------------------------------------
+proc DragSite::setdrag { path subpath initcmd endcmd {force 0}} {
+ set cen [Widget::hasChanged $path -dragenabled en]
+ set cdragevt [Widget::hasChanged $path -dragevent dragevt]
+ if { $en } {
+ if { $force || $cen || $cdragevt } {
+ register $subpath \
+ -draginitcmd $initcmd \
+ -dragendcmd $endcmd \
+ -dragevent $dragevt
+ }
+ } else {
+ register $subpath
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command DragSite::register
+# ------------------------------------------------------------------------------
+proc DragSite::register { path args } {
+ upvar \#0 DragSite::$path drag
+
+ if { [info exists drag] } {
+ bind $path $drag(evt) {}
+ unset drag
+ }
+ Widget::init DragSite .drag$path $args
+ set event [Widget::getoption .drag$path -dragevent]
+ set initcmd [Widget::getoption .drag$path -draginitcmd]
+ set endcmd [Widget::getoption .drag$path -dragendcmd]
+ set tags [bindtags $path]
+ set idx [lsearch $tags "BwDrag*"]
+ Widget::destroy .drag$path
+ if { $initcmd != "" } {
+ if { $idx != -1 } {
+ bindtags $path [lreplace $tags $idx $idx BwDrag$event]
+ } else {
+ bindtags $path [concat $tags BwDrag$event]
+ }
+ set drag(initcmd) $initcmd
+ set drag(endcmd) $endcmd
+ set drag(evt) $event
+ } elseif { $idx != -1 } {
+ bindtags $path [lreplace $tags $idx $idx]
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command DragSite::_begin_drag
+# ------------------------------------------------------------------------------
+proc DragSite::_begin_drag { event source state X Y } {
+ variable _x0
+ variable _y0
+ variable _state
+
+ switch -- $event {
+ press {
+ set _x0 $X
+ set _y0 $Y
+ set _state "press"
+ }
+ motion {
+ catch { if { ![string compare $_state "press"] } {
+ if { abs($_x0-$X) > 3 || abs($_y0-$Y) > 3 } {
+ set _state "done"
+ _init_drag $source $state $X $Y
+ }
+ }
+ }
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command DragSite::_init_drag
+# ------------------------------------------------------------------------------
+proc DragSite::_init_drag { source state X Y } {
+ variable _topw
+ upvar \#0 DragSite::$source drag
+
+ destroy $_topw
+ toplevel $_topw
+ wm withdraw $_topw
+ wm overrideredirect $_topw 1
+
+ set info [uplevel \#0 $drag(initcmd) [list $source $X $Y .drag]]
+ if { $info != "" } {
+ set type [lindex $info 0]
+ set ops [lindex $info 1]
+ set data [lindex $info 2]
+
+ if { [winfo children $_topw] == "" } {
+ if { ![string compare $type "BITMAP"] || ![string compare $type "IMAGE"] } {
+ label $_topw.l -image [Bitmap::get dragicon] -relief flat -bd 0
+ } else {
+ label $_topw.l -image [Bitmap::get dragfile] -relief flat -bd 0
+ }
+ pack $_topw.l
+ }
+ wm geometry $_topw +[expr $X+1]+[expr $Y+1]
+ wm deiconify $_topw
+ tkwait visibility $_topw
+ BWidget::grab set $_topw
+ BWidget::focus set $_topw
+
+ bindtags $_topw [list $_topw DragTop]
+ DropSite::_init_drag $_topw $drag(evt) $source $state $X $Y $type $ops $data
+ } else {
+ destroy $_topw
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command DragSite::_end_drag
+# ------------------------------------------------------------------------------
+proc DragSite::_end_drag { source target op type data result } {
+ variable _topw
+ upvar \#0 DragSite::$source drag
+
+ BWidget::grab release $_topw
+ BWidget::focus release $_topw
+ destroy $_topw
+ if { $drag(endcmd) != "" } {
+ uplevel \#0 $drag(endcmd) [list $source $target $op $type $data $result]
+ }
+}
+
+
Deleted: grass/trunk/lib/external/bwidget/dropsite.tcl
===================================================================
--- grass/trunk/lib/external/bwidget/dropsite.tcl 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/dropsite.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,451 +0,0 @@
-# ------------------------------------------------------------------------------
-# dropsite.tcl
-# This file is part of Unifix BWidget Toolkit
-# $Id$
-# ------------------------------------------------------------------------------
-# Index of commands:
-# - DropSite::include
-# - DropSite::setdrop
-# - DropSite::register
-# - DropSite::setcursor
-# - DropSite::setoperation
-# - DropSite::_update_operation
-# - DropSite::_compute_operation
-# - DropSite::_draw_operation
-# - DropSite::_init_drag
-# - DropSite::_motion
-# - DropSite::_release
-# ------------------------------------------------------------------------------
-
-
-namespace eval DropSite {
- Widget::declare DropSite {
- {-dropovercmd String "" 0}
- {-dropcmd String "" 0}
- {-droptypes String "" 0}
- }
-
- proc use { } {}
-
- variable _top ".drag"
- variable _opw ".drag.\#op"
- variable _target ""
- variable _status 0
- variable _tabops
- variable _defops
- variable _source
- variable _type
- variable _data
- variable _evt
- # key win unix
- # shift 1 | 1 -> 1
- # control 4 | 4 -> 4
- # alt 8 | 16 -> 24
- # meta | 64 -> 88
-
- array set _tabops {
- mod,none 0
- mod,shift 1
- mod,control 4
- mod,alt 24
- ops,copy 1
- ops,move 1
- ops,link 1
- }
-
- if { $tcl_platform(platform) == "unix" } {
- set _tabops(mod,alt) 8
- } else {
- set _tabops(mod,alt) 16
- }
- array set _defops \
- [list \
- copy,mod shift \
- move,mod control \
- link,mod alt \
- copy,img @[file join $env(BWIDGET_LIBRARY) "images" "opcopy.xbm"] \
- move,img @[file join $env(BWIDGET_LIBRARY) "images" "opmove.xbm"] \
- link,img @[file join $env(BWIDGET_LIBRARY) "images" "oplink.xbm"]]
-
- bind DragTop <KeyPress-Shift_L> {DropSite::_update_operation [expr %s | 1]}
- bind DragTop <KeyPress-Shift_R> {DropSite::_update_operation [expr %s | 1]}
- bind DragTop <KeyPress-Control_L> {DropSite::_update_operation [expr %s | 4]}
- bind DragTop <KeyPress-Control_R> {DropSite::_update_operation [expr %s | 4]}
- if { $tcl_platform(platform) == "unix" } {
- bind DragTop <KeyPress-Alt_L> {DropSite::_update_operation [expr %s | 8]}
- bind DragTop <KeyPress-Alt_R> {DropSite::_update_operation [expr %s | 8]}
- } else {
- bind DragTop <KeyPress-Alt_L> {DropSite::_update_operation [expr %s | 16]}
- bind DragTop <KeyPress-Alt_R> {DropSite::_update_operation [expr %s | 16]}
- }
-
- bind DragTop <KeyRelease-Shift_L> {DropSite::_update_operation [expr %s & ~1]}
- bind DragTop <KeyRelease-Shift_R> {DropSite::_update_operation [expr %s & ~1]}
- bind DragTop <KeyRelease-Control_L> {DropSite::_update_operation [expr %s & ~4]}
- bind DragTop <KeyRelease-Control_R> {DropSite::_update_operation [expr %s & ~4]}
- if { $tcl_platform(platform) == "unix" } {
- bind DragTop <KeyRelease-Alt_L> {DropSite::_update_operation [expr %s & ~8]}
- bind DragTop <KeyRelease-Alt_R> {DropSite::_update_operation [expr %s & ~8]}
- } else {
- bind DragTop <KeyRelease-Alt_L> {DropSite::_update_operation [expr %s & ~16]}
- bind DragTop <KeyRelease-Alt_R> {DropSite::_update_operation [expr %s & ~16]}
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command DropSite::include
-# ------------------------------------------------------------------------------
-proc DropSite::include { class types } {
- set dropoptions {
- {-dropenabled Boolean 0 0}
- {-dropovercmd String "" 0}
- {-dropcmd String "" 0}
- }
- lappend dropoptions [list -droptypes String $types 0]
- Widget::declare $class $dropoptions
-}
-
-
-# ------------------------------------------------------------------------------
-# Command DropSite::setdrop
-# Widget interface to register
-# ------------------------------------------------------------------------------
-proc DropSite::setdrop { path subpath dropover drop {force 0}} {
- set cen [Widget::hasChanged $path -dropenabled en]
- set ctypes [Widget::hasChanged $path -droptypes types]
- if { $en } {
- if { $force || $cen || $ctypes } {
- register $subpath \
- -droptypes $types \
- -dropcmd $drop \
- -dropovercmd $dropover
- }
- } else {
- register $subpath
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command DropSite::register
-# ------------------------------------------------------------------------------
-proc DropSite::register { path args } {
- variable _tabops
- variable _defops
- upvar \#0 DropSite::$path drop
-
- Widget::init DropSite .drop$path $args
- if { [info exists drop] } {
- unset drop
- }
- set dropcmd [Widget::getoption .drop$path -dropcmd]
- set types [Widget::getoption .drop$path -droptypes]
- set overcmd [Widget::getoption .drop$path -dropovercmd]
- Widget::destroy .drop$path
- if { $dropcmd != "" && $types != "" } {
- set drop(dropcmd) $dropcmd
- set drop(overcmd) $overcmd
- foreach {type ops} $types {
- set drop($type,ops) {}
- foreach {descop lmod} $ops {
- if { ![llength $descop] || [llength $descop] > 3 } {
- return -code error "invalid operation description \"$descop\""
- }
- foreach {subop baseop imgop} $descop {
- set subop [string trim $subop]
- if { ![string length $subop] } {
- return -code error "sub operation is empty"
- }
- if { ![string length $baseop] } {
- set baseop $subop
- }
- if { [info exists drop($type,ops,$subop)] } {
- return -code error "operation \"$subop\" already defined"
- }
- if { ![info exists _tabops(ops,$baseop)] } {
- return -code error "invalid base operation \"$baseop\""
- }
- if { [string compare $subop $baseop] &&
- [info exists _tabops(ops,$subop)] } {
- return -code error "sub operation \"$subop\" is a base operation"
- }
- if { ![string length $imgop] } {
- set imgop $_defops($baseop,img)
- }
- }
- if { ![string compare $lmod "program"] } {
- set drop($type,ops,$subop) $baseop
- set drop($type,img,$subop) $imgop
- } else {
- if { ![string length $lmod] } {
- set lmod $_defops($baseop,mod)
- }
- set mask 0
- foreach mod $lmod {
- if { ![info exists _tabops(mod,$mod)] } {
- return -code error "invalid modifier \"$mod\""
- }
- set mask [expr {$mask | $_tabops(mod,$mod)}]
- }
- if { ($mask == 0) != ([string compare $subop "default"] == 0) } {
- return -code error "sub operation default can only be used with modifier \"none\""
- }
- set drop($type,mod,$mask) $subop
- set drop($type,ops,$subop) $baseop
- set drop($type,img,$subop) $imgop
- lappend masklist $mask
- }
- }
- if { ![info exists drop($type,mod,0)] } {
- set drop($type,mod,0) default
- set drop($type,ops,default) copy
- set drop($type,img,default) $_defops(copy,img)
- lappend masklist 0
- }
- set drop($type,ops,force) copy
- set drop($type,img,force) $_defops(copy,img)
- foreach mask [lsort -integer -decreasing $masklist] {
- lappend drop($type,ops) $mask $drop($type,mod,$mask)
- }
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command DropSite::setcursor
-# ------------------------------------------------------------------------------
-proc DropSite::setcursor { cursor } {
- catch {.drag configure -cursor $cursor}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command DropSite::setoperation
-# ------------------------------------------------------------------------------
-proc DropSite::setoperation { op } {
- variable _curop
- variable _dragops
- variable _target
- variable _type
- upvar \#0 DropSite::$_target drop
-
- if { [info exist drop($_type,ops,$op)] &&
- $_dragops($drop($_type,ops,$op)) } {
- set _curop $op
- } else {
- # force to a copy operation
- set _curop force
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command DropSite::_init_drag
-# ------------------------------------------------------------------------------
-proc DropSite::_init_drag { top evt source state X Y type ops data } {
- variable _top
- variable _source
- variable _type
- variable _data
- variable _target
- variable _status
- variable _state
- variable _dragops
- variable _opw
- variable _evt
-
- catch {unset _dragops}
- array set _dragops {copy 1 move 0 link 0}
- foreach op $ops {
- set _dragops($op) 1
- }
- set _target ""
- set _status 0
- set _top $top
- set _source $source
- set _type $type
- set _data $data
-
- label $_opw -relief flat -bd 0 -highlightthickness 0 \
- -foreground black -background white
-
- bind $top <ButtonRelease-$evt> {DropSite::_release %X %Y}
- bind $top <B$evt-Motion> {DropSite::_motion %X %Y}
- bind $top <Motion> {DropSite::_release %X %Y}
- set _state $state
- set _evt $evt
- _motion $X $Y
-}
-
-
-# ------------------------------------------------------------------------------
-# Command DropSite::_update_operation
-# ------------------------------------------------------------------------------
-proc DropSite::_update_operation { state } {
- variable _top
- variable _status
- variable _state
-
- if { $_status & 3 } {
- set _state $state
- _motion [winfo pointerx $_top] [winfo pointery $_top]
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command DropSite::_compute_operation
-# ------------------------------------------------------------------------------
-proc DropSite::_compute_operation { target state type } {
- variable _curop
- variable _dragops
- upvar \#0 DropSite::$target drop
-
- foreach {mask op} $drop($type,ops) {
- if { ($state & $mask) == $mask } {
- if { $_dragops($drop($type,ops,$op)) } {
- set _curop $op
- return
- }
- }
- }
- set _curop force
-}
-
-
-# ------------------------------------------------------------------------------
-# Command DropSite::_draw_operation
-# ------------------------------------------------------------------------------
-proc DropSite::_draw_operation { target type } {
- variable _opw
- variable _curop
- variable _dragops
- variable _tabops
- variable _status
-
- upvar \#0 DropSite::$target drop
-
- if { !($_status & 1) } {
- catch {place forget $_opw}
- return
- }
-
- if { 0 } {
- if { ![info exist drop($type,ops,$_curop)] ||
- !$_dragops($drop($type,ops,$_curop)) } {
- # force to a copy operation
- set _curop copy
- catch {
- $_opw configure -bitmap $_tabops(img,copy)
- place $_opw -relx 1 -rely 1 -anchor se
- }
- }
- } elseif { ![string compare $_curop "default"] } {
- catch {place forget $_opw}
- } else {
- catch {
- $_opw configure -bitmap $drop($type,img,$_curop)
- place $_opw -relx 1 -rely 1 -anchor se
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command DropSite::_motion
-# ------------------------------------------------------------------------------
-proc DropSite::_motion { X Y } {
- variable _top
- variable _target
- variable _status
- variable _state
- variable _curop
- variable _type
- variable _data
- variable _source
- variable _evt
-
- set script [bind $_top <B$_evt-Motion>]
- bind $_top <B$_evt-Motion> {}
- bind $_top <Motion> {}
- wm geometry $_top "+[expr {$X+1}]+[expr {$Y+1}]"
- update
- if { ![winfo exists $_top] } {
- return
- }
- set path [winfo containing $X $Y]
- if { [string compare $path $_target] } {
- # path != current target
- if { $_status & 2 } {
- # current target is valid and has recall status
- # generate leave event
- upvar \#0 DropSite::$_target drop
- uplevel \#0 $drop(overcmd) [list $_target $_source leave $X $Y $_curop $_type $_data]
- }
- set _target $path
- upvar \#0 DropSite::$_target drop
- if { [info exists drop($_type,ops)] } {
- # path is a valid target
- _compute_operation $_target $_state $_type
- if { $drop(overcmd) != "" } {
- set arg [list $_target $_source enter $X $Y $_curop $_type $_data]
- set _status [uplevel \#0 $drop(overcmd) $arg]
- } else {
- set _status 1
- catch {$_top configure -cursor based_arrow_down}
- }
- _draw_operation $_target $_type
- update
- catch {
- bind $_top <B$_evt-Motion> {DropSite::_motion %X %Y}
- bind $_top <Motion> {DropSite::_release %X %Y}
- }
- return
- } else {
- set _status 0
- catch {$_top configure -cursor dot}
- _draw_operation "" ""
- }
- } elseif { $_status & 2 } {
- upvar \#0 DropSite::$_target drop
- _compute_operation $_target $_state $_type
- set arg [list $_target $_source motion $X $Y $_curop $_type $_data]
- set _status [uplevel \#0 $drop(overcmd) $arg]
- _draw_operation $_target $_type
- }
- update
- catch {
- bind $_top <B$_evt-Motion> {DropSite::_motion %X %Y}
- bind $_top <Motion> {DropSite::_release %X %Y}
- }
-}
-
-
-
-# ------------------------------------------------------------------------------
-# Command DropSite::_release
-# ------------------------------------------------------------------------------
-proc DropSite::_release { X Y } {
- variable _target
- variable _status
- variable _curop
- variable _source
- variable _type
- variable _data
-
- if { $_status & 1 } {
- upvar \#0 DropSite::$_target drop
-
- set res [uplevel \#0 $drop(dropcmd) [list $_target $_source $X $Y $_curop $_type $_data]]
- DragSite::_end_drag $_source $_target $drop($_type,ops,$_curop) $_type $_data $res
- } else {
- if { $_status & 2 } {
- # notify leave event
- upvar \#0 DropSite::$_target drop
- uplevel \#0 $drop(overcmd) [list $_target $_source leave $X $Y $_curop $_type $_data]
- }
- DragSite::_end_drag $_source "" "" $_type $_data 0
- }
-}
Copied: grass/trunk/lib/external/bwidget/dropsite.tcl (from rev 35192, grass/trunk/lib/external/bwidget/dropsite.tcl)
===================================================================
--- grass/trunk/lib/external/bwidget/dropsite.tcl (rev 0)
+++ grass/trunk/lib/external/bwidget/dropsite.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,451 @@
+# ------------------------------------------------------------------------------
+# dropsite.tcl
+# This file is part of Unifix BWidget Toolkit
+# $Id$
+# ------------------------------------------------------------------------------
+# Index of commands:
+# - DropSite::include
+# - DropSite::setdrop
+# - DropSite::register
+# - DropSite::setcursor
+# - DropSite::setoperation
+# - DropSite::_update_operation
+# - DropSite::_compute_operation
+# - DropSite::_draw_operation
+# - DropSite::_init_drag
+# - DropSite::_motion
+# - DropSite::_release
+# ------------------------------------------------------------------------------
+
+
+namespace eval DropSite {
+ Widget::declare DropSite {
+ {-dropovercmd String "" 0}
+ {-dropcmd String "" 0}
+ {-droptypes String "" 0}
+ }
+
+ proc use { } {}
+
+ variable _top ".drag"
+ variable _opw ".drag.\#op"
+ variable _target ""
+ variable _status 0
+ variable _tabops
+ variable _defops
+ variable _source
+ variable _type
+ variable _data
+ variable _evt
+ # key win unix
+ # shift 1 | 1 -> 1
+ # control 4 | 4 -> 4
+ # alt 8 | 16 -> 24
+ # meta | 64 -> 88
+
+ array set _tabops {
+ mod,none 0
+ mod,shift 1
+ mod,control 4
+ mod,alt 24
+ ops,copy 1
+ ops,move 1
+ ops,link 1
+ }
+
+ if { $tcl_platform(platform) == "unix" } {
+ set _tabops(mod,alt) 8
+ } else {
+ set _tabops(mod,alt) 16
+ }
+ array set _defops \
+ [list \
+ copy,mod shift \
+ move,mod control \
+ link,mod alt \
+ copy,img @[file join $env(BWIDGET_LIBRARY) "images" "opcopy.xbm"] \
+ move,img @[file join $env(BWIDGET_LIBRARY) "images" "opmove.xbm"] \
+ link,img @[file join $env(BWIDGET_LIBRARY) "images" "oplink.xbm"]]
+
+ bind DragTop <KeyPress-Shift_L> {DropSite::_update_operation [expr %s | 1]}
+ bind DragTop <KeyPress-Shift_R> {DropSite::_update_operation [expr %s | 1]}
+ bind DragTop <KeyPress-Control_L> {DropSite::_update_operation [expr %s | 4]}
+ bind DragTop <KeyPress-Control_R> {DropSite::_update_operation [expr %s | 4]}
+ if { $tcl_platform(platform) == "unix" } {
+ bind DragTop <KeyPress-Alt_L> {DropSite::_update_operation [expr %s | 8]}
+ bind DragTop <KeyPress-Alt_R> {DropSite::_update_operation [expr %s | 8]}
+ } else {
+ bind DragTop <KeyPress-Alt_L> {DropSite::_update_operation [expr %s | 16]}
+ bind DragTop <KeyPress-Alt_R> {DropSite::_update_operation [expr %s | 16]}
+ }
+
+ bind DragTop <KeyRelease-Shift_L> {DropSite::_update_operation [expr %s & ~1]}
+ bind DragTop <KeyRelease-Shift_R> {DropSite::_update_operation [expr %s & ~1]}
+ bind DragTop <KeyRelease-Control_L> {DropSite::_update_operation [expr %s & ~4]}
+ bind DragTop <KeyRelease-Control_R> {DropSite::_update_operation [expr %s & ~4]}
+ if { $tcl_platform(platform) == "unix" } {
+ bind DragTop <KeyRelease-Alt_L> {DropSite::_update_operation [expr %s & ~8]}
+ bind DragTop <KeyRelease-Alt_R> {DropSite::_update_operation [expr %s & ~8]}
+ } else {
+ bind DragTop <KeyRelease-Alt_L> {DropSite::_update_operation [expr %s & ~16]}
+ bind DragTop <KeyRelease-Alt_R> {DropSite::_update_operation [expr %s & ~16]}
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command DropSite::include
+# ------------------------------------------------------------------------------
+proc DropSite::include { class types } {
+ set dropoptions {
+ {-dropenabled Boolean 0 0}
+ {-dropovercmd String "" 0}
+ {-dropcmd String "" 0}
+ }
+ lappend dropoptions [list -droptypes String $types 0]
+ Widget::declare $class $dropoptions
+}
+
+
+# ------------------------------------------------------------------------------
+# Command DropSite::setdrop
+# Widget interface to register
+# ------------------------------------------------------------------------------
+proc DropSite::setdrop { path subpath dropover drop {force 0}} {
+ set cen [Widget::hasChanged $path -dropenabled en]
+ set ctypes [Widget::hasChanged $path -droptypes types]
+ if { $en } {
+ if { $force || $cen || $ctypes } {
+ register $subpath \
+ -droptypes $types \
+ -dropcmd $drop \
+ -dropovercmd $dropover
+ }
+ } else {
+ register $subpath
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command DropSite::register
+# ------------------------------------------------------------------------------
+proc DropSite::register { path args } {
+ variable _tabops
+ variable _defops
+ upvar \#0 DropSite::$path drop
+
+ Widget::init DropSite .drop$path $args
+ if { [info exists drop] } {
+ unset drop
+ }
+ set dropcmd [Widget::getoption .drop$path -dropcmd]
+ set types [Widget::getoption .drop$path -droptypes]
+ set overcmd [Widget::getoption .drop$path -dropovercmd]
+ Widget::destroy .drop$path
+ if { $dropcmd != "" && $types != "" } {
+ set drop(dropcmd) $dropcmd
+ set drop(overcmd) $overcmd
+ foreach {type ops} $types {
+ set drop($type,ops) {}
+ foreach {descop lmod} $ops {
+ if { ![llength $descop] || [llength $descop] > 3 } {
+ return -code error "invalid operation description \"$descop\""
+ }
+ foreach {subop baseop imgop} $descop {
+ set subop [string trim $subop]
+ if { ![string length $subop] } {
+ return -code error "sub operation is empty"
+ }
+ if { ![string length $baseop] } {
+ set baseop $subop
+ }
+ if { [info exists drop($type,ops,$subop)] } {
+ return -code error "operation \"$subop\" already defined"
+ }
+ if { ![info exists _tabops(ops,$baseop)] } {
+ return -code error "invalid base operation \"$baseop\""
+ }
+ if { [string compare $subop $baseop] &&
+ [info exists _tabops(ops,$subop)] } {
+ return -code error "sub operation \"$subop\" is a base operation"
+ }
+ if { ![string length $imgop] } {
+ set imgop $_defops($baseop,img)
+ }
+ }
+ if { ![string compare $lmod "program"] } {
+ set drop($type,ops,$subop) $baseop
+ set drop($type,img,$subop) $imgop
+ } else {
+ if { ![string length $lmod] } {
+ set lmod $_defops($baseop,mod)
+ }
+ set mask 0
+ foreach mod $lmod {
+ if { ![info exists _tabops(mod,$mod)] } {
+ return -code error "invalid modifier \"$mod\""
+ }
+ set mask [expr {$mask | $_tabops(mod,$mod)}]
+ }
+ if { ($mask == 0) != ([string compare $subop "default"] == 0) } {
+ return -code error "sub operation default can only be used with modifier \"none\""
+ }
+ set drop($type,mod,$mask) $subop
+ set drop($type,ops,$subop) $baseop
+ set drop($type,img,$subop) $imgop
+ lappend masklist $mask
+ }
+ }
+ if { ![info exists drop($type,mod,0)] } {
+ set drop($type,mod,0) default
+ set drop($type,ops,default) copy
+ set drop($type,img,default) $_defops(copy,img)
+ lappend masklist 0
+ }
+ set drop($type,ops,force) copy
+ set drop($type,img,force) $_defops(copy,img)
+ foreach mask [lsort -integer -decreasing $masklist] {
+ lappend drop($type,ops) $mask $drop($type,mod,$mask)
+ }
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command DropSite::setcursor
+# ------------------------------------------------------------------------------
+proc DropSite::setcursor { cursor } {
+ catch {.drag configure -cursor $cursor}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command DropSite::setoperation
+# ------------------------------------------------------------------------------
+proc DropSite::setoperation { op } {
+ variable _curop
+ variable _dragops
+ variable _target
+ variable _type
+ upvar \#0 DropSite::$_target drop
+
+ if { [info exist drop($_type,ops,$op)] &&
+ $_dragops($drop($_type,ops,$op)) } {
+ set _curop $op
+ } else {
+ # force to a copy operation
+ set _curop force
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command DropSite::_init_drag
+# ------------------------------------------------------------------------------
+proc DropSite::_init_drag { top evt source state X Y type ops data } {
+ variable _top
+ variable _source
+ variable _type
+ variable _data
+ variable _target
+ variable _status
+ variable _state
+ variable _dragops
+ variable _opw
+ variable _evt
+
+ catch {unset _dragops}
+ array set _dragops {copy 1 move 0 link 0}
+ foreach op $ops {
+ set _dragops($op) 1
+ }
+ set _target ""
+ set _status 0
+ set _top $top
+ set _source $source
+ set _type $type
+ set _data $data
+
+ label $_opw -relief flat -bd 0 -highlightthickness 0 \
+ -foreground black -background white
+
+ bind $top <ButtonRelease-$evt> {DropSite::_release %X %Y}
+ bind $top <B$evt-Motion> {DropSite::_motion %X %Y}
+ bind $top <Motion> {DropSite::_release %X %Y}
+ set _state $state
+ set _evt $evt
+ _motion $X $Y
+}
+
+
+# ------------------------------------------------------------------------------
+# Command DropSite::_update_operation
+# ------------------------------------------------------------------------------
+proc DropSite::_update_operation { state } {
+ variable _top
+ variable _status
+ variable _state
+
+ if { $_status & 3 } {
+ set _state $state
+ _motion [winfo pointerx $_top] [winfo pointery $_top]
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command DropSite::_compute_operation
+# ------------------------------------------------------------------------------
+proc DropSite::_compute_operation { target state type } {
+ variable _curop
+ variable _dragops
+ upvar \#0 DropSite::$target drop
+
+ foreach {mask op} $drop($type,ops) {
+ if { ($state & $mask) == $mask } {
+ if { $_dragops($drop($type,ops,$op)) } {
+ set _curop $op
+ return
+ }
+ }
+ }
+ set _curop force
+}
+
+
+# ------------------------------------------------------------------------------
+# Command DropSite::_draw_operation
+# ------------------------------------------------------------------------------
+proc DropSite::_draw_operation { target type } {
+ variable _opw
+ variable _curop
+ variable _dragops
+ variable _tabops
+ variable _status
+
+ upvar \#0 DropSite::$target drop
+
+ if { !($_status & 1) } {
+ catch {place forget $_opw}
+ return
+ }
+
+ if { 0 } {
+ if { ![info exist drop($type,ops,$_curop)] ||
+ !$_dragops($drop($type,ops,$_curop)) } {
+ # force to a copy operation
+ set _curop copy
+ catch {
+ $_opw configure -bitmap $_tabops(img,copy)
+ place $_opw -relx 1 -rely 1 -anchor se
+ }
+ }
+ } elseif { ![string compare $_curop "default"] } {
+ catch {place forget $_opw}
+ } else {
+ catch {
+ $_opw configure -bitmap $drop($type,img,$_curop)
+ place $_opw -relx 1 -rely 1 -anchor se
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command DropSite::_motion
+# ------------------------------------------------------------------------------
+proc DropSite::_motion { X Y } {
+ variable _top
+ variable _target
+ variable _status
+ variable _state
+ variable _curop
+ variable _type
+ variable _data
+ variable _source
+ variable _evt
+
+ set script [bind $_top <B$_evt-Motion>]
+ bind $_top <B$_evt-Motion> {}
+ bind $_top <Motion> {}
+ wm geometry $_top "+[expr {$X+1}]+[expr {$Y+1}]"
+ update
+ if { ![winfo exists $_top] } {
+ return
+ }
+ set path [winfo containing $X $Y]
+ if { [string compare $path $_target] } {
+ # path != current target
+ if { $_status & 2 } {
+ # current target is valid and has recall status
+ # generate leave event
+ upvar \#0 DropSite::$_target drop
+ uplevel \#0 $drop(overcmd) [list $_target $_source leave $X $Y $_curop $_type $_data]
+ }
+ set _target $path
+ upvar \#0 DropSite::$_target drop
+ if { [info exists drop($_type,ops)] } {
+ # path is a valid target
+ _compute_operation $_target $_state $_type
+ if { $drop(overcmd) != "" } {
+ set arg [list $_target $_source enter $X $Y $_curop $_type $_data]
+ set _status [uplevel \#0 $drop(overcmd) $arg]
+ } else {
+ set _status 1
+ catch {$_top configure -cursor based_arrow_down}
+ }
+ _draw_operation $_target $_type
+ update
+ catch {
+ bind $_top <B$_evt-Motion> {DropSite::_motion %X %Y}
+ bind $_top <Motion> {DropSite::_release %X %Y}
+ }
+ return
+ } else {
+ set _status 0
+ catch {$_top configure -cursor dot}
+ _draw_operation "" ""
+ }
+ } elseif { $_status & 2 } {
+ upvar \#0 DropSite::$_target drop
+ _compute_operation $_target $_state $_type
+ set arg [list $_target $_source motion $X $Y $_curop $_type $_data]
+ set _status [uplevel \#0 $drop(overcmd) $arg]
+ _draw_operation $_target $_type
+ }
+ update
+ catch {
+ bind $_top <B$_evt-Motion> {DropSite::_motion %X %Y}
+ bind $_top <Motion> {DropSite::_release %X %Y}
+ }
+}
+
+
+
+# ------------------------------------------------------------------------------
+# Command DropSite::_release
+# ------------------------------------------------------------------------------
+proc DropSite::_release { X Y } {
+ variable _target
+ variable _status
+ variable _curop
+ variable _source
+ variable _type
+ variable _data
+
+ if { $_status & 1 } {
+ upvar \#0 DropSite::$_target drop
+
+ set res [uplevel \#0 $drop(dropcmd) [list $_target $_source $X $Y $_curop $_type $_data]]
+ DragSite::_end_drag $_source $_target $drop($_type,ops,$_curop) $_type $_data $res
+ } else {
+ if { $_status & 2 } {
+ # notify leave event
+ upvar \#0 DropSite::$_target drop
+ uplevel \#0 $drop(overcmd) [list $_target $_source leave $X $Y $_curop $_type $_data]
+ }
+ DragSite::_end_drag $_source "" "" $_type $_data 0
+ }
+}
Deleted: grass/trunk/lib/external/bwidget/dynhelp.tcl
===================================================================
--- grass/trunk/lib/external/bwidget/dynhelp.tcl 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/dynhelp.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,332 +0,0 @@
-# ------------------------------------------------------------------------------
-# dynhelp.tcl
-# This file is part of Unifix BWidget Toolkit
-# $Id$
-# ------------------------------------------------------------------------------
-# Index of commands:
-# - DynamicHelp::configure
-# - DynamicHelp::include
-# - DynamicHelp::sethelp
-# - DynamicHelp::register
-# - DynamicHelp::_motion_balloon
-# - DynamicHelp::_motion_info
-# - DynamicHelp::_leave_info
-# - DynamicHelp::_menu_info
-# - DynamicHelp::_show_help
-# - DynamicHelp::_init
-# ------------------------------------------------------------------------------
-
-namespace eval DynamicHelp {
- Widget::declare DynamicHelp {
- {-foreground TkResource black 0 label}
- {-background TkResource "#FFFFC0" 0 label}
- {-borderwidth TkResource 1 0 label}
- {-justify TkResource left 0 label}
- {-font TkResource "helvetica 8" 0 label}
- {-delay Int 600 0 {=100 =2000}}
- {-bd Synonym -borderwidth}
- {-bg Synonym -background}
- {-fg Synonym -foreground}
- }
-
- proc use {} {}
-
- variable _registered
-
- variable _top ".help_shell"
- variable _id ""
- variable _delay 600
- variable _current ""
- variable _saved
-
- Widget::init DynamicHelp $_top {}
-
- bind BwHelpBalloon <Enter> {DynamicHelp::_motion_balloon enter %W %X %Y}
- bind BwHelpBalloon <Motion> {DynamicHelp::_motion_balloon motion %W %X %Y}
- bind BwHelpBalloon <Leave> {DynamicHelp::_motion_balloon leave %W %X %Y}
- bind BwHelpBalloon <Button> {DynamicHelp::_motion_balloon button %W %X %Y}
- bind BwHelpBalloon <Destroy> {catch {unset DynamicHelp::_registered(%W)}}
-
- bind BwHelpVariable <Enter> {DynamicHelp::_motion_info %W}
- bind BwHelpVariable <Motion> {DynamicHelp::_motion_info %W}
- bind BwHelpVariable <Leave> {DynamicHelp::_leave_info %W}
- bind BwHelpVariable <Destroy> {catch {unset DynamicHelp::_registered(%W)}}
-
- bind BwHelpMenu <<MenuSelect>> {DynamicHelp::_menu_info select %W}
- bind BwHelpMenu <Unmap> {DynamicHelp::_menu_info unmap %W}
- bind BwHelpMenu <Destroy> {catch {unset DynamicHelp::_registered(%W)}}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command DynamicHelp::configure
-# ------------------------------------------------------------------------------
-proc DynamicHelp::configure { args } {
- variable _top
- variable _delay
-
- set res [Widget::configure $_top $args]
- if { [Widget::hasChanged $_top -delay val] } {
- set _delay $val
- }
-
- return $res
-}
-
-
-# ------------------------------------------------------------------------------
-# Command DynamicHelp::include
-# ------------------------------------------------------------------------------
-proc DynamicHelp::include { class type } {
- set helpoptions {
- {-helptext String "" 0}
- {-helpvar String "" 0}}
- lappend helpoptions [list -helptype Enum $type 0 {balloon variable}]
- Widget::declare $class $helpoptions
-}
-
-
-# ------------------------------------------------------------------------------
-# Command DynamicHelp::sethelp
-# ------------------------------------------------------------------------------
-proc DynamicHelp::sethelp { path subpath {force 0}} {
- set ctype [Widget::hasChanged $path -helptype htype]
- set ctext [Widget::hasChanged $path -helptext htext]
- set cvar [Widget::hasChanged $path -helpvar hvar]
- if { $force || $ctype || $ctext || $cvar } {
- switch $htype {
- balloon {
- return [register $subpath balloon $htext]
- }
- variable {
- return [register $subpath variable $hvar $htext]
- }
- }
- return [register $subpath $htype]
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command DynamicHelp::register
-# ------------------------------------------------------------------------------
-proc DynamicHelp::register { path type args } {
- variable _registered
-
- if { [winfo exists $path] } {
- set evt [bindtags $path]
- set idx [lsearch $evt "BwHelp*"]
- set evt [lreplace $evt $idx $idx]
- switch $type {
- balloon {
- set text [lindex $args 0]
- if { $text != "" } {
- set _registered($path) $text
- lappend evt BwHelpBalloon
- } else {
- catch {unset _registered($path)}
- }
- bindtags $path $evt
- return 1
- }
-
- variable {
- set var [lindex $args 0]
- set text [lindex $args 1]
- if { $text != "" && $var != "" } {
- set _registered($path) [list $var $text]
- lappend evt BwHelpVariable
- } else {
- catch {unset _registered($path)}
- }
- bindtags $path $evt
- return 1
- }
-
- menu {
- set cpath [BWidget::clonename $path]
- if { [winfo exists $cpath] } {
- set path $cpath
- }
- set var [lindex $args 0]
- if { $var != "" } {
- set _registered($path) [list $var]
- lappend evt BwHelpMenu
- } else {
- catch {unset _registered($path)}
- }
- bindtags $path $evt
- return 1
- }
-
- menuentry {
- set cpath [BWidget::clonename $path]
- if { [winfo exists $cpath] } {
- set path $cpath
- }
- if { [info exists _registered($path)] } {
- if { [set index [lindex $args 0]] != "" } {
- set text [lindex $args 1]
- set idx [lsearch $_registered($path) [list $index *]]
- if { $text != "" } {
- if { $idx == -1 } {
- lappend _registered($path) [list $index $text]
- } else {
- set _registered($path) [lreplace $_registered($path) $idx $idx [list $index $text]]
- }
- } else {
- set _registered($path) [lreplace $_registered($path) $idx $idx]
- }
- }
- return 1
- }
- return 0
- }
- }
- catch {unset _registered($path)}
- bindtags $path $evt
- return 1
- } else {
- catch {unset _registered($path)}
- return 0
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command DynamicHelp::_motion_balloon
-# ------------------------------------------------------------------------------
-proc DynamicHelp::_motion_balloon { type path x y } {
- variable _top
- variable _id
- variable _delay
- variable _current
-
- if { $_current != $path && $type == "enter" } {
- set _current $path
- set type "motion"
- destroy $_top
- }
- if { $_current == $path } {
- if { $_id != "" } {
- after cancel $_id
- set _id ""
- }
- if { $type == "motion" } {
- if { ![winfo exists $_top] } {
- set _id [after $_delay "DynamicHelp::_show_help $path $x $y"]
- }
- } else {
- destroy $_top
- set _current ""
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command DynamicHelp::_motion_info
-# ------------------------------------------------------------------------------
-proc DynamicHelp::_motion_info { path } {
- variable _registered
- variable _current
- variable _saved
-
- if { $_current != $path && [info exists _registered($path)] } {
- if { ![info exists _saved] } {
- set _saved [GlobalVar::getvar [lindex $_registered($path) 0]]
- }
- GlobalVar::setvar [lindex $_registered($path) 0] [lindex $_registered($path) 1]
- set _current $path
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command DynamicHelp::_leave_info
-# ------------------------------------------------------------------------------
-proc DynamicHelp::_leave_info { path } {
- variable _registered
- variable _current
- variable _saved
-
- if { [info exists _registered($path)] } {
- GlobalVar::setvar [lindex $_registered($path) 0] $_saved
- }
- unset _saved
- set _current ""
-
-}
-
-
-# ------------------------------------------------------------------------------
-# Command DynamicHelp::_menu_info
-# Version of R1v1 restored, due to lack of [winfo ismapped] and <Unmap>
-# under windows for menu.
-# ------------------------------------------------------------------------------
-proc DynamicHelp::_menu_info { event path } {
- variable _registered
-
- if { [info exists _registered($path)] } {
- set index [$path index active]
- if { [string compare $index "none"] &&
- [set idx [lsearch $_registered($path) [list $index *]]] != -1 } {
- GlobalVar::setvar [lindex $_registered($path) 0] \
- [lindex [lindex $_registered($path) $idx] 1]
- } else {
- GlobalVar::setvar [lindex $_registered($path) 0] ""
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command DynamicHelp::_show_help
-# ------------------------------------------------------------------------------
-proc DynamicHelp::_show_help { path x y } {
- variable _top
- variable _registered
- variable _id
- variable _delay
-
- if { [info exists _registered($path)] } {
- destroy $_top
- toplevel $_top -relief flat \
- -bg [Widget::getoption $_top -foreground] \
- -bd [Widget::getoption $_top -borderwidth]
- wm overrideredirect $_top 1
- wm transient $_top
- wm withdraw $_top
-
- label $_top.label -text $_registered($path) \
- -relief flat -bd 0 -highlightthickness 0 \
- -foreground [Widget::getoption $_top -foreground] \
- -background [Widget::getoption $_top -background] \
- -font [Widget::getoption $_top -font] \
- -justify [Widget::getoption $_top -justify]
-
-
- pack $_top.label -side left
- update idletasks
-
- set scrwidth [winfo vrootwidth .]
- set scrheight [winfo vrootheight .]
- set width [winfo reqwidth $_top]
- set height [winfo reqheight $_top]
- incr y 12
- incr x 8
-
- if { $x+$width > $scrwidth } {
- set x [expr $scrwidth - $width]
- }
- if { $y+$height > $scrheight } {
- set y [expr $y - 12 - $height]
- }
-
- wm geometry $_top "+$x+$y"
- update idletasks
- wm deiconify $_top
- }
-}
-
-
Copied: grass/trunk/lib/external/bwidget/dynhelp.tcl (from rev 35192, grass/trunk/lib/external/bwidget/dynhelp.tcl)
===================================================================
--- grass/trunk/lib/external/bwidget/dynhelp.tcl (rev 0)
+++ grass/trunk/lib/external/bwidget/dynhelp.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,332 @@
+# ------------------------------------------------------------------------------
+# dynhelp.tcl
+# This file is part of Unifix BWidget Toolkit
+# $Id$
+# ------------------------------------------------------------------------------
+# Index of commands:
+# - DynamicHelp::configure
+# - DynamicHelp::include
+# - DynamicHelp::sethelp
+# - DynamicHelp::register
+# - DynamicHelp::_motion_balloon
+# - DynamicHelp::_motion_info
+# - DynamicHelp::_leave_info
+# - DynamicHelp::_menu_info
+# - DynamicHelp::_show_help
+# - DynamicHelp::_init
+# ------------------------------------------------------------------------------
+
+namespace eval DynamicHelp {
+ Widget::declare DynamicHelp {
+ {-foreground TkResource black 0 label}
+ {-background TkResource "#FFFFC0" 0 label}
+ {-borderwidth TkResource 1 0 label}
+ {-justify TkResource left 0 label}
+ {-font TkResource "helvetica 8" 0 label}
+ {-delay Int 600 0 {=100 =2000}}
+ {-bd Synonym -borderwidth}
+ {-bg Synonym -background}
+ {-fg Synonym -foreground}
+ }
+
+ proc use {} {}
+
+ variable _registered
+
+ variable _top ".help_shell"
+ variable _id ""
+ variable _delay 600
+ variable _current ""
+ variable _saved
+
+ Widget::init DynamicHelp $_top {}
+
+ bind BwHelpBalloon <Enter> {DynamicHelp::_motion_balloon enter %W %X %Y}
+ bind BwHelpBalloon <Motion> {DynamicHelp::_motion_balloon motion %W %X %Y}
+ bind BwHelpBalloon <Leave> {DynamicHelp::_motion_balloon leave %W %X %Y}
+ bind BwHelpBalloon <Button> {DynamicHelp::_motion_balloon button %W %X %Y}
+ bind BwHelpBalloon <Destroy> {catch {unset DynamicHelp::_registered(%W)}}
+
+ bind BwHelpVariable <Enter> {DynamicHelp::_motion_info %W}
+ bind BwHelpVariable <Motion> {DynamicHelp::_motion_info %W}
+ bind BwHelpVariable <Leave> {DynamicHelp::_leave_info %W}
+ bind BwHelpVariable <Destroy> {catch {unset DynamicHelp::_registered(%W)}}
+
+ bind BwHelpMenu <<MenuSelect>> {DynamicHelp::_menu_info select %W}
+ bind BwHelpMenu <Unmap> {DynamicHelp::_menu_info unmap %W}
+ bind BwHelpMenu <Destroy> {catch {unset DynamicHelp::_registered(%W)}}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command DynamicHelp::configure
+# ------------------------------------------------------------------------------
+proc DynamicHelp::configure { args } {
+ variable _top
+ variable _delay
+
+ set res [Widget::configure $_top $args]
+ if { [Widget::hasChanged $_top -delay val] } {
+ set _delay $val
+ }
+
+ return $res
+}
+
+
+# ------------------------------------------------------------------------------
+# Command DynamicHelp::include
+# ------------------------------------------------------------------------------
+proc DynamicHelp::include { class type } {
+ set helpoptions {
+ {-helptext String "" 0}
+ {-helpvar String "" 0}}
+ lappend helpoptions [list -helptype Enum $type 0 {balloon variable}]
+ Widget::declare $class $helpoptions
+}
+
+
+# ------------------------------------------------------------------------------
+# Command DynamicHelp::sethelp
+# ------------------------------------------------------------------------------
+proc DynamicHelp::sethelp { path subpath {force 0}} {
+ set ctype [Widget::hasChanged $path -helptype htype]
+ set ctext [Widget::hasChanged $path -helptext htext]
+ set cvar [Widget::hasChanged $path -helpvar hvar]
+ if { $force || $ctype || $ctext || $cvar } {
+ switch $htype {
+ balloon {
+ return [register $subpath balloon $htext]
+ }
+ variable {
+ return [register $subpath variable $hvar $htext]
+ }
+ }
+ return [register $subpath $htype]
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command DynamicHelp::register
+# ------------------------------------------------------------------------------
+proc DynamicHelp::register { path type args } {
+ variable _registered
+
+ if { [winfo exists $path] } {
+ set evt [bindtags $path]
+ set idx [lsearch $evt "BwHelp*"]
+ set evt [lreplace $evt $idx $idx]
+ switch $type {
+ balloon {
+ set text [lindex $args 0]
+ if { $text != "" } {
+ set _registered($path) $text
+ lappend evt BwHelpBalloon
+ } else {
+ catch {unset _registered($path)}
+ }
+ bindtags $path $evt
+ return 1
+ }
+
+ variable {
+ set var [lindex $args 0]
+ set text [lindex $args 1]
+ if { $text != "" && $var != "" } {
+ set _registered($path) [list $var $text]
+ lappend evt BwHelpVariable
+ } else {
+ catch {unset _registered($path)}
+ }
+ bindtags $path $evt
+ return 1
+ }
+
+ menu {
+ set cpath [BWidget::clonename $path]
+ if { [winfo exists $cpath] } {
+ set path $cpath
+ }
+ set var [lindex $args 0]
+ if { $var != "" } {
+ set _registered($path) [list $var]
+ lappend evt BwHelpMenu
+ } else {
+ catch {unset _registered($path)}
+ }
+ bindtags $path $evt
+ return 1
+ }
+
+ menuentry {
+ set cpath [BWidget::clonename $path]
+ if { [winfo exists $cpath] } {
+ set path $cpath
+ }
+ if { [info exists _registered($path)] } {
+ if { [set index [lindex $args 0]] != "" } {
+ set text [lindex $args 1]
+ set idx [lsearch $_registered($path) [list $index *]]
+ if { $text != "" } {
+ if { $idx == -1 } {
+ lappend _registered($path) [list $index $text]
+ } else {
+ set _registered($path) [lreplace $_registered($path) $idx $idx [list $index $text]]
+ }
+ } else {
+ set _registered($path) [lreplace $_registered($path) $idx $idx]
+ }
+ }
+ return 1
+ }
+ return 0
+ }
+ }
+ catch {unset _registered($path)}
+ bindtags $path $evt
+ return 1
+ } else {
+ catch {unset _registered($path)}
+ return 0
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command DynamicHelp::_motion_balloon
+# ------------------------------------------------------------------------------
+proc DynamicHelp::_motion_balloon { type path x y } {
+ variable _top
+ variable _id
+ variable _delay
+ variable _current
+
+ if { $_current != $path && $type == "enter" } {
+ set _current $path
+ set type "motion"
+ destroy $_top
+ }
+ if { $_current == $path } {
+ if { $_id != "" } {
+ after cancel $_id
+ set _id ""
+ }
+ if { $type == "motion" } {
+ if { ![winfo exists $_top] } {
+ set _id [after $_delay "DynamicHelp::_show_help $path $x $y"]
+ }
+ } else {
+ destroy $_top
+ set _current ""
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command DynamicHelp::_motion_info
+# ------------------------------------------------------------------------------
+proc DynamicHelp::_motion_info { path } {
+ variable _registered
+ variable _current
+ variable _saved
+
+ if { $_current != $path && [info exists _registered($path)] } {
+ if { ![info exists _saved] } {
+ set _saved [GlobalVar::getvar [lindex $_registered($path) 0]]
+ }
+ GlobalVar::setvar [lindex $_registered($path) 0] [lindex $_registered($path) 1]
+ set _current $path
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command DynamicHelp::_leave_info
+# ------------------------------------------------------------------------------
+proc DynamicHelp::_leave_info { path } {
+ variable _registered
+ variable _current
+ variable _saved
+
+ if { [info exists _registered($path)] } {
+ GlobalVar::setvar [lindex $_registered($path) 0] $_saved
+ }
+ unset _saved
+ set _current ""
+
+}
+
+
+# ------------------------------------------------------------------------------
+# Command DynamicHelp::_menu_info
+# Version of R1v1 restored, due to lack of [winfo ismapped] and <Unmap>
+# under windows for menu.
+# ------------------------------------------------------------------------------
+proc DynamicHelp::_menu_info { event path } {
+ variable _registered
+
+ if { [info exists _registered($path)] } {
+ set index [$path index active]
+ if { [string compare $index "none"] &&
+ [set idx [lsearch $_registered($path) [list $index *]]] != -1 } {
+ GlobalVar::setvar [lindex $_registered($path) 0] \
+ [lindex [lindex $_registered($path) $idx] 1]
+ } else {
+ GlobalVar::setvar [lindex $_registered($path) 0] ""
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command DynamicHelp::_show_help
+# ------------------------------------------------------------------------------
+proc DynamicHelp::_show_help { path x y } {
+ variable _top
+ variable _registered
+ variable _id
+ variable _delay
+
+ if { [info exists _registered($path)] } {
+ destroy $_top
+ toplevel $_top -relief flat \
+ -bg [Widget::getoption $_top -foreground] \
+ -bd [Widget::getoption $_top -borderwidth]
+ wm overrideredirect $_top 1
+ wm transient $_top
+ wm withdraw $_top
+
+ label $_top.label -text $_registered($path) \
+ -relief flat -bd 0 -highlightthickness 0 \
+ -foreground [Widget::getoption $_top -foreground] \
+ -background [Widget::getoption $_top -background] \
+ -font [Widget::getoption $_top -font] \
+ -justify [Widget::getoption $_top -justify]
+
+
+ pack $_top.label -side left
+ update idletasks
+
+ set scrwidth [winfo vrootwidth .]
+ set scrheight [winfo vrootheight .]
+ set width [winfo reqwidth $_top]
+ set height [winfo reqheight $_top]
+ incr y 12
+ incr x 8
+
+ if { $x+$width > $scrwidth } {
+ set x [expr $scrwidth - $width]
+ }
+ if { $y+$height > $scrheight } {
+ set y [expr $y - 12 - $height]
+ }
+
+ wm geometry $_top "+$x+$y"
+ update idletasks
+ wm deiconify $_top
+ }
+}
+
+
Deleted: grass/trunk/lib/external/bwidget/entry.tcl
===================================================================
--- grass/trunk/lib/external/bwidget/entry.tcl 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/entry.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,426 +0,0 @@
-# ------------------------------------------------------------------------------
-# entry.tcl
-# This file is part of Unifix BWidget Toolkit
-# $Id$
-# ------------------------------------------------------------------------------
-# Index of commands:
-# - Entry::create
-# - Entry::configure
-# - Entry::cget
-# - Entry::_destroy
-# - Entry::_init_drag_cmd
-# - Entry::_end_drag_cmd
-# - Entry::_drop_cmd
-# - Entry::_over_cmd
-# - Entry::_auto_scroll
-# - Entry::_scroll
-# ------------------------------------------------------------------------------
-
-namespace eval Entry {
- Widget::tkinclude Entry entry :cmd \
- remove {-state -cursor -foreground -textvariable}
-
- Widget::declare Entry {
- {-foreground TkResource "" 0 entry}
- {-disabledforeground TkResource "" 0 button}
- {-state Enum normal 0 {normal disabled}}
- {-text String "" 0}
- {-textvariable String "" 0}
- {-editable Boolean 1 0}
- {-command String "" 0}
- {-relief TkResource "" 0 entry}
- {-borderwidth TkResource "" 0 entry}
- {-fg Synonym -foreground}
- {-bd Synonym -borderwidth}
- }
-
- DynamicHelp::include Entry balloon
- DragSite::include Entry "" 3
- DropSite::include Entry {
- TEXT {move {}}
- FGCOLOR {move {}}
- BGCOLOR {move {}}
- COLOR {move {}}
- }
-
- foreach event [bind Entry] {
- bind BwEntry $event [bind Entry $event]
- }
- bind BwEntry <Return> {Entry::invoke %W}
- bind BwEntry <Destroy> {Entry::_destroy %W}
- bind BwDisabledEntry <Destroy> {Entry::_destroy %W}
-
- proc ::Entry { path args } { return [eval Entry::create $path $args] }
- proc use {} {}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Entry::create
-# ------------------------------------------------------------------------------
-proc Entry::create { path args } {
- variable $path
- upvar 0 $path data
-
- Widget::init Entry $path $args
-
- set data(afterid) ""
- if { [set varname [Widget::getoption $path -textvariable]] != "" } {
- set data(varname) $varname
- } else {
- set data(varname) Entry::$path\(var\)
- }
-
- if { [GlobalVar::exists $data(varname)] } {
- set curval [GlobalVar::getvar $data(varname)]
- Widget::setoption $path -text $curval
- } else {
- set curval [Widget::getoption $path -text]
- GlobalVar::setvar $data(varname) $curval
- }
-
- eval entry $path [Widget::subcget $path :cmd]
- uplevel \#0 $path configure -textvariable [list $data(varname)]
-
- set state [Widget::getoption $path -state]
- set editable [Widget::getoption $path -editable]
- if { $editable && ![string compare $state "normal"] } {
- bindtags $path [list $path BwEntry [winfo toplevel $path] all]
- $path configure -takefocus 1
- } else {
- bindtags $path [list $path BwDisabledEntry [winfo toplevel $path] all]
- $path configure -takefocus 0
- }
- if { $editable == 0 } {
- $path configure -cursor left_ptr
- }
- if { ![string compare $state "disabled"] } {
- $path configure -foreground [Widget::getoption $path -disabledforeground]
- }
-
- DragSite::setdrag $path $path Entry::_init_drag_cmd Entry::_end_drag_cmd 1
- DropSite::setdrop $path $path Entry::_over_cmd Entry::_drop_cmd 1
- DynamicHelp::sethelp $path $path 1
-
- rename $path ::$path:cmd
- proc ::$path { cmd args } "return \[Entry::_path_command $path \$cmd \$args\]"
-
- return $path
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Entry::configure
-# ------------------------------------------------------------------------------
-proc Entry::configure { path args } {
- variable $path
- upvar 0 $path data
-
- Widget::setoption $path -text [$path:cmd get]
-
- set res [Widget::configure $path $args]
-
- set chstate [Widget::hasChanged $path -state state]
- set cheditable [Widget::hasChanged $path -editable editable]
- set chfg [Widget::hasChanged $path -foreground fg]
- set chdfg [Widget::hasChanged $path -disabledforeground dfg]
-
- if { $chstate || $cheditable } {
- set btags [bindtags $path]
- if { $editable && ![string compare $state "normal"] } {
- set idx [lsearch $btags BwDisabledEntry]
- if { $idx != -1 } {
- bindtags $path [lreplace $btags $idx $idx BwEntry]
- }
- $path:cmd configure -takefocus 1
- } else {
- set idx [lsearch $btags BwEntry]
- if { $idx != -1 } {
- bindtags $path [lreplace $btags $idx $idx BwDisabledEntry]
- }
- $path:cmd configure -takefocus 0
- if { ![string compare [focus] $path] } {
- focus .
- }
- }
- }
-
- if { $chstate || $chfg || $chdfg } {
- if { ![string compare $state "disabled"] } {
- $path:cmd configure -fg $dfg
- } else {
- $path:cmd configure -fg $fg
- }
- }
-
- if { $cheditable } {
- if { $editable } {
- $path:cmd configure -cursor xterm
- } else {
- $path:cmd configure -cursor left_ptr
- }
- }
-
- if { [Widget::hasChanged $path -textvariable varname] } {
- if { [string length $varname] } {
- set data(varname) $varname
- } else {
- catch {unset data(var)}
- set data(varname) Entry::$path\(var\)
- }
- if { [GlobalVar::exists $data(varname)] } {
- set curval [GlobalVar::getvar $data(varname)]
- Widget::setoption $path -text $curval
- } else {
- Widget::hasChanged $path -text curval
- GlobalVar::setvar $data(varname) $curval
- }
- uplevel \#0 $path:cmd configure -textvariable [list $data(varname)]
- }
-
- if { [Widget::hasChanged $path -text curval] } {
- if { [Widget::getoption $path -textvariable] == "" } {
- GlobalVar::setvar $data(varname) $curval
- } else {
- Widget::setoption $path -text [GlobalVar::getvar $data(varname)]
- }
- }
-
- DragSite::setdrag $path $path Entry::_init_drag_cmd Entry::_end_drag_cmd
- DropSite::setdrop $path $path Entry::_over_cmd Entry::_drop_cmd
- DynamicHelp::sethelp $path $path
-
- return $res
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Entry::cget
-# ------------------------------------------------------------------------------
-proc Entry::cget { path option } {
- Widget::setoption $path -text [$path:cmd get]
- return [Widget::cget $path $option]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Entry::invoke
-# ------------------------------------------------------------------------------
-proc Entry::invoke { path } {
- if { [set cmd [Widget::getoption $path -command]] != "" } {
- uplevel \#0 $cmd
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Entry::_path_command
-# ------------------------------------------------------------------------------
-proc Entry::_path_command { path cmd larg } {
- if { ![string compare $cmd "configure"] || ![string compare $cmd "cget"] } {
- return [eval Entry::$cmd $path $larg]
- } else {
- return [eval $path:cmd $cmd $larg]
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Entry::_destroy
-# ------------------------------------------------------------------------------
-proc Entry::_destroy { path } {
- variable $path
- upvar 0 $path data
-
- Widget::destroy $path
- rename $path {}
- unset data
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Entry::_init_drag_cmd
-# ------------------------------------------------------------------------------
-proc Entry::_init_drag_cmd { path X Y top } {
- variable $path
- upvar 0 $path data
-
- if { [set cmd [Widget::getoption $path -draginitcmd]] != "" } {
- return [uplevel \#0 $cmd [list $path $X $Y $top]]
- }
- set type [Widget::getoption $path -dragtype]
- if { $type == "" } {
- set type "TEXT"
- }
- if { [set drag [$path get]] != "" } {
- if { [$path:cmd selection present] } {
- set idx [$path:cmd index @[expr $X-[winfo rootx $path]]]
- set sel0 [$path:cmd index sel.first]
- set sel1 [expr [$path:cmd index sel.last]-1]
- if { $idx >= $sel0 && $idx <= $sel1 } {
- set drag [string range $drag $sel0 $sel1]
- set data(dragstart) $sel0
- set data(dragend) [expr {$sel1+1}]
- if { ![Widget::getoption $path -editable] ||
- [Widget::getoption $path -state] == "disabled" } {
- return [list $type {copy} $drag]
- } else {
- return [list $type {copy move} $drag]
- }
- }
- } else {
- set data(dragstart) 0
- set data(dragend) end
- if { ![Widget::getoption $path -editable] ||
- [Widget::getoption $path -state] == "disabled" } {
- return [list $type {copy} $drag]
- } else {
- return [list $type {copy move} $drag]
- }
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Entry::_end_drag_cmd
-# ------------------------------------------------------------------------------
-proc Entry::_end_drag_cmd { path target op type dnddata result } {
- variable $path
- upvar 0 $path data
-
- if { [set cmd [Widget::getoption $path -dragendcmd]] != "" } {
- return [uplevel \#0 $cmd [list $path $target $op $type $dnddata $result]]
- }
- if { $result && $op == "move" && $path != $target } {
- $path:cmd delete $data(dragstart) $data(dragend)
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Entry::_drop_cmd
-# ------------------------------------------------------------------------------
-proc Entry::_drop_cmd { path source X Y op type dnddata } {
- variable $path
- upvar 0 $path data
-
- if { $data(afterid) != "" } {
- after cancel $data(afterid)
- set data(afterid) ""
- }
- if { [set cmd [Widget::getoption $path -dropcmd]] != "" } {
- set idx [$path:cmd index @[expr $X-[winfo rootx $path]]]
- return [uplevel \#0 $cmd [list $path $source $idx $op $type $dnddata]]
- }
- if { $type == "COLOR" || $type == "FGCOLOR" } {
- configure $path -foreground $dnddata
- } elseif { $type == "BGCOLOR" } {
- configure $path -background $dnddata
- } else {
- $path:cmd icursor @[expr $X-[winfo rootx $path]]
- if { $op == "move" && $path == $source } {
- $path:cmd delete $data(dragstart) $data(dragend)
- }
- set sel0 [$path index insert]
- $path:cmd insert insert $dnddata
- set sel1 [$path index insert]
- $path:cmd selection range $sel0 $sel1
- }
- return 1
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Entry::_over_cmd
-# ------------------------------------------------------------------------------
-proc Entry::_over_cmd { path source event X Y op type dnddata } {
- variable $path
- upvar 0 $path data
-
- set x [expr $X-[winfo rootx $path]]
- if { ![string compare $event "leave"] } {
- if { [string length $data(afterid)] } {
- after cancel $data(afterid)
- set data(afterid) ""
- }
- } elseif { [_auto_scroll $path $x] } {
- return 2
- }
-
- if { [set cmd [Widget::getoption $path -dropovercmd]] != "" } {
- set x [expr $X-[winfo rootx $path]]
- set idx [$path:cmd index @$x]
- set res [uplevel \#0 $cmd [list $path $source $event $idx $op $type $dnddata]]
- return $res
- }
-
- if { ![string compare $type "COLOR"] ||
- ![string compare $type "FGCOLOR"] ||
- ![string compare $type "BGCOLOR"] } {
- DropSite::setcursor based_arrow_down
- return 1
- }
- if { [Widget::getoption $path -editable] && ![string compare [Widget::getoption $path -state] "normal"] } {
- if { [string compare $event "leave"] } {
- $path:cmd selection clear
- $path:cmd icursor @$x
- DropSite::setcursor based_arrow_down
- return 3
- }
- }
- DropSite::setcursor dot
- return 0
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Entry::_auto_scroll
-# ------------------------------------------------------------------------------
-proc Entry::_auto_scroll { path x } {
- variable $path
- upvar 0 $path data
-
- set xmax [winfo width $path]
- if { $x <= 10 && [$path:cmd index @0] > 0 } {
- if { $data(afterid) == "" } {
- set data(afterid) [after 100 "Entry::_scroll $path -1 $x $xmax"]
- DropSite::setcursor sb_left_arrow
- }
- return 1
- } else {
- if { $x >= $xmax-10 && [$path:cmd index @$xmax] < [$path:cmd index end] } {
- if { $data(afterid) == "" } {
- set data(afterid) [after 100 "Entry::_scroll $path 1 $x $xmax"]
- DropSite::setcursor sb_right_arrow
- }
- return 1
- } else {
- if { $data(afterid) != "" } {
- after cancel $data(afterid)
- set data(afterid) ""
- }
- }
- }
- return 0
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Entry::_scroll
-# ------------------------------------------------------------------------------
-proc Entry::_scroll { path dir x xmax } {
- variable $path
- upvar 0 $path data
-
- $path:cmd xview scroll $dir units
- $path:cmd icursor @$x
- if { ($dir == -1 && [$path:cmd index @0] > 0) ||
- ($dir == 1 && [$path:cmd index @$xmax] < [$path:cmd index end]) } {
- set data(afterid) [after 100 "Entry::_scroll $path $dir $x $xmax"]
- } else {
- set data(afterid) ""
- DropSite::setcursor dot
- }
-}
-
Copied: grass/trunk/lib/external/bwidget/entry.tcl (from rev 35192, grass/trunk/lib/external/bwidget/entry.tcl)
===================================================================
--- grass/trunk/lib/external/bwidget/entry.tcl (rev 0)
+++ grass/trunk/lib/external/bwidget/entry.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,426 @@
+# ------------------------------------------------------------------------------
+# entry.tcl
+# This file is part of Unifix BWidget Toolkit
+# $Id$
+# ------------------------------------------------------------------------------
+# Index of commands:
+# - Entry::create
+# - Entry::configure
+# - Entry::cget
+# - Entry::_destroy
+# - Entry::_init_drag_cmd
+# - Entry::_end_drag_cmd
+# - Entry::_drop_cmd
+# - Entry::_over_cmd
+# - Entry::_auto_scroll
+# - Entry::_scroll
+# ------------------------------------------------------------------------------
+
+namespace eval Entry {
+ Widget::tkinclude Entry entry :cmd \
+ remove {-state -cursor -foreground -textvariable}
+
+ Widget::declare Entry {
+ {-foreground TkResource "" 0 entry}
+ {-disabledforeground TkResource "" 0 button}
+ {-state Enum normal 0 {normal disabled}}
+ {-text String "" 0}
+ {-textvariable String "" 0}
+ {-editable Boolean 1 0}
+ {-command String "" 0}
+ {-relief TkResource "" 0 entry}
+ {-borderwidth TkResource "" 0 entry}
+ {-fg Synonym -foreground}
+ {-bd Synonym -borderwidth}
+ }
+
+ DynamicHelp::include Entry balloon
+ DragSite::include Entry "" 3
+ DropSite::include Entry {
+ TEXT {move {}}
+ FGCOLOR {move {}}
+ BGCOLOR {move {}}
+ COLOR {move {}}
+ }
+
+ foreach event [bind Entry] {
+ bind BwEntry $event [bind Entry $event]
+ }
+ bind BwEntry <Return> {Entry::invoke %W}
+ bind BwEntry <Destroy> {Entry::_destroy %W}
+ bind BwDisabledEntry <Destroy> {Entry::_destroy %W}
+
+ proc ::Entry { path args } { return [eval Entry::create $path $args] }
+ proc use {} {}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Entry::create
+# ------------------------------------------------------------------------------
+proc Entry::create { path args } {
+ variable $path
+ upvar 0 $path data
+
+ Widget::init Entry $path $args
+
+ set data(afterid) ""
+ if { [set varname [Widget::getoption $path -textvariable]] != "" } {
+ set data(varname) $varname
+ } else {
+ set data(varname) Entry::$path\(var\)
+ }
+
+ if { [GlobalVar::exists $data(varname)] } {
+ set curval [GlobalVar::getvar $data(varname)]
+ Widget::setoption $path -text $curval
+ } else {
+ set curval [Widget::getoption $path -text]
+ GlobalVar::setvar $data(varname) $curval
+ }
+
+ eval entry $path [Widget::subcget $path :cmd]
+ uplevel \#0 $path configure -textvariable [list $data(varname)]
+
+ set state [Widget::getoption $path -state]
+ set editable [Widget::getoption $path -editable]
+ if { $editable && ![string compare $state "normal"] } {
+ bindtags $path [list $path BwEntry [winfo toplevel $path] all]
+ $path configure -takefocus 1
+ } else {
+ bindtags $path [list $path BwDisabledEntry [winfo toplevel $path] all]
+ $path configure -takefocus 0
+ }
+ if { $editable == 0 } {
+ $path configure -cursor left_ptr
+ }
+ if { ![string compare $state "disabled"] } {
+ $path configure -foreground [Widget::getoption $path -disabledforeground]
+ }
+
+ DragSite::setdrag $path $path Entry::_init_drag_cmd Entry::_end_drag_cmd 1
+ DropSite::setdrop $path $path Entry::_over_cmd Entry::_drop_cmd 1
+ DynamicHelp::sethelp $path $path 1
+
+ rename $path ::$path:cmd
+ proc ::$path { cmd args } "return \[Entry::_path_command $path \$cmd \$args\]"
+
+ return $path
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Entry::configure
+# ------------------------------------------------------------------------------
+proc Entry::configure { path args } {
+ variable $path
+ upvar 0 $path data
+
+ Widget::setoption $path -text [$path:cmd get]
+
+ set res [Widget::configure $path $args]
+
+ set chstate [Widget::hasChanged $path -state state]
+ set cheditable [Widget::hasChanged $path -editable editable]
+ set chfg [Widget::hasChanged $path -foreground fg]
+ set chdfg [Widget::hasChanged $path -disabledforeground dfg]
+
+ if { $chstate || $cheditable } {
+ set btags [bindtags $path]
+ if { $editable && ![string compare $state "normal"] } {
+ set idx [lsearch $btags BwDisabledEntry]
+ if { $idx != -1 } {
+ bindtags $path [lreplace $btags $idx $idx BwEntry]
+ }
+ $path:cmd configure -takefocus 1
+ } else {
+ set idx [lsearch $btags BwEntry]
+ if { $idx != -1 } {
+ bindtags $path [lreplace $btags $idx $idx BwDisabledEntry]
+ }
+ $path:cmd configure -takefocus 0
+ if { ![string compare [focus] $path] } {
+ focus .
+ }
+ }
+ }
+
+ if { $chstate || $chfg || $chdfg } {
+ if { ![string compare $state "disabled"] } {
+ $path:cmd configure -fg $dfg
+ } else {
+ $path:cmd configure -fg $fg
+ }
+ }
+
+ if { $cheditable } {
+ if { $editable } {
+ $path:cmd configure -cursor xterm
+ } else {
+ $path:cmd configure -cursor left_ptr
+ }
+ }
+
+ if { [Widget::hasChanged $path -textvariable varname] } {
+ if { [string length $varname] } {
+ set data(varname) $varname
+ } else {
+ catch {unset data(var)}
+ set data(varname) Entry::$path\(var\)
+ }
+ if { [GlobalVar::exists $data(varname)] } {
+ set curval [GlobalVar::getvar $data(varname)]
+ Widget::setoption $path -text $curval
+ } else {
+ Widget::hasChanged $path -text curval
+ GlobalVar::setvar $data(varname) $curval
+ }
+ uplevel \#0 $path:cmd configure -textvariable [list $data(varname)]
+ }
+
+ if { [Widget::hasChanged $path -text curval] } {
+ if { [Widget::getoption $path -textvariable] == "" } {
+ GlobalVar::setvar $data(varname) $curval
+ } else {
+ Widget::setoption $path -text [GlobalVar::getvar $data(varname)]
+ }
+ }
+
+ DragSite::setdrag $path $path Entry::_init_drag_cmd Entry::_end_drag_cmd
+ DropSite::setdrop $path $path Entry::_over_cmd Entry::_drop_cmd
+ DynamicHelp::sethelp $path $path
+
+ return $res
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Entry::cget
+# ------------------------------------------------------------------------------
+proc Entry::cget { path option } {
+ Widget::setoption $path -text [$path:cmd get]
+ return [Widget::cget $path $option]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Entry::invoke
+# ------------------------------------------------------------------------------
+proc Entry::invoke { path } {
+ if { [set cmd [Widget::getoption $path -command]] != "" } {
+ uplevel \#0 $cmd
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Entry::_path_command
+# ------------------------------------------------------------------------------
+proc Entry::_path_command { path cmd larg } {
+ if { ![string compare $cmd "configure"] || ![string compare $cmd "cget"] } {
+ return [eval Entry::$cmd $path $larg]
+ } else {
+ return [eval $path:cmd $cmd $larg]
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Entry::_destroy
+# ------------------------------------------------------------------------------
+proc Entry::_destroy { path } {
+ variable $path
+ upvar 0 $path data
+
+ Widget::destroy $path
+ rename $path {}
+ unset data
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Entry::_init_drag_cmd
+# ------------------------------------------------------------------------------
+proc Entry::_init_drag_cmd { path X Y top } {
+ variable $path
+ upvar 0 $path data
+
+ if { [set cmd [Widget::getoption $path -draginitcmd]] != "" } {
+ return [uplevel \#0 $cmd [list $path $X $Y $top]]
+ }
+ set type [Widget::getoption $path -dragtype]
+ if { $type == "" } {
+ set type "TEXT"
+ }
+ if { [set drag [$path get]] != "" } {
+ if { [$path:cmd selection present] } {
+ set idx [$path:cmd index @[expr $X-[winfo rootx $path]]]
+ set sel0 [$path:cmd index sel.first]
+ set sel1 [expr [$path:cmd index sel.last]-1]
+ if { $idx >= $sel0 && $idx <= $sel1 } {
+ set drag [string range $drag $sel0 $sel1]
+ set data(dragstart) $sel0
+ set data(dragend) [expr {$sel1+1}]
+ if { ![Widget::getoption $path -editable] ||
+ [Widget::getoption $path -state] == "disabled" } {
+ return [list $type {copy} $drag]
+ } else {
+ return [list $type {copy move} $drag]
+ }
+ }
+ } else {
+ set data(dragstart) 0
+ set data(dragend) end
+ if { ![Widget::getoption $path -editable] ||
+ [Widget::getoption $path -state] == "disabled" } {
+ return [list $type {copy} $drag]
+ } else {
+ return [list $type {copy move} $drag]
+ }
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Entry::_end_drag_cmd
+# ------------------------------------------------------------------------------
+proc Entry::_end_drag_cmd { path target op type dnddata result } {
+ variable $path
+ upvar 0 $path data
+
+ if { [set cmd [Widget::getoption $path -dragendcmd]] != "" } {
+ return [uplevel \#0 $cmd [list $path $target $op $type $dnddata $result]]
+ }
+ if { $result && $op == "move" && $path != $target } {
+ $path:cmd delete $data(dragstart) $data(dragend)
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Entry::_drop_cmd
+# ------------------------------------------------------------------------------
+proc Entry::_drop_cmd { path source X Y op type dnddata } {
+ variable $path
+ upvar 0 $path data
+
+ if { $data(afterid) != "" } {
+ after cancel $data(afterid)
+ set data(afterid) ""
+ }
+ if { [set cmd [Widget::getoption $path -dropcmd]] != "" } {
+ set idx [$path:cmd index @[expr $X-[winfo rootx $path]]]
+ return [uplevel \#0 $cmd [list $path $source $idx $op $type $dnddata]]
+ }
+ if { $type == "COLOR" || $type == "FGCOLOR" } {
+ configure $path -foreground $dnddata
+ } elseif { $type == "BGCOLOR" } {
+ configure $path -background $dnddata
+ } else {
+ $path:cmd icursor @[expr $X-[winfo rootx $path]]
+ if { $op == "move" && $path == $source } {
+ $path:cmd delete $data(dragstart) $data(dragend)
+ }
+ set sel0 [$path index insert]
+ $path:cmd insert insert $dnddata
+ set sel1 [$path index insert]
+ $path:cmd selection range $sel0 $sel1
+ }
+ return 1
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Entry::_over_cmd
+# ------------------------------------------------------------------------------
+proc Entry::_over_cmd { path source event X Y op type dnddata } {
+ variable $path
+ upvar 0 $path data
+
+ set x [expr $X-[winfo rootx $path]]
+ if { ![string compare $event "leave"] } {
+ if { [string length $data(afterid)] } {
+ after cancel $data(afterid)
+ set data(afterid) ""
+ }
+ } elseif { [_auto_scroll $path $x] } {
+ return 2
+ }
+
+ if { [set cmd [Widget::getoption $path -dropovercmd]] != "" } {
+ set x [expr $X-[winfo rootx $path]]
+ set idx [$path:cmd index @$x]
+ set res [uplevel \#0 $cmd [list $path $source $event $idx $op $type $dnddata]]
+ return $res
+ }
+
+ if { ![string compare $type "COLOR"] ||
+ ![string compare $type "FGCOLOR"] ||
+ ![string compare $type "BGCOLOR"] } {
+ DropSite::setcursor based_arrow_down
+ return 1
+ }
+ if { [Widget::getoption $path -editable] && ![string compare [Widget::getoption $path -state] "normal"] } {
+ if { [string compare $event "leave"] } {
+ $path:cmd selection clear
+ $path:cmd icursor @$x
+ DropSite::setcursor based_arrow_down
+ return 3
+ }
+ }
+ DropSite::setcursor dot
+ return 0
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Entry::_auto_scroll
+# ------------------------------------------------------------------------------
+proc Entry::_auto_scroll { path x } {
+ variable $path
+ upvar 0 $path data
+
+ set xmax [winfo width $path]
+ if { $x <= 10 && [$path:cmd index @0] > 0 } {
+ if { $data(afterid) == "" } {
+ set data(afterid) [after 100 "Entry::_scroll $path -1 $x $xmax"]
+ DropSite::setcursor sb_left_arrow
+ }
+ return 1
+ } else {
+ if { $x >= $xmax-10 && [$path:cmd index @$xmax] < [$path:cmd index end] } {
+ if { $data(afterid) == "" } {
+ set data(afterid) [after 100 "Entry::_scroll $path 1 $x $xmax"]
+ DropSite::setcursor sb_right_arrow
+ }
+ return 1
+ } else {
+ if { $data(afterid) != "" } {
+ after cancel $data(afterid)
+ set data(afterid) ""
+ }
+ }
+ }
+ return 0
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Entry::_scroll
+# ------------------------------------------------------------------------------
+proc Entry::_scroll { path dir x xmax } {
+ variable $path
+ upvar 0 $path data
+
+ $path:cmd xview scroll $dir units
+ $path:cmd icursor @$x
+ if { ($dir == -1 && [$path:cmd index @0] > 0) ||
+ ($dir == 1 && [$path:cmd index @$xmax] < [$path:cmd index end]) } {
+ set data(afterid) [after 100 "Entry::_scroll $path $dir $x $xmax"]
+ } else {
+ set data(afterid) ""
+ DropSite::setcursor dot
+ }
+}
+
Deleted: grass/trunk/lib/external/bwidget/font.tcl
===================================================================
--- grass/trunk/lib/external/bwidget/font.tcl 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/font.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,379 +0,0 @@
-# ------------------------------------------------------------------------------
-# font.tcl
-# This file is part of Unifix BWidget Toolkit
-# ------------------------------------------------------------------------------
-# Index of commands:
-# - SelectFont::create
-# - SelectFont::configure
-# - SelectFont::cget
-# - SelectFont::_draw
-# - SelectFont::_destroy
-# - SelectFont::_modstyle
-# - SelectFont::_update
-# - SelectFont::_getfont
-# - SelectFont::_init
-# ------------------------------------------------------------------------------
-
-namespace eval SelectFont {
- Dialog::use
- LabelFrame::use
- ScrolledWindow::use
-
- Widget::declare SelectFont {
- {-title String "Font selection" 0}
- {-parent String "" 0}
- {-background TkResource "" 0 frame}
-
- {-type Enum dialog 0 {dialog toolbar}}
- {-font TkResource "" 0 label}
- {-command String "" 0}
- {-sampletext String "Sample Text" 0}
- {-bg Synonym -background}
- }
-
- proc ::SelectFont { path args } { return [eval SelectFont::create $path $args] }
- proc use {} {}
-
- variable _families
- variable _styles {bold italic underline overstrike}
- variable _sizes {4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24}
-
- variable _widget
-}
-
-
-# ------------------------------------------------------------------------------
-# Command SelectFont::create
-# ------------------------------------------------------------------------------
-proc SelectFont::create { path args } {
- variable _families
- variable _sizes
- variable _styles
- variable $path
- upvar 0 $path data
-
- if { ![info exists _families] } {
- loadfont
- }
- Widget::init SelectFont "$path#SelectFont" $args
- set bg [Widget::getoption "$path#SelectFont" -background]
- if { [Widget::getoption "$path#SelectFont" -type] == "dialog" } {
- Dialog::create $path -modal local -default 0 -cancel 1 -background $bg \
- -title [Widget::getoption "$path#SelectFont" -title] \
- -parent [Widget::getoption "$path#SelectFont" -parent]
-
- set frame [Dialog::getframe $path]
- set topf [frame $frame.topf -relief flat -borderwidth 0 -background $bg]
-
- set labf1 [LabelFrame::create $topf.labf1 -text "Font" -name font \
- -side top -anchor w -relief flat -background $bg]
- set sw [ScrolledWindow::create [LabelFrame::getframe $labf1].sw \
- -background $bg]
- set lbf [listbox $sw.lb \
- -height 5 -width 25 -exportselection false -selectmode browse]
- ScrolledWindow::setwidget $sw $lbf
- LabelFrame::configure $labf1 -focus $lbf
- eval $lbf insert end $_families
- set script "set SelectFont::$path\(family\) \[%W curselection\]; SelectFont::_update $path"
- bind $lbf <ButtonRelease-1> $script
- bind $lbf <space> $script
- pack $sw -fill both -expand yes
-
- set labf2 [LabelFrame::create $topf.labf2 -text "Size" -name size \
- -side top -anchor w -relief flat -background $bg]
- set sw [ScrolledWindow::create [LabelFrame::getframe $labf2].sw \
- -scrollbar vertical -background $bg]
- set lbs [listbox $sw.lb \
- -height 5 -width 6 -exportselection false -selectmode browse]
- ScrolledWindow::setwidget $sw $lbs
- LabelFrame::configure $labf2 -focus $lbs
- eval $lbs insert end $_sizes
- set script "set SelectFont::$path\(size\) \[%W curselection\]; SelectFont::_update $path"
- bind $lbs <ButtonRelease-1> $script
- bind $lbs <space> $script
- pack $sw -fill both -expand yes
-
- set labf3 [LabelFrame::create $topf.labf3 -text "Style" -name style \
- -side top -anchor w -relief sunken -bd 1 -background $bg]
- set subf [LabelFrame::getframe $labf3]
- foreach st $_styles {
- set name [lindex [BWidget::getname $st] 0]
- if { $name == "" } {
- set name "[string toupper [string index $name 0]][string range $name 1 end]"
- }
- checkbutton $subf.$st -text $name \
- -variable SelectFont::$path\($st\) \
- -background $bg \
- -command "SelectFont::_update $path"
- bind $subf.$st <Return> break
- pack $subf.$st -anchor w
- }
- LabelFrame::configure $labf3 -focus $subf.[lindex $_styles 0]
-
- pack $labf1 -side left -anchor n -fill both -expand yes
- pack $labf2 -side left -anchor n -fill both -expand yes -padx 8
- pack $labf3 -side left -anchor n -fill both -expand yes
-
- set botf [frame $frame.botf -width 100 -height 50 \
- -bg white -bd 0 -relief flat \
- -highlightthickness 1 -takefocus 0 \
- -highlightbackground black \
- -highlightcolor black]
-
- set lab [label $botf.label \
- -background white -foreground black \
- -borderwidth 0 -takefocus 0 -highlightthickness 0 \
- -text [Widget::getoption "$path#SelectFont" -sampletext]]
- place $lab -relx 0.5 -rely 0.5 -anchor c
-
- pack $topf -pady 4 -fill both -expand yes
- pack $botf -pady 4 -fill x
-
- Dialog::add $path -name ok
- Dialog::add $path -name cancel
-
- set data(label) $lab
- set data(lbf) $lbf
- set data(lbs) $lbs
-
- _getfont $path
-
- proc ::$path { cmd args } "return \[eval SelectFont::\$cmd $path \$args\]"
-
- return [_draw $path]
- } else {
- frame $path -relief flat -borderwidth 0 -background $bg
- bind $path <Destroy> "SelectFont::_destroy $path"
- set lbf [ComboBox::create $path.font \
- -highlightthickness 0 -takefocus 0 -background $bg \
- -values $_families \
- -textvariable SelectFont::$path\(family\) \
- -editable 0 \
- -modifycmd "SelectFont::_update $path"]
- set lbs [ComboBox::create $path.size \
- -highlightthickness 0 -takefocus 0 -background $bg \
- -width 4 \
- -values $_sizes \
- -textvariable SelectFont::$path\(size\) \
- -editable 0 \
- -modifycmd "SelectFont::_update $path"]
- pack $lbf -side left -anchor w
- pack $lbs -side left -anchor w -padx 4
- foreach st $_styles {
- button $path.$st \
- -highlightthickness 0 -takefocus 0 -padx 0 -pady 0 -bd 2 \
- -background $bg \
- -image [Bitmap::get $st] \
- -command "SelectFont::_modstyle $path $st"
- pack $path.$st -side left -anchor w
- }
- set data(label) ""
- set data(lbf) $lbf
- set data(lbs) $lbs
- _getfont $path
-
- rename $path ::$path:cmd
- proc ::$path { cmd args } "return \[eval SelectFont::\$cmd $path \$args\]"
- }
-
- return $path
-}
-
-
-# ------------------------------------------------------------------------------
-# Command SelectFont::configure
-# ------------------------------------------------------------------------------
-proc SelectFont::configure { path args } {
- variable _styles
-
- set res [Widget::configure "$path#SelectFont" $args]
-
- if { [Widget::hasChanged "$path#SelectFont" -font font] } {
- _getfont $path
- }
- if { [Widget::hasChanged "$path#SelectFont" -background bg] } {
- switch -- [Widget::getoption "$path#SelectFont" -type] {
- dialog {
- Dialog::configure $path -background $bg
- set topf [Dialog::getframe $path].topf
- $topf configure -background $bg
- foreach labf {labf1 labf2} {
- LabelFrame::configure $topf.$labf -background $bg
- set subf [LabelFrame::getframe $topf.$labf]
- ScrolledWindow::configure $subf.sw -background $bg
- $subf.sw.lb configure -background $bg
- }
- LabelFrame::configure $topf.labf3 -background $bg
- set subf [LabelFrame::getframe $topf.labf3]
- foreach w [winfo children $subf] {
- $w configure -background $bg
- }
- }
- toolbar {
- $path configure -background $bg
- ComboBox::configure $path.font -background $bg
- ComboBox::configure $path.size -background $bg
- foreach st $_styles {
- $path.$st configure -background $bg
- }
- }
- }
- }
- return $res
-}
-
-
-# ------------------------------------------------------------------------------
-# Command SelectFont::cget
-# ------------------------------------------------------------------------------
-proc SelectFont::cget { path option } {
- return [Widget::cget "$path#SelectFont" $option]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command SelectFont::loadfont
-# ------------------------------------------------------------------------------
-proc SelectFont::loadfont { } {
- variable _families
-
- # initialize families
- set _families {}
- set lfont [font families]
- lappend lfont times courier helvetica
- foreach font $lfont {
- set family [font actual [list $font] -family]
- if { [lsearch -exact $_families $family] == -1 } {
- lappend _families $family
- }
- }
- set _families [lsort $_families]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command SelectFont::_draw
-# ------------------------------------------------------------------------------
-proc SelectFont::_draw { path } {
- variable $path
- upvar 0 $path data
-
- $data(lbf) selection clear 0 end
- $data(lbf) selection set $data(family)
- $data(lbf) activate $data(family)
- $data(lbf) see $data(family)
- $data(lbs) selection clear 0 end
- $data(lbs) selection set $data(size)
- $data(lbs) activate $data(size)
- $data(lbs) see $data(size)
- _update $path
-
- if { [Dialog::draw $path] == 0 } {
- set result [Widget::getoption "$path#SelectFont" -font]
- } else {
- set result ""
- }
- unset data
- Widget::destroy "$path#SelectFont"
- destroy $path
- return $result
-}
-
-
-# ------------------------------------------------------------------------------
-# Command SelectFont::_destroy
-# ------------------------------------------------------------------------------
-proc SelectFont::_destroy { path } {
- variable $path
- upvar 0 $path data
-
- unset data
- Widget::destroy "$path#SelectFont"
- rename $path {}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command SelectFont::_modstyle
-# ------------------------------------------------------------------------------
-proc SelectFont::_modstyle { path style } {
- variable $path
- upvar 0 $path data
-
- if { $data($style) == 1 } {
- $path.$style configure -relief raised
- set data($style) 0
- } else {
- $path.$style configure -relief sunken
- set data($style) 1
- }
- _update $path
-}
-
-
-# ------------------------------------------------------------------------------
-# Command SelectFont::_update
-# ------------------------------------------------------------------------------
-proc SelectFont::_update { path } {
- variable _families
- variable _sizes
- variable _styles
- variable $path
- upvar 0 $path data
-
- set type [Widget::getoption "$path#SelectFont" -type]
- if { $type == "dialog" } {
- set curs [$path:cmd cget -cursor]
- $path:cmd configure -cursor watch
- }
- if { [Widget::getoption "$path#SelectFont" -type] == "dialog" } {
- set font [list \
- [lindex $_families $data(family)] \
- [lindex $_sizes $data(size)]]
- } else {
- set font [list $data(family) $data(size)]
- }
- foreach st $_styles {
- if { $data($st) } {
- lappend font $st
- }
- }
- Widget::setoption "$path#SelectFont" -font $font
- if { $type == "dialog" } {
- $data(label) configure -font $font
- $path:cmd configure -cursor $curs
- } elseif { [set cmd [Widget::getoption "$path#SelectFont" -command]] != "" } {
- uplevel \#0 $cmd
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command SelectFont::_getfont
-# ------------------------------------------------------------------------------
-proc SelectFont::_getfont { path } {
- variable _families
- variable _styles
- variable _sizes
- variable $path
- upvar 0 $path data
-
- array set font [font actual [Widget::getoption "$path#SelectFont" -font]]
- set data(bold) [expr {[string compare $font(-weight) "normal"] != 0}]
- set data(italic) [expr {[string compare $font(-slant) "roman"] != 0}]
- set data(underline) $font(-underline)
- set data(overstrike) $font(-overstrike)
- if { [Widget::getoption "$path#SelectFont" -type] == "dialog" } {
- set idxf [lsearch $_families $font(-family)]
- set idxs [lsearch $_sizes $font(-size)]
- set data(family) [expr {$idxf >= 0 ? $idxf : 0}]
- set data(size) [expr {$idxs >= 0 ? $idxs : 0}]
- } else {
- set data(family) $font(-family)
- set data(size) $font(-size)
- foreach st $_styles {
- $path.$st configure -relief [expr {$data($st) ? "sunken":"raised"}]
- }
- }
-}
-
Copied: grass/trunk/lib/external/bwidget/font.tcl (from rev 35192, grass/trunk/lib/external/bwidget/font.tcl)
===================================================================
--- grass/trunk/lib/external/bwidget/font.tcl (rev 0)
+++ grass/trunk/lib/external/bwidget/font.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,379 @@
+# ------------------------------------------------------------------------------
+# font.tcl
+# This file is part of Unifix BWidget Toolkit
+# ------------------------------------------------------------------------------
+# Index of commands:
+# - SelectFont::create
+# - SelectFont::configure
+# - SelectFont::cget
+# - SelectFont::_draw
+# - SelectFont::_destroy
+# - SelectFont::_modstyle
+# - SelectFont::_update
+# - SelectFont::_getfont
+# - SelectFont::_init
+# ------------------------------------------------------------------------------
+
+namespace eval SelectFont {
+ Dialog::use
+ LabelFrame::use
+ ScrolledWindow::use
+
+ Widget::declare SelectFont {
+ {-title String "Font selection" 0}
+ {-parent String "" 0}
+ {-background TkResource "" 0 frame}
+
+ {-type Enum dialog 0 {dialog toolbar}}
+ {-font TkResource "" 0 label}
+ {-command String "" 0}
+ {-sampletext String "Sample Text" 0}
+ {-bg Synonym -background}
+ }
+
+ proc ::SelectFont { path args } { return [eval SelectFont::create $path $args] }
+ proc use {} {}
+
+ variable _families
+ variable _styles {bold italic underline overstrike}
+ variable _sizes {4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24}
+
+ variable _widget
+}
+
+
+# ------------------------------------------------------------------------------
+# Command SelectFont::create
+# ------------------------------------------------------------------------------
+proc SelectFont::create { path args } {
+ variable _families
+ variable _sizes
+ variable _styles
+ variable $path
+ upvar 0 $path data
+
+ if { ![info exists _families] } {
+ loadfont
+ }
+ Widget::init SelectFont "$path#SelectFont" $args
+ set bg [Widget::getoption "$path#SelectFont" -background]
+ if { [Widget::getoption "$path#SelectFont" -type] == "dialog" } {
+ Dialog::create $path -modal local -default 0 -cancel 1 -background $bg \
+ -title [Widget::getoption "$path#SelectFont" -title] \
+ -parent [Widget::getoption "$path#SelectFont" -parent]
+
+ set frame [Dialog::getframe $path]
+ set topf [frame $frame.topf -relief flat -borderwidth 0 -background $bg]
+
+ set labf1 [LabelFrame::create $topf.labf1 -text "Font" -name font \
+ -side top -anchor w -relief flat -background $bg]
+ set sw [ScrolledWindow::create [LabelFrame::getframe $labf1].sw \
+ -background $bg]
+ set lbf [listbox $sw.lb \
+ -height 5 -width 25 -exportselection false -selectmode browse]
+ ScrolledWindow::setwidget $sw $lbf
+ LabelFrame::configure $labf1 -focus $lbf
+ eval $lbf insert end $_families
+ set script "set SelectFont::$path\(family\) \[%W curselection\]; SelectFont::_update $path"
+ bind $lbf <ButtonRelease-1> $script
+ bind $lbf <space> $script
+ pack $sw -fill both -expand yes
+
+ set labf2 [LabelFrame::create $topf.labf2 -text "Size" -name size \
+ -side top -anchor w -relief flat -background $bg]
+ set sw [ScrolledWindow::create [LabelFrame::getframe $labf2].sw \
+ -scrollbar vertical -background $bg]
+ set lbs [listbox $sw.lb \
+ -height 5 -width 6 -exportselection false -selectmode browse]
+ ScrolledWindow::setwidget $sw $lbs
+ LabelFrame::configure $labf2 -focus $lbs
+ eval $lbs insert end $_sizes
+ set script "set SelectFont::$path\(size\) \[%W curselection\]; SelectFont::_update $path"
+ bind $lbs <ButtonRelease-1> $script
+ bind $lbs <space> $script
+ pack $sw -fill both -expand yes
+
+ set labf3 [LabelFrame::create $topf.labf3 -text "Style" -name style \
+ -side top -anchor w -relief sunken -bd 1 -background $bg]
+ set subf [LabelFrame::getframe $labf3]
+ foreach st $_styles {
+ set name [lindex [BWidget::getname $st] 0]
+ if { $name == "" } {
+ set name "[string toupper [string index $name 0]][string range $name 1 end]"
+ }
+ checkbutton $subf.$st -text $name \
+ -variable SelectFont::$path\($st\) \
+ -background $bg \
+ -command "SelectFont::_update $path"
+ bind $subf.$st <Return> break
+ pack $subf.$st -anchor w
+ }
+ LabelFrame::configure $labf3 -focus $subf.[lindex $_styles 0]
+
+ pack $labf1 -side left -anchor n -fill both -expand yes
+ pack $labf2 -side left -anchor n -fill both -expand yes -padx 8
+ pack $labf3 -side left -anchor n -fill both -expand yes
+
+ set botf [frame $frame.botf -width 100 -height 50 \
+ -bg white -bd 0 -relief flat \
+ -highlightthickness 1 -takefocus 0 \
+ -highlightbackground black \
+ -highlightcolor black]
+
+ set lab [label $botf.label \
+ -background white -foreground black \
+ -borderwidth 0 -takefocus 0 -highlightthickness 0 \
+ -text [Widget::getoption "$path#SelectFont" -sampletext]]
+ place $lab -relx 0.5 -rely 0.5 -anchor c
+
+ pack $topf -pady 4 -fill both -expand yes
+ pack $botf -pady 4 -fill x
+
+ Dialog::add $path -name ok
+ Dialog::add $path -name cancel
+
+ set data(label) $lab
+ set data(lbf) $lbf
+ set data(lbs) $lbs
+
+ _getfont $path
+
+ proc ::$path { cmd args } "return \[eval SelectFont::\$cmd $path \$args\]"
+
+ return [_draw $path]
+ } else {
+ frame $path -relief flat -borderwidth 0 -background $bg
+ bind $path <Destroy> "SelectFont::_destroy $path"
+ set lbf [ComboBox::create $path.font \
+ -highlightthickness 0 -takefocus 0 -background $bg \
+ -values $_families \
+ -textvariable SelectFont::$path\(family\) \
+ -editable 0 \
+ -modifycmd "SelectFont::_update $path"]
+ set lbs [ComboBox::create $path.size \
+ -highlightthickness 0 -takefocus 0 -background $bg \
+ -width 4 \
+ -values $_sizes \
+ -textvariable SelectFont::$path\(size\) \
+ -editable 0 \
+ -modifycmd "SelectFont::_update $path"]
+ pack $lbf -side left -anchor w
+ pack $lbs -side left -anchor w -padx 4
+ foreach st $_styles {
+ button $path.$st \
+ -highlightthickness 0 -takefocus 0 -padx 0 -pady 0 -bd 2 \
+ -background $bg \
+ -image [Bitmap::get $st] \
+ -command "SelectFont::_modstyle $path $st"
+ pack $path.$st -side left -anchor w
+ }
+ set data(label) ""
+ set data(lbf) $lbf
+ set data(lbs) $lbs
+ _getfont $path
+
+ rename $path ::$path:cmd
+ proc ::$path { cmd args } "return \[eval SelectFont::\$cmd $path \$args\]"
+ }
+
+ return $path
+}
+
+
+# ------------------------------------------------------------------------------
+# Command SelectFont::configure
+# ------------------------------------------------------------------------------
+proc SelectFont::configure { path args } {
+ variable _styles
+
+ set res [Widget::configure "$path#SelectFont" $args]
+
+ if { [Widget::hasChanged "$path#SelectFont" -font font] } {
+ _getfont $path
+ }
+ if { [Widget::hasChanged "$path#SelectFont" -background bg] } {
+ switch -- [Widget::getoption "$path#SelectFont" -type] {
+ dialog {
+ Dialog::configure $path -background $bg
+ set topf [Dialog::getframe $path].topf
+ $topf configure -background $bg
+ foreach labf {labf1 labf2} {
+ LabelFrame::configure $topf.$labf -background $bg
+ set subf [LabelFrame::getframe $topf.$labf]
+ ScrolledWindow::configure $subf.sw -background $bg
+ $subf.sw.lb configure -background $bg
+ }
+ LabelFrame::configure $topf.labf3 -background $bg
+ set subf [LabelFrame::getframe $topf.labf3]
+ foreach w [winfo children $subf] {
+ $w configure -background $bg
+ }
+ }
+ toolbar {
+ $path configure -background $bg
+ ComboBox::configure $path.font -background $bg
+ ComboBox::configure $path.size -background $bg
+ foreach st $_styles {
+ $path.$st configure -background $bg
+ }
+ }
+ }
+ }
+ return $res
+}
+
+
+# ------------------------------------------------------------------------------
+# Command SelectFont::cget
+# ------------------------------------------------------------------------------
+proc SelectFont::cget { path option } {
+ return [Widget::cget "$path#SelectFont" $option]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command SelectFont::loadfont
+# ------------------------------------------------------------------------------
+proc SelectFont::loadfont { } {
+ variable _families
+
+ # initialize families
+ set _families {}
+ set lfont [font families]
+ lappend lfont times courier helvetica
+ foreach font $lfont {
+ set family [font actual [list $font] -family]
+ if { [lsearch -exact $_families $family] == -1 } {
+ lappend _families $family
+ }
+ }
+ set _families [lsort $_families]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command SelectFont::_draw
+# ------------------------------------------------------------------------------
+proc SelectFont::_draw { path } {
+ variable $path
+ upvar 0 $path data
+
+ $data(lbf) selection clear 0 end
+ $data(lbf) selection set $data(family)
+ $data(lbf) activate $data(family)
+ $data(lbf) see $data(family)
+ $data(lbs) selection clear 0 end
+ $data(lbs) selection set $data(size)
+ $data(lbs) activate $data(size)
+ $data(lbs) see $data(size)
+ _update $path
+
+ if { [Dialog::draw $path] == 0 } {
+ set result [Widget::getoption "$path#SelectFont" -font]
+ } else {
+ set result ""
+ }
+ unset data
+ Widget::destroy "$path#SelectFont"
+ destroy $path
+ return $result
+}
+
+
+# ------------------------------------------------------------------------------
+# Command SelectFont::_destroy
+# ------------------------------------------------------------------------------
+proc SelectFont::_destroy { path } {
+ variable $path
+ upvar 0 $path data
+
+ unset data
+ Widget::destroy "$path#SelectFont"
+ rename $path {}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command SelectFont::_modstyle
+# ------------------------------------------------------------------------------
+proc SelectFont::_modstyle { path style } {
+ variable $path
+ upvar 0 $path data
+
+ if { $data($style) == 1 } {
+ $path.$style configure -relief raised
+ set data($style) 0
+ } else {
+ $path.$style configure -relief sunken
+ set data($style) 1
+ }
+ _update $path
+}
+
+
+# ------------------------------------------------------------------------------
+# Command SelectFont::_update
+# ------------------------------------------------------------------------------
+proc SelectFont::_update { path } {
+ variable _families
+ variable _sizes
+ variable _styles
+ variable $path
+ upvar 0 $path data
+
+ set type [Widget::getoption "$path#SelectFont" -type]
+ if { $type == "dialog" } {
+ set curs [$path:cmd cget -cursor]
+ $path:cmd configure -cursor watch
+ }
+ if { [Widget::getoption "$path#SelectFont" -type] == "dialog" } {
+ set font [list \
+ [lindex $_families $data(family)] \
+ [lindex $_sizes $data(size)]]
+ } else {
+ set font [list $data(family) $data(size)]
+ }
+ foreach st $_styles {
+ if { $data($st) } {
+ lappend font $st
+ }
+ }
+ Widget::setoption "$path#SelectFont" -font $font
+ if { $type == "dialog" } {
+ $data(label) configure -font $font
+ $path:cmd configure -cursor $curs
+ } elseif { [set cmd [Widget::getoption "$path#SelectFont" -command]] != "" } {
+ uplevel \#0 $cmd
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command SelectFont::_getfont
+# ------------------------------------------------------------------------------
+proc SelectFont::_getfont { path } {
+ variable _families
+ variable _styles
+ variable _sizes
+ variable $path
+ upvar 0 $path data
+
+ array set font [font actual [Widget::getoption "$path#SelectFont" -font]]
+ set data(bold) [expr {[string compare $font(-weight) "normal"] != 0}]
+ set data(italic) [expr {[string compare $font(-slant) "roman"] != 0}]
+ set data(underline) $font(-underline)
+ set data(overstrike) $font(-overstrike)
+ if { [Widget::getoption "$path#SelectFont" -type] == "dialog" } {
+ set idxf [lsearch $_families $font(-family)]
+ set idxs [lsearch $_sizes $font(-size)]
+ set data(family) [expr {$idxf >= 0 ? $idxf : 0}]
+ set data(size) [expr {$idxs >= 0 ? $idxs : 0}]
+ } else {
+ set data(family) $font(-family)
+ set data(size) $font(-size)
+ foreach st $_styles {
+ $path.$st configure -relief [expr {$data($st) ? "sunken":"raised"}]
+ }
+ }
+}
+
Copied: grass/trunk/lib/external/bwidget/images (from rev 35192, grass/trunk/lib/external/bwidget/images)
Property changes on: grass/trunk/lib/external/bwidget/images
___________________________________________________________________
Name: svn:ignore
+ *OBJ*
Deleted: grass/trunk/lib/external/bwidget/images/bold.gif
===================================================================
(Binary files differ)
Copied: grass/trunk/lib/external/bwidget/images/bold.gif (from rev 35192, grass/trunk/lib/external/bwidget/images/bold.gif)
===================================================================
(Binary files differ)
Deleted: grass/trunk/lib/external/bwidget/images/copy.gif
===================================================================
(Binary files differ)
Copied: grass/trunk/lib/external/bwidget/images/copy.gif (from rev 35192, grass/trunk/lib/external/bwidget/images/copy.gif)
===================================================================
(Binary files differ)
Deleted: grass/trunk/lib/external/bwidget/images/cut.gif
===================================================================
(Binary files differ)
Copied: grass/trunk/lib/external/bwidget/images/cut.gif (from rev 35192, grass/trunk/lib/external/bwidget/images/cut.gif)
===================================================================
(Binary files differ)
Deleted: grass/trunk/lib/external/bwidget/images/dragfile.gif
===================================================================
(Binary files differ)
Copied: grass/trunk/lib/external/bwidget/images/dragfile.gif (from rev 35192, grass/trunk/lib/external/bwidget/images/dragfile.gif)
===================================================================
(Binary files differ)
Deleted: grass/trunk/lib/external/bwidget/images/dragicon.gif
===================================================================
(Binary files differ)
Copied: grass/trunk/lib/external/bwidget/images/dragicon.gif (from rev 35192, grass/trunk/lib/external/bwidget/images/dragicon.gif)
===================================================================
(Binary files differ)
Deleted: grass/trunk/lib/external/bwidget/images/error.gif
===================================================================
(Binary files differ)
Copied: grass/trunk/lib/external/bwidget/images/error.gif (from rev 35192, grass/trunk/lib/external/bwidget/images/error.gif)
===================================================================
(Binary files differ)
Deleted: grass/trunk/lib/external/bwidget/images/file.gif
===================================================================
(Binary files differ)
Copied: grass/trunk/lib/external/bwidget/images/file.gif (from rev 35192, grass/trunk/lib/external/bwidget/images/file.gif)
===================================================================
(Binary files differ)
Deleted: grass/trunk/lib/external/bwidget/images/folder.gif
===================================================================
(Binary files differ)
Copied: grass/trunk/lib/external/bwidget/images/folder.gif (from rev 35192, grass/trunk/lib/external/bwidget/images/folder.gif)
===================================================================
(Binary files differ)
Deleted: grass/trunk/lib/external/bwidget/images/hourglass.gif
===================================================================
(Binary files differ)
Copied: grass/trunk/lib/external/bwidget/images/hourglass.gif (from rev 35192, grass/trunk/lib/external/bwidget/images/hourglass.gif)
===================================================================
(Binary files differ)
Deleted: grass/trunk/lib/external/bwidget/images/info.gif
===================================================================
(Binary files differ)
Copied: grass/trunk/lib/external/bwidget/images/info.gif (from rev 35192, grass/trunk/lib/external/bwidget/images/info.gif)
===================================================================
(Binary files differ)
Deleted: grass/trunk/lib/external/bwidget/images/italic.gif
===================================================================
(Binary files differ)
Copied: grass/trunk/lib/external/bwidget/images/italic.gif (from rev 35192, grass/trunk/lib/external/bwidget/images/italic.gif)
===================================================================
(Binary files differ)
Deleted: grass/trunk/lib/external/bwidget/images/minus.xbm
===================================================================
--- grass/trunk/lib/external/bwidget/images/minus.xbm 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/images/minus.xbm 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,5 +0,0 @@
-#define minus_width 9
-#define minus_height 9
-static char minus_bits[] = {
- 0xff,0x01,0x01,0x01,0x01,0x01,0x01,0x01,0x7d,0x01,0x01,0x01,0x01,0x01,0x01,
- 0x01,0xff,0x01};
Copied: grass/trunk/lib/external/bwidget/images/minus.xbm (from rev 35192, grass/trunk/lib/external/bwidget/images/minus.xbm)
===================================================================
--- grass/trunk/lib/external/bwidget/images/minus.xbm (rev 0)
+++ grass/trunk/lib/external/bwidget/images/minus.xbm 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,5 @@
+#define minus_width 9
+#define minus_height 9
+static char minus_bits[] = {
+ 0xff,0x01,0x01,0x01,0x01,0x01,0x01,0x01,0x7d,0x01,0x01,0x01,0x01,0x01,0x01,
+ 0x01,0xff,0x01};
Deleted: grass/trunk/lib/external/bwidget/images/new.gif
===================================================================
(Binary files differ)
Copied: grass/trunk/lib/external/bwidget/images/new.gif (from rev 35192, grass/trunk/lib/external/bwidget/images/new.gif)
===================================================================
(Binary files differ)
Deleted: grass/trunk/lib/external/bwidget/images/opcopy.xbm
===================================================================
--- grass/trunk/lib/external/bwidget/images/opcopy.xbm 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/images/opcopy.xbm 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,5 +0,0 @@
-#define opcopy_width 11
-#define opcopy_height 11
-static char opcopy_bits[] = {
- 0xff,0xff,0x01,0xfc,0x21,0xfc,0x21,0xfc,0x21,0xfc,0xfd,0xfd,0x21,0xfc,0x21,
- 0xfc,0x21,0xfc,0x01,0xfc,0xff,0xff};
Copied: grass/trunk/lib/external/bwidget/images/opcopy.xbm (from rev 35192, grass/trunk/lib/external/bwidget/images/opcopy.xbm)
===================================================================
--- grass/trunk/lib/external/bwidget/images/opcopy.xbm (rev 0)
+++ grass/trunk/lib/external/bwidget/images/opcopy.xbm 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,5 @@
+#define opcopy_width 11
+#define opcopy_height 11
+static char opcopy_bits[] = {
+ 0xff,0xff,0x01,0xfc,0x21,0xfc,0x21,0xfc,0x21,0xfc,0xfd,0xfd,0x21,0xfc,0x21,
+ 0xfc,0x21,0xfc,0x01,0xfc,0xff,0xff};
Deleted: grass/trunk/lib/external/bwidget/images/open.gif
===================================================================
(Binary files differ)
Copied: grass/trunk/lib/external/bwidget/images/open.gif (from rev 35192, grass/trunk/lib/external/bwidget/images/open.gif)
===================================================================
(Binary files differ)
Deleted: grass/trunk/lib/external/bwidget/images/openfold.gif
===================================================================
(Binary files differ)
Copied: grass/trunk/lib/external/bwidget/images/openfold.gif (from rev 35192, grass/trunk/lib/external/bwidget/images/openfold.gif)
===================================================================
(Binary files differ)
Deleted: grass/trunk/lib/external/bwidget/images/oplink.xbm
===================================================================
--- grass/trunk/lib/external/bwidget/images/oplink.xbm 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/images/oplink.xbm 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,5 +0,0 @@
-#define oplink_width 11
-#define oplink_height 11
-static char oplink_bits[] = {
- 0xff,0xff,0x01,0xfc,0xf1,0xfc,0xe1,0xfc,0xf1,0xfc,0xb9,0xfc,0x19,0xfc,0x09,
- 0xfc,0x11,0xfc,0x01,0xfc,0xff,0xff};
Copied: grass/trunk/lib/external/bwidget/images/oplink.xbm (from rev 35192, grass/trunk/lib/external/bwidget/images/oplink.xbm)
===================================================================
--- grass/trunk/lib/external/bwidget/images/oplink.xbm (rev 0)
+++ grass/trunk/lib/external/bwidget/images/oplink.xbm 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,5 @@
+#define oplink_width 11
+#define oplink_height 11
+static char oplink_bits[] = {
+ 0xff,0xff,0x01,0xfc,0xf1,0xfc,0xe1,0xfc,0xf1,0xfc,0xb9,0xfc,0x19,0xfc,0x09,
+ 0xfc,0x11,0xfc,0x01,0xfc,0xff,0xff};
Deleted: grass/trunk/lib/external/bwidget/images/opmove.xbm
===================================================================
--- grass/trunk/lib/external/bwidget/images/opmove.xbm 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/images/opmove.xbm 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,5 +0,0 @@
-#define opmove_width 11
-#define opmove_height 11
-static char opmove_bits[] = {
- 0xff,0xff,0x01,0xfc,0x01,0xfc,0x51,0xfc,0x89,0xfc,0xfd,0xfd,0x89,0xfc,0x51,
- 0xfc,0x01,0xfc,0x01,0xfc,0xff,0xff};
Copied: grass/trunk/lib/external/bwidget/images/opmove.xbm (from rev 35192, grass/trunk/lib/external/bwidget/images/opmove.xbm)
===================================================================
--- grass/trunk/lib/external/bwidget/images/opmove.xbm (rev 0)
+++ grass/trunk/lib/external/bwidget/images/opmove.xbm 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,5 @@
+#define opmove_width 11
+#define opmove_height 11
+static char opmove_bits[] = {
+ 0xff,0xff,0x01,0xfc,0x01,0xfc,0x51,0xfc,0x89,0xfc,0xfd,0xfd,0x89,0xfc,0x51,
+ 0xfc,0x01,0xfc,0x01,0xfc,0xff,0xff};
Deleted: grass/trunk/lib/external/bwidget/images/overstrike.gif
===================================================================
(Binary files differ)
Copied: grass/trunk/lib/external/bwidget/images/overstrike.gif (from rev 35192, grass/trunk/lib/external/bwidget/images/overstrike.gif)
===================================================================
(Binary files differ)
Deleted: grass/trunk/lib/external/bwidget/images/palette.gif
===================================================================
(Binary files differ)
Copied: grass/trunk/lib/external/bwidget/images/palette.gif (from rev 35192, grass/trunk/lib/external/bwidget/images/palette.gif)
===================================================================
(Binary files differ)
Deleted: grass/trunk/lib/external/bwidget/images/passwd.gif
===================================================================
(Binary files differ)
Copied: grass/trunk/lib/external/bwidget/images/passwd.gif (from rev 35192, grass/trunk/lib/external/bwidget/images/passwd.gif)
===================================================================
(Binary files differ)
Deleted: grass/trunk/lib/external/bwidget/images/paste.gif
===================================================================
(Binary files differ)
Copied: grass/trunk/lib/external/bwidget/images/paste.gif (from rev 35192, grass/trunk/lib/external/bwidget/images/paste.gif)
===================================================================
(Binary files differ)
Deleted: grass/trunk/lib/external/bwidget/images/plus.xbm
===================================================================
--- grass/trunk/lib/external/bwidget/images/plus.xbm 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/images/plus.xbm 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,5 +0,0 @@
-#define plus_width 9
-#define plus_height 9
-static char plus_bits[] = {
- 0xff,0x01,0x01,0x01,0x11,0x01,0x11,0x01,0x7d,0x01,0x11,0x01,0x11,0x01,0x01,
- 0x01,0xff,0x01};
Copied: grass/trunk/lib/external/bwidget/images/plus.xbm (from rev 35192, grass/trunk/lib/external/bwidget/images/plus.xbm)
===================================================================
--- grass/trunk/lib/external/bwidget/images/plus.xbm (rev 0)
+++ grass/trunk/lib/external/bwidget/images/plus.xbm 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,5 @@
+#define plus_width 9
+#define plus_height 9
+static char plus_bits[] = {
+ 0xff,0x01,0x01,0x01,0x11,0x01,0x11,0x01,0x7d,0x01,0x11,0x01,0x11,0x01,0x01,
+ 0x01,0xff,0x01};
Deleted: grass/trunk/lib/external/bwidget/images/print.gif
===================================================================
(Binary files differ)
Copied: grass/trunk/lib/external/bwidget/images/print.gif (from rev 35192, grass/trunk/lib/external/bwidget/images/print.gif)
===================================================================
(Binary files differ)
Deleted: grass/trunk/lib/external/bwidget/images/question.gif
===================================================================
(Binary files differ)
Copied: grass/trunk/lib/external/bwidget/images/question.gif (from rev 35192, grass/trunk/lib/external/bwidget/images/question.gif)
===================================================================
(Binary files differ)
Deleted: grass/trunk/lib/external/bwidget/images/save.gif
===================================================================
(Binary files differ)
Copied: grass/trunk/lib/external/bwidget/images/save.gif (from rev 35192, grass/trunk/lib/external/bwidget/images/save.gif)
===================================================================
(Binary files differ)
Deleted: grass/trunk/lib/external/bwidget/images/underline.gif
===================================================================
(Binary files differ)
Copied: grass/trunk/lib/external/bwidget/images/underline.gif (from rev 35192, grass/trunk/lib/external/bwidget/images/underline.gif)
===================================================================
(Binary files differ)
Deleted: grass/trunk/lib/external/bwidget/images/undo.gif
===================================================================
(Binary files differ)
Copied: grass/trunk/lib/external/bwidget/images/undo.gif (from rev 35192, grass/trunk/lib/external/bwidget/images/undo.gif)
===================================================================
(Binary files differ)
Deleted: grass/trunk/lib/external/bwidget/images/warning.gif
===================================================================
(Binary files differ)
Copied: grass/trunk/lib/external/bwidget/images/warning.gif (from rev 35192, grass/trunk/lib/external/bwidget/images/warning.gif)
===================================================================
(Binary files differ)
Deleted: grass/trunk/lib/external/bwidget/init.tcl
===================================================================
--- grass/trunk/lib/external/bwidget/init.tcl 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/init.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,21 +0,0 @@
-
-if { $tcl_platform(platform) == "windows" } {
- option add *Listbox.background SystemWindow widgetDefault
- option add *ListBox.background SystemWindow widgetDefault
- option add *Tree.background SystemWindow widgetDefault
- option add *Button.padY 0 widgetDefault
- option add *ButtonBox.padY 0 widgetDefault
- option add *Dialog.padY 0 widgetDefault
- option add *Dialog.anchor e widgetDefault
-} else {
- option add *Scrollbar.width 12 widgetDefault
- option add *Scrollbar.borderWidth 1 widgetDefault
- option add *Dialog.separator 1 widgetDefault
- option add *MainFrame.relief raised widgetDefault
- option add *MainFrame.separator none widgetDefault
-}
-
-option read [file join $env(BWIDGET_LIBRARY) "lang" "en.rc"]
-
-bind all <Key-Tab> {focus [Widget::focusNext %W]}
-bind all <Shift-Key-Tab> {focus [Widget::focusPrev %W]}
Copied: grass/trunk/lib/external/bwidget/init.tcl (from rev 35192, grass/trunk/lib/external/bwidget/init.tcl)
===================================================================
--- grass/trunk/lib/external/bwidget/init.tcl (rev 0)
+++ grass/trunk/lib/external/bwidget/init.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,21 @@
+
+if { $tcl_platform(platform) == "windows" } {
+ option add *Listbox.background SystemWindow widgetDefault
+ option add *ListBox.background SystemWindow widgetDefault
+ option add *Tree.background SystemWindow widgetDefault
+ option add *Button.padY 0 widgetDefault
+ option add *ButtonBox.padY 0 widgetDefault
+ option add *Dialog.padY 0 widgetDefault
+ option add *Dialog.anchor e widgetDefault
+} else {
+ option add *Scrollbar.width 12 widgetDefault
+ option add *Scrollbar.borderWidth 1 widgetDefault
+ option add *Dialog.separator 1 widgetDefault
+ option add *MainFrame.relief raised widgetDefault
+ option add *MainFrame.separator none widgetDefault
+}
+
+option read [file join $env(BWIDGET_LIBRARY) "lang" "en.rc"]
+
+bind all <Key-Tab> {focus [Widget::focusNext %W]}
+bind all <Shift-Key-Tab> {focus [Widget::focusPrev %W]}
Deleted: grass/trunk/lib/external/bwidget/label.tcl
===================================================================
--- grass/trunk/lib/external/bwidget/label.tcl 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/label.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,258 +0,0 @@
-# ------------------------------------------------------------------------------
-# label.tcl
-# This file is part of Unifix BWidget Toolkit
-# $Id$
-# ------------------------------------------------------------------------------
-# Index of commands:
-# - Label::create
-# - Label::configure
-# - Label::cget
-# - Label::setfocus
-# - Label::_drag_cmd
-# - Label::_drop_cmd
-# - Label::_over_cmd
-# ------------------------------------------------------------------------------
-
-namespace eval Label {
- Widget::tkinclude Label label :cmd \
- remove {-foreground -text -textvariable -underline}
-
- Widget::declare Label {
- {-name String "" 0}
- {-text String "" 0}
- {-textvariable String "" 0}
- {-underline Int -1 0 {=-1}}
- {-focus String "" 0}
- {-foreground TkResource "" 0 label}
- {-disabledforeground TkResource "" 0 button}
- {-state Enum normal 0 {normal disabled}}
- {-fg Synonym -foreground}
-
- }
- DynamicHelp::include Label balloon
- DragSite::include Label "" 1
- DropSite::include Label {
- TEXT {move {}}
- IMAGE {move {}}
- BITMAP {move {}}
- FGCOLOR {move {}}
- BGCOLOR {move {}}
- COLOR {move {}}
- }
-
- Widget::syncoptions Label "" :cmd {-text {} -underline {}}
-
- proc ::Label { path args } { return [eval Label::create $path $args] }
- proc use {} {}
-
- bind BwLabel <FocusIn> {Label::setfocus %W}
- bind BwLabel <Destroy> {Widget::destroy %W; rename %W {}}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Label::create
-# ------------------------------------------------------------------------------
-proc Label::create { path args } {
- Widget::init Label $path $args
-
- if { [Widget::getoption $path -state] == "normal" } {
- set fg [Widget::getoption $path -foreground]
- } else {
- set fg [Widget::getoption $path -disabledforeground]
- }
-
- set var [Widget::getoption $path -textvariable]
- if { $var == "" &&
- [Widget::getoption $path -image] == "" &&
- [Widget::getoption $path -bitmap] == ""} {
- set desc [BWidget::getname [Widget::getoption $path -name]]
- if { $desc != "" } {
- set text [lindex $desc 0]
- set under [lindex $desc 1]
- } else {
- set text [Widget::getoption $path -text]
- set under [Widget::getoption $path -underline]
- }
- } else {
- set under -1
- set text ""
- }
-
- eval label $path [Widget::subcget $path :cmd] \
- [list -text $text -textvariable $var -underline $under -foreground $fg]
-
- set accel [string tolower [string index $text $under]]
- if { $accel != "" } {
- bind [winfo toplevel $path] <Alt-$accel> "Label::setfocus $path"
- }
-
- bindtags $path [list $path Label BwLabel [winfo toplevel $path] all]
-
- DragSite::setdrag $path $path Label::_init_drag_cmd [Widget::getoption $path -dragendcmd] 1
- DropSite::setdrop $path $path Label::_over_cmd Label::_drop_cmd 1
- DynamicHelp::sethelp $path $path 1
-
- rename $path ::$path:cmd
- proc ::$path { cmd args } "return \[eval Label::\$cmd $path \$args\]"
-
- return $path
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Label::configure
-# ------------------------------------------------------------------------------
-proc Label::configure { path args } {
- set oldunder [$path:cmd cget -underline]
- if { $oldunder != -1 } {
- set oldaccel [string tolower [string index [$path:cmd cget -text] $oldunder]]
- } else {
- set oldaccel ""
- }
- set res [Widget::configure $path $args]
-
- set cfg [Widget::hasChanged $path -foreground fg]
- set cdfg [Widget::hasChanged $path -disabledforeground dfg]
- set cst [Widget::hasChanged $path -state state]
-
- if { $cst || $cfg || $cdfg } {
- if { $state == "normal" } {
- $path:cmd configure -fg $fg
- } else {
- $path:cmd configure -fg $dfg
- }
- }
-
- set cv [Widget::hasChanged $path -textvariable var]
- set cb [Widget::hasChanged $path -image img]
- set ci [Widget::hasChanged $path -bitmap bmp]
- set cn [Widget::hasChanged $path -name name]
- set ct [Widget::hasChanged $path -text text]
- set cu [Widget::hasChanged $path -underline under]
-
- if { $cv || $cb || $ci || $cn || $ct || $cu } {
- if { $var == "" && $img == "" && $bmp == "" } {
- set desc [BWidget::getname $name]
- if { $desc != "" } {
- set text [lindex $desc 0]
- set under [lindex $desc 1]
- }
- } else {
- set under -1
- set text ""
- }
- set top [winfo toplevel $path]
- if { $oldaccel != "" } {
- bind $top <Alt-$oldaccel> {}
- }
- set accel [string tolower [string index $text $under]]
- if { $accel != "" } {
- bind $top <Alt-$accel> "Label::setfocus $path"
- }
- $path:cmd configure -text $text -underline $under -textvariable $var
- }
-
- set force [Widget::hasChanged $path -dragendcmd dragend]
- DragSite::setdrag $path $path Label::_init_drag_cmd $dragend $force
- DropSite::setdrop $path $path Label::_over_cmd Label::_drop_cmd
- DynamicHelp::sethelp $path $path
-
- return $res
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Label::cget
-# ------------------------------------------------------------------------------
-proc Label::cget { path option } {
- return [Widget::cget $path $option]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Label::setfocus
-# ------------------------------------------------------------------------------
-proc Label::setfocus { path } {
- if { ![string compare [Widget::getoption $path -state] "normal"] } {
- set w [Widget::getoption $path -focus]
- if { [winfo exists $w] && [Widget::focusOK $w] } {
- focus $w
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Label::_init_drag_cmd
-# ------------------------------------------------------------------------------
-proc Label::_init_drag_cmd { path X Y top } {
- if { [set cmd [Widget::getoption $path -draginitcmd]] != "" } {
- return [uplevel \#0 $cmd [list $path $X $Y $top]]
- }
- if { [set data [$path:cmd cget -image]] != "" } {
- set type "IMAGE"
- pack [label $top.l -image $data]
- } elseif { [set data [$path:cmd cget -bitmap]] != "" } {
- set type "BITMAP"
- pack [label $top.l -bitmap $data]
- } else {
- set data [$path:cmd cget -text]
- set type "TEXT"
- }
- set usertype [Widget::getoption $path -dragtype]
- if { $usertype != "" } {
- set type $usertype
- }
- return [list $type {copy} $data]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Label::_drop_cmd
-# ------------------------------------------------------------------------------
-proc Label::_drop_cmd { path source X Y op type data } {
- if { [set cmd [Widget::getoption $path -dropcmd]] != "" } {
- return [uplevel \#0 $cmd [list $path $source $X $Y $op $type $data]]
- }
- if { $type == "COLOR" || $type == "FGCOLOR" } {
- configure $path -foreground $data
- } elseif { $type == "BGCOLOR" } {
- configure $path -background $data
- } else {
- set text ""
- set image ""
- set bitmap ""
- switch -- $type {
- IMAGE {set image $data}
- BITMAP {set bitmap $data}
- default {
- set text $data
- if { [set var [$path:cmd cget -textvariable]] != "" } {
- configure $path -image "" -bitmap ""
- GlobalVar::setvar $var $data
- return
- }
- }
- }
- configure $path -text $text -image $image -bitmap $bitmap
- }
- return 1
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Label::_over_cmd
-# ------------------------------------------------------------------------------
-proc Label::_over_cmd { path source event X Y op type data } {
- if { [set cmd [Widget::getoption $path -dropovercmd]] != "" } {
- return [uplevel \#0 $cmd [list $path $source $event $X $Y $op $type $data]]
- }
- if { [Widget::getoption $path -state] == "normal" ||
- $type == "COLOR" || $type == "FGCOLOR" || $type == "BGCOLOR" } {
- DropSite::setcursor based_arrow_down
- return 1
- }
- DropSite::setcursor dot
- return 0
-}
Copied: grass/trunk/lib/external/bwidget/label.tcl (from rev 35192, grass/trunk/lib/external/bwidget/label.tcl)
===================================================================
--- grass/trunk/lib/external/bwidget/label.tcl (rev 0)
+++ grass/trunk/lib/external/bwidget/label.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,258 @@
+# ------------------------------------------------------------------------------
+# label.tcl
+# This file is part of Unifix BWidget Toolkit
+# $Id$
+# ------------------------------------------------------------------------------
+# Index of commands:
+# - Label::create
+# - Label::configure
+# - Label::cget
+# - Label::setfocus
+# - Label::_drag_cmd
+# - Label::_drop_cmd
+# - Label::_over_cmd
+# ------------------------------------------------------------------------------
+
+namespace eval Label {
+ Widget::tkinclude Label label :cmd \
+ remove {-foreground -text -textvariable -underline}
+
+ Widget::declare Label {
+ {-name String "" 0}
+ {-text String "" 0}
+ {-textvariable String "" 0}
+ {-underline Int -1 0 {=-1}}
+ {-focus String "" 0}
+ {-foreground TkResource "" 0 label}
+ {-disabledforeground TkResource "" 0 button}
+ {-state Enum normal 0 {normal disabled}}
+ {-fg Synonym -foreground}
+
+ }
+ DynamicHelp::include Label balloon
+ DragSite::include Label "" 1
+ DropSite::include Label {
+ TEXT {move {}}
+ IMAGE {move {}}
+ BITMAP {move {}}
+ FGCOLOR {move {}}
+ BGCOLOR {move {}}
+ COLOR {move {}}
+ }
+
+ Widget::syncoptions Label "" :cmd {-text {} -underline {}}
+
+ proc ::Label { path args } { return [eval Label::create $path $args] }
+ proc use {} {}
+
+ bind BwLabel <FocusIn> {Label::setfocus %W}
+ bind BwLabel <Destroy> {Widget::destroy %W; rename %W {}}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Label::create
+# ------------------------------------------------------------------------------
+proc Label::create { path args } {
+ Widget::init Label $path $args
+
+ if { [Widget::getoption $path -state] == "normal" } {
+ set fg [Widget::getoption $path -foreground]
+ } else {
+ set fg [Widget::getoption $path -disabledforeground]
+ }
+
+ set var [Widget::getoption $path -textvariable]
+ if { $var == "" &&
+ [Widget::getoption $path -image] == "" &&
+ [Widget::getoption $path -bitmap] == ""} {
+ set desc [BWidget::getname [Widget::getoption $path -name]]
+ if { $desc != "" } {
+ set text [lindex $desc 0]
+ set under [lindex $desc 1]
+ } else {
+ set text [Widget::getoption $path -text]
+ set under [Widget::getoption $path -underline]
+ }
+ } else {
+ set under -1
+ set text ""
+ }
+
+ eval label $path [Widget::subcget $path :cmd] \
+ [list -text $text -textvariable $var -underline $under -foreground $fg]
+
+ set accel [string tolower [string index $text $under]]
+ if { $accel != "" } {
+ bind [winfo toplevel $path] <Alt-$accel> "Label::setfocus $path"
+ }
+
+ bindtags $path [list $path Label BwLabel [winfo toplevel $path] all]
+
+ DragSite::setdrag $path $path Label::_init_drag_cmd [Widget::getoption $path -dragendcmd] 1
+ DropSite::setdrop $path $path Label::_over_cmd Label::_drop_cmd 1
+ DynamicHelp::sethelp $path $path 1
+
+ rename $path ::$path:cmd
+ proc ::$path { cmd args } "return \[eval Label::\$cmd $path \$args\]"
+
+ return $path
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Label::configure
+# ------------------------------------------------------------------------------
+proc Label::configure { path args } {
+ set oldunder [$path:cmd cget -underline]
+ if { $oldunder != -1 } {
+ set oldaccel [string tolower [string index [$path:cmd cget -text] $oldunder]]
+ } else {
+ set oldaccel ""
+ }
+ set res [Widget::configure $path $args]
+
+ set cfg [Widget::hasChanged $path -foreground fg]
+ set cdfg [Widget::hasChanged $path -disabledforeground dfg]
+ set cst [Widget::hasChanged $path -state state]
+
+ if { $cst || $cfg || $cdfg } {
+ if { $state == "normal" } {
+ $path:cmd configure -fg $fg
+ } else {
+ $path:cmd configure -fg $dfg
+ }
+ }
+
+ set cv [Widget::hasChanged $path -textvariable var]
+ set cb [Widget::hasChanged $path -image img]
+ set ci [Widget::hasChanged $path -bitmap bmp]
+ set cn [Widget::hasChanged $path -name name]
+ set ct [Widget::hasChanged $path -text text]
+ set cu [Widget::hasChanged $path -underline under]
+
+ if { $cv || $cb || $ci || $cn || $ct || $cu } {
+ if { $var == "" && $img == "" && $bmp == "" } {
+ set desc [BWidget::getname $name]
+ if { $desc != "" } {
+ set text [lindex $desc 0]
+ set under [lindex $desc 1]
+ }
+ } else {
+ set under -1
+ set text ""
+ }
+ set top [winfo toplevel $path]
+ if { $oldaccel != "" } {
+ bind $top <Alt-$oldaccel> {}
+ }
+ set accel [string tolower [string index $text $under]]
+ if { $accel != "" } {
+ bind $top <Alt-$accel> "Label::setfocus $path"
+ }
+ $path:cmd configure -text $text -underline $under -textvariable $var
+ }
+
+ set force [Widget::hasChanged $path -dragendcmd dragend]
+ DragSite::setdrag $path $path Label::_init_drag_cmd $dragend $force
+ DropSite::setdrop $path $path Label::_over_cmd Label::_drop_cmd
+ DynamicHelp::sethelp $path $path
+
+ return $res
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Label::cget
+# ------------------------------------------------------------------------------
+proc Label::cget { path option } {
+ return [Widget::cget $path $option]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Label::setfocus
+# ------------------------------------------------------------------------------
+proc Label::setfocus { path } {
+ if { ![string compare [Widget::getoption $path -state] "normal"] } {
+ set w [Widget::getoption $path -focus]
+ if { [winfo exists $w] && [Widget::focusOK $w] } {
+ focus $w
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Label::_init_drag_cmd
+# ------------------------------------------------------------------------------
+proc Label::_init_drag_cmd { path X Y top } {
+ if { [set cmd [Widget::getoption $path -draginitcmd]] != "" } {
+ return [uplevel \#0 $cmd [list $path $X $Y $top]]
+ }
+ if { [set data [$path:cmd cget -image]] != "" } {
+ set type "IMAGE"
+ pack [label $top.l -image $data]
+ } elseif { [set data [$path:cmd cget -bitmap]] != "" } {
+ set type "BITMAP"
+ pack [label $top.l -bitmap $data]
+ } else {
+ set data [$path:cmd cget -text]
+ set type "TEXT"
+ }
+ set usertype [Widget::getoption $path -dragtype]
+ if { $usertype != "" } {
+ set type $usertype
+ }
+ return [list $type {copy} $data]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Label::_drop_cmd
+# ------------------------------------------------------------------------------
+proc Label::_drop_cmd { path source X Y op type data } {
+ if { [set cmd [Widget::getoption $path -dropcmd]] != "" } {
+ return [uplevel \#0 $cmd [list $path $source $X $Y $op $type $data]]
+ }
+ if { $type == "COLOR" || $type == "FGCOLOR" } {
+ configure $path -foreground $data
+ } elseif { $type == "BGCOLOR" } {
+ configure $path -background $data
+ } else {
+ set text ""
+ set image ""
+ set bitmap ""
+ switch -- $type {
+ IMAGE {set image $data}
+ BITMAP {set bitmap $data}
+ default {
+ set text $data
+ if { [set var [$path:cmd cget -textvariable]] != "" } {
+ configure $path -image "" -bitmap ""
+ GlobalVar::setvar $var $data
+ return
+ }
+ }
+ }
+ configure $path -text $text -image $image -bitmap $bitmap
+ }
+ return 1
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Label::_over_cmd
+# ------------------------------------------------------------------------------
+proc Label::_over_cmd { path source event X Y op type data } {
+ if { [set cmd [Widget::getoption $path -dropovercmd]] != "" } {
+ return [uplevel \#0 $cmd [list $path $source $event $X $Y $op $type $data]]
+ }
+ if { [Widget::getoption $path -state] == "normal" ||
+ $type == "COLOR" || $type == "FGCOLOR" || $type == "BGCOLOR" } {
+ DropSite::setcursor based_arrow_down
+ return 1
+ }
+ DropSite::setcursor dot
+ return 0
+}
Deleted: grass/trunk/lib/external/bwidget/labelentry.tcl
===================================================================
--- grass/trunk/lib/external/bwidget/labelentry.tcl 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/labelentry.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,100 +0,0 @@
-# ------------------------------------------------------------------------------
-# labelentry.tcl
-# This file is part of Unifix BWidget Toolkit
-# $Id$
-# ------------------------------------------------------------------------------
-# Index of commands:
-# - LabelEntry::create
-# - LabelEntry::configure
-# - LabelEntry::cget
-# - LabelEntry::bind
-# ------------------------------------------------------------------------------
-
-namespace eval LabelEntry {
- Entry::use
- LabelFrame::use
-
- Widget::bwinclude LabelEntry LabelFrame .labf \
- remove {-relief -borderwidth -focus} \
- rename {-text -label} \
- prefix {label -justify -width -anchor -height -font} \
-
- Widget::bwinclude LabelEntry Entry .e \
- remove {-fg -bg} \
- rename {-foreground -entryfg -background -entrybg}
-
- Widget::addmap LabelEntry "" :cmd {-background {}}
-
- Widget::syncoptions LabelEntry Entry .e {-text {}}
- Widget::syncoptions LabelEntry LabelFrame .labf {-label -text -underline {}}
-
- ::bind BwLabelEntry <FocusIn> {focus %W.labf}
- ::bind BwLabelEntry <Destroy> {Widget::destroy %W; rename %W {}}
-
- proc ::LabelEntry { path args } { return [eval LabelEntry::create $path $args] }
- proc use { } {}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command LabelEntry::create
-# ------------------------------------------------------------------------------
-proc LabelEntry::create { path args } {
- Widget::init LabelEntry $path $args
-
- eval frame $path [Widget::subcget $path :cmd] \
- -relief flat -bd 0 -highlightthickness 0 -takefocus 0
-
- set labf [eval LabelFrame::create $path.labf [Widget::subcget $path .labf] \
- -relief flat -borderwidth 0 -focus $path.e]
- set subf [LabelFrame::getframe $labf]
- set entry [eval Entry::create $path.e [Widget::subcget $path .e]]
-
- pack $entry -in $subf -fill both -expand yes
- pack $labf -fill both -expand yes
-
- bindtags $path [list $path BwLabelEntry [winfo toplevel $path] all]
-
- rename $path ::$path:cmd
- proc ::$path { cmd args } "return \[LabelEntry::_path_command $path \$cmd \$args\]"
-
- return $path
-}
-
-
-# ------------------------------------------------------------------------------
-# Command LabelEntry::configure
-# ------------------------------------------------------------------------------
-proc LabelEntry::configure { path args } {
- return [Widget::configure $path $args]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command LabelEntry::cget
-# ------------------------------------------------------------------------------
-proc LabelEntry::cget { path option } {
- return [Widget::cget $path $option]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command LabelEntry::bind
-# ------------------------------------------------------------------------------
-proc LabelEntry::bind { path args } {
- return [eval ::bind $path.e $args]
-}
-
-
-#------------------------------------------------------------------------------
-# Command LabelEntry::_path_command
-#------------------------------------------------------------------------------
-proc LabelEntry::_path_command { path cmd larg } {
- if { ![string compare $cmd "configure"] ||
- ![string compare $cmd "cget"] ||
- ![string compare $cmd "bind"] } {
- return [eval LabelEntry::$cmd $path $larg]
- } else {
- return [eval $path.e:cmd $cmd $larg]
- }
-}
Copied: grass/trunk/lib/external/bwidget/labelentry.tcl (from rev 35192, grass/trunk/lib/external/bwidget/labelentry.tcl)
===================================================================
--- grass/trunk/lib/external/bwidget/labelentry.tcl (rev 0)
+++ grass/trunk/lib/external/bwidget/labelentry.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,100 @@
+# ------------------------------------------------------------------------------
+# labelentry.tcl
+# This file is part of Unifix BWidget Toolkit
+# $Id$
+# ------------------------------------------------------------------------------
+# Index of commands:
+# - LabelEntry::create
+# - LabelEntry::configure
+# - LabelEntry::cget
+# - LabelEntry::bind
+# ------------------------------------------------------------------------------
+
+namespace eval LabelEntry {
+ Entry::use
+ LabelFrame::use
+
+ Widget::bwinclude LabelEntry LabelFrame .labf \
+ remove {-relief -borderwidth -focus} \
+ rename {-text -label} \
+ prefix {label -justify -width -anchor -height -font} \
+
+ Widget::bwinclude LabelEntry Entry .e \
+ remove {-fg -bg} \
+ rename {-foreground -entryfg -background -entrybg}
+
+ Widget::addmap LabelEntry "" :cmd {-background {}}
+
+ Widget::syncoptions LabelEntry Entry .e {-text {}}
+ Widget::syncoptions LabelEntry LabelFrame .labf {-label -text -underline {}}
+
+ ::bind BwLabelEntry <FocusIn> {focus %W.labf}
+ ::bind BwLabelEntry <Destroy> {Widget::destroy %W; rename %W {}}
+
+ proc ::LabelEntry { path args } { return [eval LabelEntry::create $path $args] }
+ proc use { } {}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command LabelEntry::create
+# ------------------------------------------------------------------------------
+proc LabelEntry::create { path args } {
+ Widget::init LabelEntry $path $args
+
+ eval frame $path [Widget::subcget $path :cmd] \
+ -relief flat -bd 0 -highlightthickness 0 -takefocus 0
+
+ set labf [eval LabelFrame::create $path.labf [Widget::subcget $path .labf] \
+ -relief flat -borderwidth 0 -focus $path.e]
+ set subf [LabelFrame::getframe $labf]
+ set entry [eval Entry::create $path.e [Widget::subcget $path .e]]
+
+ pack $entry -in $subf -fill both -expand yes
+ pack $labf -fill both -expand yes
+
+ bindtags $path [list $path BwLabelEntry [winfo toplevel $path] all]
+
+ rename $path ::$path:cmd
+ proc ::$path { cmd args } "return \[LabelEntry::_path_command $path \$cmd \$args\]"
+
+ return $path
+}
+
+
+# ------------------------------------------------------------------------------
+# Command LabelEntry::configure
+# ------------------------------------------------------------------------------
+proc LabelEntry::configure { path args } {
+ return [Widget::configure $path $args]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command LabelEntry::cget
+# ------------------------------------------------------------------------------
+proc LabelEntry::cget { path option } {
+ return [Widget::cget $path $option]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command LabelEntry::bind
+# ------------------------------------------------------------------------------
+proc LabelEntry::bind { path args } {
+ return [eval ::bind $path.e $args]
+}
+
+
+#------------------------------------------------------------------------------
+# Command LabelEntry::_path_command
+#------------------------------------------------------------------------------
+proc LabelEntry::_path_command { path cmd larg } {
+ if { ![string compare $cmd "configure"] ||
+ ![string compare $cmd "cget"] ||
+ ![string compare $cmd "bind"] } {
+ return [eval LabelEntry::$cmd $path $larg]
+ } else {
+ return [eval $path.e:cmd $cmd $larg]
+ }
+}
Deleted: grass/trunk/lib/external/bwidget/labelframe.tcl
===================================================================
--- grass/trunk/lib/external/bwidget/labelframe.tcl 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/labelframe.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,160 +0,0 @@
-# ------------------------------------------------------------------------------
-# labelframe.tcl
-# This file is part of Unifix BWidget Toolkit
-# $Id$
-# ------------------------------------------------------------------------------
-# Index of commands:
-# - LabelFrame::create
-# - LabelFrame::getframe
-# - LabelFrame::configure
-# - LabelFrame::cget
-# - LabelFrame::align
-# ------------------------------------------------------------------------------
-
-namespace eval LabelFrame {
- Label::use
-
- Widget::bwinclude LabelFrame Label .l \
- remove {
- -highlightthickness -highlightcolor -highlightbackground
- -takefocus -relief -borderwidth
- -bitmap -image -cursor -textvariable
- -dragenabled -draginitcmd -dragendcmd -dragevent -dragtype
- -dropenabled -droptypes -dropovercmd -dropcmd} \
- initialize {-anchor w}
-
- Widget::declare LabelFrame {
- {-relief TkResource flat 0 frame}
- {-borderwidth TkResource 0 0 frame}
- {-side Enum left 1 {left right top bottom}}
- {-bd Synonym -borderwidth}
- }
-
- Widget::addmap LabelFrame "" :cmd {-background {}}
- Widget::addmap LabelFrame "" .f {-background {} -relief {} -borderwidth {}}
-
- Widget::syncoptions LabelFrame Label .l {-text {} -underline {}}
-
- bind BwLabelFrame <FocusIn> {Label::setfocus %W.l}
- bind BwLabelFrame <Destroy> {Widget::destroy %W; rename %W {}}
-
- proc ::LabelFrame { path args } { return [eval LabelFrame::create $path $args] }
- proc use {} {}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command LabelFrame::create
-# ------------------------------------------------------------------------------
-proc LabelFrame::create { path args } {
- Widget::init LabelFrame $path $args
-
- set path [frame $path -background [Widget::getoption $path -background] \
- -relief flat -bd 0 -takefocus 0 -highlightthickness 0]
-
- set label [eval Label::create $path.l [Widget::subcget $path .l] \
- -takefocus 0 -highlightthickness 0 -relief flat -borderwidth 0 \
- -dropenabled 0 -dragenabled 0]
- set frame [eval frame $path.f [Widget::subcget $path .f] \
- -highlightthickness 0 -takefocus 0]
-
- switch [Widget::getoption $path -side] {
- left {set packopt "-side left"}
- right {set packopt "-side right"}
- top {set packopt "-side top -fill x"}
- bottom {set packopt "-side bottom -fill x"}
- }
-
- eval pack $label $packopt
- pack $frame -fill both -expand yes
-
- bindtags $path [list $path BwLabelFrame [winfo toplevel $path] all]
-
- rename $path ::$path:cmd
- proc ::$path { cmd args } "return \[eval LabelFrame::\$cmd $path \$args\]"
-
- return $path
-}
-
-
-# ------------------------------------------------------------------------------
-# Command LabelFrame::getframe
-# ------------------------------------------------------------------------------
-proc LabelFrame::getframe { path } {
- return $path.f
-}
-
-
-# ------------------------------------------------------------------------------
-# Command LabelFrame::configure
-# ------------------------------------------------------------------------------
-proc LabelFrame::configure { path args } {
- return [Widget::configure $path $args]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command LabelFrame::cget
-# ------------------------------------------------------------------------------
-proc LabelFrame::cget { path option } {
- return [Widget::cget $path $option]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command LabelFrame::align
-# This command align label of all widget given by args of class LabelFrame
-# (or "derived") by setting their width to the max one +1
-# ------------------------------------------------------------------------------
-proc LabelFrame::align { args } {
- set maxlen 0
- set wlist {}
- foreach wl $args {
- foreach w $wl {
- if { ![info exists Widget::_class($w)] } {
- continue
- }
- set class $Widget::_class($w)
- if { ![string compare $class "LabelFrame"] } {
- set textopt -text
- set widthopt -width
- } else {
- upvar 0 Widget::${class}::map classmap
- set textopt ""
- set widthopt ""
- set notdone 2
- foreach {option lmap} [array get classmap] {
- foreach {subpath subclass realopt} $lmap {
- if { ![string compare $subclass "LabelFrame"] } {
- if { ![string compare $realopt "-text"] } {
- set textopt $option
- incr notdone -1
- break
- }
- if { ![string compare $realopt "-width"] } {
- set widthopt $option
- incr notdone -1
- break
- }
- }
- }
- if { !$notdone } {
- break
- }
- }
- if { $notdone } {
- continue
- }
- }
- set len [string length [$w cget $textopt]]
- if { $len > $maxlen } {
- set maxlen $len
- }
- lappend wlist $w $widthopt
- }
- }
- incr maxlen
- foreach {w widthopt} $wlist {
- $w configure $widthopt $maxlen
- }
-}
Copied: grass/trunk/lib/external/bwidget/labelframe.tcl (from rev 35192, grass/trunk/lib/external/bwidget/labelframe.tcl)
===================================================================
--- grass/trunk/lib/external/bwidget/labelframe.tcl (rev 0)
+++ grass/trunk/lib/external/bwidget/labelframe.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,160 @@
+# ------------------------------------------------------------------------------
+# labelframe.tcl
+# This file is part of Unifix BWidget Toolkit
+# $Id$
+# ------------------------------------------------------------------------------
+# Index of commands:
+# - LabelFrame::create
+# - LabelFrame::getframe
+# - LabelFrame::configure
+# - LabelFrame::cget
+# - LabelFrame::align
+# ------------------------------------------------------------------------------
+
+namespace eval LabelFrame {
+ Label::use
+
+ Widget::bwinclude LabelFrame Label .l \
+ remove {
+ -highlightthickness -highlightcolor -highlightbackground
+ -takefocus -relief -borderwidth
+ -bitmap -image -cursor -textvariable
+ -dragenabled -draginitcmd -dragendcmd -dragevent -dragtype
+ -dropenabled -droptypes -dropovercmd -dropcmd} \
+ initialize {-anchor w}
+
+ Widget::declare LabelFrame {
+ {-relief TkResource flat 0 frame}
+ {-borderwidth TkResource 0 0 frame}
+ {-side Enum left 1 {left right top bottom}}
+ {-bd Synonym -borderwidth}
+ }
+
+ Widget::addmap LabelFrame "" :cmd {-background {}}
+ Widget::addmap LabelFrame "" .f {-background {} -relief {} -borderwidth {}}
+
+ Widget::syncoptions LabelFrame Label .l {-text {} -underline {}}
+
+ bind BwLabelFrame <FocusIn> {Label::setfocus %W.l}
+ bind BwLabelFrame <Destroy> {Widget::destroy %W; rename %W {}}
+
+ proc ::LabelFrame { path args } { return [eval LabelFrame::create $path $args] }
+ proc use {} {}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command LabelFrame::create
+# ------------------------------------------------------------------------------
+proc LabelFrame::create { path args } {
+ Widget::init LabelFrame $path $args
+
+ set path [frame $path -background [Widget::getoption $path -background] \
+ -relief flat -bd 0 -takefocus 0 -highlightthickness 0]
+
+ set label [eval Label::create $path.l [Widget::subcget $path .l] \
+ -takefocus 0 -highlightthickness 0 -relief flat -borderwidth 0 \
+ -dropenabled 0 -dragenabled 0]
+ set frame [eval frame $path.f [Widget::subcget $path .f] \
+ -highlightthickness 0 -takefocus 0]
+
+ switch [Widget::getoption $path -side] {
+ left {set packopt "-side left"}
+ right {set packopt "-side right"}
+ top {set packopt "-side top -fill x"}
+ bottom {set packopt "-side bottom -fill x"}
+ }
+
+ eval pack $label $packopt
+ pack $frame -fill both -expand yes
+
+ bindtags $path [list $path BwLabelFrame [winfo toplevel $path] all]
+
+ rename $path ::$path:cmd
+ proc ::$path { cmd args } "return \[eval LabelFrame::\$cmd $path \$args\]"
+
+ return $path
+}
+
+
+# ------------------------------------------------------------------------------
+# Command LabelFrame::getframe
+# ------------------------------------------------------------------------------
+proc LabelFrame::getframe { path } {
+ return $path.f
+}
+
+
+# ------------------------------------------------------------------------------
+# Command LabelFrame::configure
+# ------------------------------------------------------------------------------
+proc LabelFrame::configure { path args } {
+ return [Widget::configure $path $args]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command LabelFrame::cget
+# ------------------------------------------------------------------------------
+proc LabelFrame::cget { path option } {
+ return [Widget::cget $path $option]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command LabelFrame::align
+# This command align label of all widget given by args of class LabelFrame
+# (or "derived") by setting their width to the max one +1
+# ------------------------------------------------------------------------------
+proc LabelFrame::align { args } {
+ set maxlen 0
+ set wlist {}
+ foreach wl $args {
+ foreach w $wl {
+ if { ![info exists Widget::_class($w)] } {
+ continue
+ }
+ set class $Widget::_class($w)
+ if { ![string compare $class "LabelFrame"] } {
+ set textopt -text
+ set widthopt -width
+ } else {
+ upvar 0 Widget::${class}::map classmap
+ set textopt ""
+ set widthopt ""
+ set notdone 2
+ foreach {option lmap} [array get classmap] {
+ foreach {subpath subclass realopt} $lmap {
+ if { ![string compare $subclass "LabelFrame"] } {
+ if { ![string compare $realopt "-text"] } {
+ set textopt $option
+ incr notdone -1
+ break
+ }
+ if { ![string compare $realopt "-width"] } {
+ set widthopt $option
+ incr notdone -1
+ break
+ }
+ }
+ }
+ if { !$notdone } {
+ break
+ }
+ }
+ if { $notdone } {
+ continue
+ }
+ }
+ set len [string length [$w cget $textopt]]
+ if { $len > $maxlen } {
+ set maxlen $len
+ }
+ lappend wlist $w $widthopt
+ }
+ }
+ incr maxlen
+ foreach {w widthopt} $wlist {
+ $w configure $widthopt $maxlen
+ }
+}
Copied: grass/trunk/lib/external/bwidget/lang (from rev 35192, grass/trunk/lib/external/bwidget/lang)
Property changes on: grass/trunk/lib/external/bwidget/lang
___________________________________________________________________
Name: svn:ignore
+ *OBJ*
Deleted: grass/trunk/lib/external/bwidget/lang/de.rc
===================================================================
--- grass/trunk/lib/external/bwidget/lang/de.rc 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/lang/de.rc 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,52 +0,0 @@
-! ------------------------------------------------------------------------------
-! de.rc
-! This file is part of Unifix BWidget Toolkit
-! Definition of german resources
-! ------------------------------------------------------------------------------
-
-
-! --- symbolic names of buttons ------------------------------------------------
-
-*abortName: &Abbrechen
-*retryName: &Wiederholen
-*ignoreName: &Ignorieren
-*okName: &OK
-*cancelName: &Abbrechen
-*yesName: &Ja
-*noName: &Nein
-
-
-! --- symbolic names of label of SelectFont dialog ----------------------------
-
-*boldName: Fett
-*italicName: Kursiv
-*underlineName: Unterstrichen
-*overstrikeName: Durchgestrichen
-*fontName: &Schriftart
-*sizeName: S&chriftgrad
-*styleName: Sc&hriftschnitt
-
-! --- symbolic names of label of PasswdDlg dialog -----------------------------
-
-*loginName: &Login
-*passwordName: &Password
-
-
-! --- resource for SelectFont dialog ------------------------------------------
-
-*SelectFont.title: Schrift Auswahl
-*SelectFont.sampletext: Beispieltext
-
-
-! --- resource for MessageDlg dialog ------------------------------------------
-
-*MessageDlg.noneTitle: Meldung
-*MessageDlg.infoTitle: Hinweis
-*MessageDlg.questionTitle: Frage
-*MessageDlg.warningTitle: Warnung
-*MessageDlg.errorTitle: Fehler
-
-
-! --- resource for PasswdDlg dialog -------------------------------------------
-
-*PasswdDlg.title: Enter login and password
Copied: grass/trunk/lib/external/bwidget/lang/de.rc (from rev 35192, grass/trunk/lib/external/bwidget/lang/de.rc)
===================================================================
--- grass/trunk/lib/external/bwidget/lang/de.rc (rev 0)
+++ grass/trunk/lib/external/bwidget/lang/de.rc 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,52 @@
+! ------------------------------------------------------------------------------
+! de.rc
+! This file is part of Unifix BWidget Toolkit
+! Definition of german resources
+! ------------------------------------------------------------------------------
+
+
+! --- symbolic names of buttons ------------------------------------------------
+
+*abortName: &Abbrechen
+*retryName: &Wiederholen
+*ignoreName: &Ignorieren
+*okName: &OK
+*cancelName: &Abbrechen
+*yesName: &Ja
+*noName: &Nein
+
+
+! --- symbolic names of label of SelectFont dialog ----------------------------
+
+*boldName: Fett
+*italicName: Kursiv
+*underlineName: Unterstrichen
+*overstrikeName: Durchgestrichen
+*fontName: &Schriftart
+*sizeName: S&chriftgrad
+*styleName: Sc&hriftschnitt
+
+! --- symbolic names of label of PasswdDlg dialog -----------------------------
+
+*loginName: &Login
+*passwordName: &Password
+
+
+! --- resource for SelectFont dialog ------------------------------------------
+
+*SelectFont.title: Schrift Auswahl
+*SelectFont.sampletext: Beispieltext
+
+
+! --- resource for MessageDlg dialog ------------------------------------------
+
+*MessageDlg.noneTitle: Meldung
+*MessageDlg.infoTitle: Hinweis
+*MessageDlg.questionTitle: Frage
+*MessageDlg.warningTitle: Warnung
+*MessageDlg.errorTitle: Fehler
+
+
+! --- resource for PasswdDlg dialog -------------------------------------------
+
+*PasswdDlg.title: Enter login and password
Deleted: grass/trunk/lib/external/bwidget/lang/en.rc
===================================================================
--- grass/trunk/lib/external/bwidget/lang/en.rc 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/lang/en.rc 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,52 +0,0 @@
-! ------------------------------------------------------------------------------
-! en.rc
-! This file is part of Unifix BWidget Toolkit
-! Definition of english resources
-! ------------------------------------------------------------------------------
-
-
-! --- symbolic names of buttons ------------------------------------------------
-
-*abortName: &Abort
-*retryName: &Retry
-*ignoreName: &Ignore
-*okName: &OK
-*cancelName: &Cancel
-*yesName: &Yes
-*noName: &No
-
-
-! --- symbolic names of label of SelectFont dialog ----------------------------
-
-*boldName: Bold
-*italicName: Italic
-*underlineName: Underline
-*overstrikeName: Overstrike
-*fontName: &Font
-*sizeName: &Size
-*styleName: St&yle
-
-
-! --- symbolic names of label of PasswdDlg dialog -----------------------------
-
-*loginName: &Login
-*passwordName: &Password
-
-
-! --- resource for SelectFont dialog ------------------------------------------
-
-*SelectFont.title: Font selection
-*SelectFont.sampletext: Sample text
-
-
-! --- resource for MessageDlg dialog ------------------------------------------
-
-*MessageDlg.noneTitle: Message
-*MessageDlg.infoTitle: Information
-*MessageDlg.questionTitle: Question
-*MessageDlg.warningTitle: Warning
-*MessageDlg.errorTitle: Error
-
-! --- resource for PasswdDlg dialog -------------------------------------------
-
-*PasswdDlg.title: Enter login and password
Copied: grass/trunk/lib/external/bwidget/lang/en.rc (from rev 35192, grass/trunk/lib/external/bwidget/lang/en.rc)
===================================================================
--- grass/trunk/lib/external/bwidget/lang/en.rc (rev 0)
+++ grass/trunk/lib/external/bwidget/lang/en.rc 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,52 @@
+! ------------------------------------------------------------------------------
+! en.rc
+! This file is part of Unifix BWidget Toolkit
+! Definition of english resources
+! ------------------------------------------------------------------------------
+
+
+! --- symbolic names of buttons ------------------------------------------------
+
+*abortName: &Abort
+*retryName: &Retry
+*ignoreName: &Ignore
+*okName: &OK
+*cancelName: &Cancel
+*yesName: &Yes
+*noName: &No
+
+
+! --- symbolic names of label of SelectFont dialog ----------------------------
+
+*boldName: Bold
+*italicName: Italic
+*underlineName: Underline
+*overstrikeName: Overstrike
+*fontName: &Font
+*sizeName: &Size
+*styleName: St&yle
+
+
+! --- symbolic names of label of PasswdDlg dialog -----------------------------
+
+*loginName: &Login
+*passwordName: &Password
+
+
+! --- resource for SelectFont dialog ------------------------------------------
+
+*SelectFont.title: Font selection
+*SelectFont.sampletext: Sample text
+
+
+! --- resource for MessageDlg dialog ------------------------------------------
+
+*MessageDlg.noneTitle: Message
+*MessageDlg.infoTitle: Information
+*MessageDlg.questionTitle: Question
+*MessageDlg.warningTitle: Warning
+*MessageDlg.errorTitle: Error
+
+! --- resource for PasswdDlg dialog -------------------------------------------
+
+*PasswdDlg.title: Enter login and password
Deleted: grass/trunk/lib/external/bwidget/lang/es.rc
===================================================================
--- grass/trunk/lib/external/bwidget/lang/es.rc 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/lang/es.rc 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,53 +0,0 @@
-! ------------------------------------------------------------------------------
-! es.rc
-! This file is part of Unifix BWidget Toolkit
-! Definition of spanish resources
-! daniel at rawbyte.com
-! ------------------------------------------------------------------------------
-
-
-! --- symbolic names of buttons ------------------------------------------------
-
-*abortName: A&bortar
-*retryName: &Reintentar
-*ignoreName: &Ignorar
-*okName: &OK
-*cancelName: &Anular
-*yesName: &Sí
-*noName: &No
-
-! --- symbolic names of label of SelectFont dialog ----------------------------
-
-*boldName: &Negrita
-*italicName: &Cursiva
-*underlineName: &Subrayado
-*overstrikeName: &Tachado
-*fontName: &Fuente
-*sizeName: &Tamaño
-*styleName: &Estilo
-
-
-! --- symbolic names of label of PasswdDlg dialog -----------------------------
-
-*loginName: Nombre de &usuario
-*passwordName: &Contraseña
-
-! --- resource for SelectFont dialog ------------------------------------------
-
-*SelectFont.title: Selección de fuente
-*SelectFont.sampletext: Texto de Ejemplo
-
-
-! --- resource for MessageDlg dialog ------------------------------------------
-
-*MessageDlg.noneTitle: Indicación
-*MessageDlg.infoTitle: Información
-*MessageDlg.questionTitle: Pregunta
-*MessageDlg.warningTitle: Atención
-*MessageDlg.errorTitle: Error
-
-
-! --- resource for PasswdDlg dialog -------------------------------------------
-
-*PasswdDlg.title: Introduzca su nombre de usuario y contraseña
-
Copied: grass/trunk/lib/external/bwidget/lang/es.rc (from rev 35192, grass/trunk/lib/external/bwidget/lang/es.rc)
===================================================================
--- grass/trunk/lib/external/bwidget/lang/es.rc (rev 0)
+++ grass/trunk/lib/external/bwidget/lang/es.rc 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,53 @@
+! ------------------------------------------------------------------------------
+! es.rc
+! This file is part of Unifix BWidget Toolkit
+! Definition of spanish resources
+! daniel at rawbyte.com
+! ------------------------------------------------------------------------------
+
+
+! --- symbolic names of buttons ------------------------------------------------
+
+*abortName: A&bortar
+*retryName: &Reintentar
+*ignoreName: &Ignorar
+*okName: &OK
+*cancelName: &Anular
+*yesName: &Sí
+*noName: &No
+
+! --- symbolic names of label of SelectFont dialog ----------------------------
+
+*boldName: &Negrita
+*italicName: &Cursiva
+*underlineName: &Subrayado
+*overstrikeName: &Tachado
+*fontName: &Fuente
+*sizeName: &Tamaño
+*styleName: &Estilo
+
+
+! --- symbolic names of label of PasswdDlg dialog -----------------------------
+
+*loginName: Nombre de &usuario
+*passwordName: &Contraseña
+
+! --- resource for SelectFont dialog ------------------------------------------
+
+*SelectFont.title: Selección de fuente
+*SelectFont.sampletext: Texto de Ejemplo
+
+
+! --- resource for MessageDlg dialog ------------------------------------------
+
+*MessageDlg.noneTitle: Indicación
+*MessageDlg.infoTitle: Información
+*MessageDlg.questionTitle: Pregunta
+*MessageDlg.warningTitle: Atención
+*MessageDlg.errorTitle: Error
+
+
+! --- resource for PasswdDlg dialog -------------------------------------------
+
+*PasswdDlg.title: Introduzca su nombre de usuario y contraseña
+
Deleted: grass/trunk/lib/external/bwidget/lang/fr.rc
===================================================================
--- grass/trunk/lib/external/bwidget/lang/fr.rc 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/lang/fr.rc 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,52 +0,0 @@
-! ------------------------------------------------------------------------------
-! fr.rc
-! This file is part of Unifix BWidget Toolkit
-! Definition of french resources
-! ------------------------------------------------------------------------------
-
-
-! --- symbolic names of buttons ------------------------------------------------
-
-*abortName: A&bandonner
-*retryName: &Réessayer
-*ignoreName: &Ignorer
-*okName: &OK
-*cancelName: &Annuler
-*yesName: &Oui
-*noName: &Non
-
-! --- symbolic names of label of SelectFont dialog ----------------------------
-
-*boldName: &Gras
-*italicName: &Italique
-*underlineName: &Souligné
-*overstrikeName: &Barré
-*fontName: &Police
-*sizeName: &Taille
-*styleName: St&yle
-
-
-! --- symbolic names of label of PasswdDlg dialog -----------------------------
-
-*loginName: Nom de l'&utilisateur
-*passwordName: Mot de &passe
-
-
-! --- resource for SelectFont dialog ------------------------------------------
-
-*SelectFont.title: Sélection d'une police
-*SelectFont.sampletext: Texte d'exemple
-
-
-! --- resource for MessageDlg dialog ------------------------------------------
-
-*MessageDlg.noneTitle: Message
-*MessageDlg.infoTitle: Information
-*MessageDlg.questionTitle: Question
-*MessageDlg.warningTitle: Attention
-*MessageDlg.errorTitle: Erreur
-
-
-! --- resource for PasswdDlg dialog -------------------------------------------
-
-*PasswdDlg.title: Entrez le login et le mot de passe
Copied: grass/trunk/lib/external/bwidget/lang/fr.rc (from rev 35192, grass/trunk/lib/external/bwidget/lang/fr.rc)
===================================================================
--- grass/trunk/lib/external/bwidget/lang/fr.rc (rev 0)
+++ grass/trunk/lib/external/bwidget/lang/fr.rc 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,52 @@
+! ------------------------------------------------------------------------------
+! fr.rc
+! This file is part of Unifix BWidget Toolkit
+! Definition of french resources
+! ------------------------------------------------------------------------------
+
+
+! --- symbolic names of buttons ------------------------------------------------
+
+*abortName: A&bandonner
+*retryName: &Réessayer
+*ignoreName: &Ignorer
+*okName: &OK
+*cancelName: &Annuler
+*yesName: &Oui
+*noName: &Non
+
+! --- symbolic names of label of SelectFont dialog ----------------------------
+
+*boldName: &Gras
+*italicName: &Italique
+*underlineName: &Souligné
+*overstrikeName: &Barré
+*fontName: &Police
+*sizeName: &Taille
+*styleName: St&yle
+
+
+! --- symbolic names of label of PasswdDlg dialog -----------------------------
+
+*loginName: Nom de l'&utilisateur
+*passwordName: Mot de &passe
+
+
+! --- resource for SelectFont dialog ------------------------------------------
+
+*SelectFont.title: Sélection d'une police
+*SelectFont.sampletext: Texte d'exemple
+
+
+! --- resource for MessageDlg dialog ------------------------------------------
+
+*MessageDlg.noneTitle: Message
+*MessageDlg.infoTitle: Information
+*MessageDlg.questionTitle: Question
+*MessageDlg.warningTitle: Attention
+*MessageDlg.errorTitle: Erreur
+
+
+! --- resource for PasswdDlg dialog -------------------------------------------
+
+*PasswdDlg.title: Entrez le login et le mot de passe
Deleted: grass/trunk/lib/external/bwidget/listbox.tcl
===================================================================
--- grass/trunk/lib/external/bwidget/listbox.tcl 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/listbox.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,1179 +0,0 @@
-# ------------------------------------------------------------------------------
-# listbox.tcl
-# This file is part of Unifix BWidget Toolkit
-# $Id$
-# ------------------------------------------------------------------------------
-# Index of commands:
-# - ListBox::create
-# - ListBox::configure
-# - ListBox::cget
-# - ListBox::insert
-# - ListBox::itemconfigure
-# - ListBox::itemcget
-# - ListBox::bindText
-# - ListBox::bindImage
-# - ListBox::delete
-# - ListBox::move
-# - ListBox::reorder
-# - ListBox::selection
-# - ListBox::exists
-# - ListBox::index
-# - ListBox::item - deprecated
-# - ListBox::items
-# - ListBox::see
-# - ListBox::edit
-# - ListBox::xview
-# - ListBox::yview
-# - ListBox::_update_edit_size
-# - ListBox::_destroy
-# - ListBox::_see
-# - ListBox::_update_scrollregion
-# - ListBox::_draw_item
-# - ListBox::_redraw_items
-# - ListBox::_redraw_selection
-# - ListBox::_redraw_listbox
-# - ListBox::_redraw_idle
-# - ListBox::_resize
-# - ListBox::_init_drag_cmd
-# - ListBox::_drop_cmd
-# - ListBox::_over_cmd
-# - ListBox::_auto_scroll
-# - ListBox::_scroll
-# ------------------------------------------------------------------------------
-
-
-namespace eval ListBox {
- namespace eval Item {
- Widget::declare ListBox::Item {
- {-indent Int 0 0 {=0}}
- {-text String "" 0}
- {-font TkResource "" 0 listbox}
- {-image TkResource "" 0 label}
- {-window String "" 0}
- {-fill TkResource black 0 {listbox -foreground}}
- {-data String "" 0}
- }
- }
-
- Widget::tkinclude ListBox canvas :cmd \
- remove {-insertwidth -insertbackground -insertborderwidth -insertofftime \
- -insertontime -selectborderwidth -closeenough -confine -scrollregion \
- -xscrollincrement -yscrollincrement -width -height} \
- initialize {-relief sunken -borderwidth 2 -takefocus 1 \
- -highlightthickness 1 -width 200}
-
- Widget::declare ListBox {
- {-deltax Int 10 0 {=0 ""}}
- {-deltay Int 15 0 {=0 ""}}
- {-padx Int 20 0 {=0 ""}}
- {-background TkResource "" 0 listbox}
- {-selectbackground TkResource "" 0 listbox}
- {-selectforeground TkResource "" 0 listbox}
- {-width TkResource "" 0 listbox}
- {-height TkResource "" 0 listbox}
- {-redraw Boolean 1 0}
- {-multicolumn Boolean 0 0}
- {-dropovermode Flag "wpi" 0 "wpi"}
- {-bg Synonym -background}
- }
- DragSite::include ListBox "LISTBOX_ITEM" 1
- DropSite::include ListBox {
- LISTBOX_ITEM {copy {} move {}}
- }
-
- Widget::addmap ListBox "" :cmd {-deltay -yscrollincrement}
-
- proc ::ListBox { path args } { return [eval ListBox::create $path $args] }
- proc use {} {}
-
- variable _edit
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ListBox::create
-# ------------------------------------------------------------------------------
-proc ListBox::create { path args } {
- Widget::init ListBox $path $args
-
- variable $path
- upvar 0 $path data
-
- # widget informations
- set data(nrows) -1
-
- # items informations
- set data(items) {}
- set data(selitems) {}
-
- # update informations
- set data(upd,level) 0
- set data(upd,afterid) ""
- set data(upd,level) 0
- set data(upd,delete) {}
-
- # drag and drop informations
- set data(dnd,scroll) ""
- set data(dnd,afterid) ""
- set data(dnd,item) ""
-
- eval canvas $path [Widget::subcget $path :cmd] \
- -width [expr {[Widget::getoption $path -width]*8}] \
- -height [expr {[Widget::getoption $path -height]*[Widget::getoption $path -deltay]}] \
- -xscrollincrement 8
-
- bind $path <Configure> "ListBox::_resize $path"
- bind $path <Destroy> "ListBox::_destroy $path"
-
- DragSite::setdrag $path $path ListBox::_init_drag_cmd [Widget::getoption $path -dragendcmd] 1
- DropSite::setdrop $path $path ListBox::_over_cmd ListBox::_drop_cmd 1
-
- rename $path ::$path:cmd
- proc ::$path { cmd args } "return \[eval ListBox::\$cmd $path \$args\]"
-
- return $path
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ListBox::configure
-# ------------------------------------------------------------------------------
-proc ListBox::configure { path args } {
- set res [Widget::configure $path $args]
-
- set ch1 [expr {[Widget::hasChanged $path -deltay dy] |
- [Widget::hasChanged $path -padx val] |
- [Widget::hasChanged $path -multicolumn val]}]
-
- set ch2 [expr {[Widget::hasChanged $path -selectbackground val] |
- [Widget::hasChanged $path -selectforeground val]}]
-
- set redraw 0
- if { [Widget::hasChanged $path -height h] } {
- $path:cmd configure -height [expr {$h*$dy}]
- set redraw 1
- }
- if { [Widget::hasChanged $path -width w] } {
- $path:cmd configure -width [expr {$w*8}]
- set redraw 1
- }
-
- if { !$redraw } {
- if { $ch1 } {
- _redraw_idle $path 2
- } elseif { $ch2 } {
- _redraw_idle $path 1
- }
- }
-
- if { [Widget::hasChanged $path -redraw bool] && $bool } {
- variable $path
- upvar 0 $path data
- set lvl $data(upd,level)
- set data(upd,level) 0
- _redraw_idle $path $lvl
- }
- set force [Widget::hasChanged $path -dragendcmd dragend]
- DragSite::setdrag $path $path ListBox::_init_drag_cmd $dragend $force
- DropSite::setdrop $path $path ListBox::_over_cmd ListBox::_drop_cmd
-
- return $res
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ListBox::cget
-# ------------------------------------------------------------------------------
-proc ListBox::cget { path option } {
- return [Widget::cget $path $option]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ListBox::insert
-# ------------------------------------------------------------------------------
-proc ListBox::insert { path index item args } {
- variable $path
- upvar 0 $path data
-
- if { [lsearch $data(items) $item] != -1 } {
- return -code error "item \"$item\" already exists"
- }
-
- Widget::init ListBox::Item $path.$item $args
-
- if { ![string compare $index "end"] } {
- lappend data(items) $item
- } else {
- set data(items) [linsert $data(items) $index $item]
- }
- set data(upd,create,$item) $item
-
- _redraw_idle $path 2
- return $item
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ListBox::itemconfigure
-# ------------------------------------------------------------------------------
-proc ListBox::itemconfigure { path item args } {
- variable $path
- upvar 0 $path data
-
- if { [lsearch $data(items) $item] == -1 } {
- return -code error "item \"$item\" does not exist"
- }
-
- set oldind [Widget::getoption $path.$item -indent]
-
- set res [Widget::configure $path.$item $args]
- set chind [Widget::hasChanged $path.$item -indent indent]
- set chw [Widget::hasChanged $path.$item -window win]
- set chi [Widget::hasChanged $path.$item -image img]
- set cht [Widget::hasChanged $path.$item -text txt]
- set chf [Widget::hasChanged $path.$item -font fnt]
- set chfg [Widget::hasChanged $path.$item -fill fg]
- set idn [$path:cmd find withtag n:$item]
-
- if { $idn == "" } {
- # item is not drawn yet
- _redraw_idle $path 2
- return $res
- }
-
- set oldb [$path:cmd bbox $idn]
- set coords [$path:cmd coords $idn]
- set padx [Widget::getoption $path -padx]
- set x0 [expr {[lindex $coords 0]-$padx-$oldind+$indent}]
- set y0 [lindex $coords 1]
- if { $chw || $chi } {
- # -window or -image modified
- set idi [$path:cmd find withtag i:$item]
- set type [lindex [$path:cmd gettags $idi] 0]
- if { [string length $win] } {
- if { ![string compare $type "win"] } {
- $path:cmd itemconfigure $idi -window $win
- } else {
- $path:cmd delete $idi
- $path:cmd create window $x0 $y0 -window $win -anchor w -tags "win i:$item"
- }
- } elseif { [string length $img] } {
- if { ![string compare $type "img"] } {
- $path:cmd itemconfigure $idi -image $img
- } else {
- $path:cmd delete $idi
- $path:cmd create image $x0 $y0 -image $img -anchor w -tags "img i:$item"
- }
- } else {
- $path:cmd delete $idi
- }
- }
-
- if { $cht || $chf || $chfg } {
- # -text or -font modified, or -fill modified
- $path:cmd itemconfigure $idn -text $txt -font $fnt -fill $fg
- _redraw_idle $path 1
- }
-
- if { $chind } {
- # -indent modified
- $path:cmd coords $idn [expr {$x0+$padx}] $y0
- $path:cmd coords i:$item $x0 $y0
- _redraw_idle $path 1
- }
-
- if { [Widget::getoption $path -multicolumn] && ($cht || $chf || $chind) } {
- set bbox [$path:cmd bbox $idn]
- if { [lindex $bbox 2] > [lindex $oldb 2] } {
- _redraw_idle $path 2
- }
- }
-
- return $res
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ListBox::itemcget
-# ------------------------------------------------------------------------------
-proc ListBox::itemcget { path item option } {
- return [Widget::cget $path.$item $option]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ListBox::bindText
-# ------------------------------------------------------------------------------
-proc ListBox::bindText { path event script } {
- if { $script != "" } {
- $path:cmd bind "item" $event \
- "$script \[string range \[lindex \[$path:cmd gettags current\] 1\] 2 end\]"
- } else {
- $path:cmd bind "item" $event {}
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ListBox::bindImage
-# ------------------------------------------------------------------------------
-proc ListBox::bindImage { path event script } {
- if { $script != "" } {
- $path:cmd bind "img" $event \
- "$script \[string range \[lindex \[$path:cmd gettags current\] 1\] 2 end\]"
- } else {
- $path:cmd bind "img" $event {}
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ListBox::delete
-# ------------------------------------------------------------------------------
-proc ListBox::delete { path args } {
- variable $path
- upvar 0 $path data
-
- foreach litems $args {
- foreach item $litems {
- set idx [lsearch $data(items) $item]
- if { $idx != -1 } {
- set data(items) [lreplace $data(items) $idx $idx]
- Widget::destroy $path.$item
- if { [info exists data(upd,create,$item)] } {
- unset data(upd,create,$item)
- } else {
- lappend data(upd,delete) $item
- }
- }
- }
- }
-
- set sel $data(selitems)
- set data(selitems) {}
- eval selection $path set $sel
- _redraw_idle $path 2
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ListBox::move
-# ------------------------------------------------------------------------------
-proc ListBox::move { path item index } {
- variable $path
- upvar 0 $path data
-
- if { [set idx [lsearch $data(items) $item]] == -1 } {
- return -code error "item \"$item\" does not exist"
- }
-
- set data(items) [lreplace $data(items) $idx $idx]
- if { ![string compare $index "end"] } {
- lappend data($path,item) $item
- } else {
- set data(items) [linsert $data(items) $index $item]
- }
-
- _redraw_idle $path 2
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ListBox::reorder
-# ------------------------------------------------------------------------------
-proc ListBox::reorder { path neworder } {
- variable $path
- upvar 0 $path data
-
- set data(items) [BWidget::lreorder $data(items) $neworder]
- _redraw_idle $path 2
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ListBox::selection
-# ------------------------------------------------------------------------------
-proc ListBox::selection { path cmd args } {
- variable $path
- upvar 0 $path data
-
- switch -- $cmd {
- set {
- set data(selitems) {}
- foreach item $args {
- if { [lsearch $data(selitems) $item] == -1 } {
- if { [lsearch $data(items) $item] != -1 } {
- lappend data(selitems) $item
- }
- }
- }
- }
- add {
- foreach item $args {
- if { [lsearch $data(selitems) $item] == -1 } {
- if { [lsearch $data(items) $item] != -1 } {
- lappend data(selitems) $item
- }
- }
- }
- }
- remove {
- foreach item $args {
- if { [set idx [lsearch $data(selitems) $item]] != -1 } {
- set data(selitems) [lreplace $data(selitems) $idx $idx]
- }
- }
- }
- clear {
- set data(selitems) {}
- }
- get {
- return $data(selitems)
- }
- default {
- return
- }
- }
- _redraw_idle $path 1
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ListBox::exists
-# ------------------------------------------------------------------------------
-proc ListBox::exists { path item } {
- variable $path
- upvar 0 $path data
-
- return [expr {[lsearch $data(items) $item] != -1}]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ListBox::index
-# ------------------------------------------------------------------------------
-proc ListBox::index { path item } {
- variable $path
- upvar 0 $path data
-
- return [lsearch $data(items) $item]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ListBox::item - deprecated
-# ------------------------------------------------------------------------------
-proc ListBox::item { path first {last ""} } {
- variable $path
- upvar 0 $path data
-
- if { ![string length $last] } {
- return [lindex $data(items) $first]
- } else {
- return [lrange $data(items) $first $last]
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ListBox::items
-# ------------------------------------------------------------------------------
-proc ListBox::items { path {first ""} {last ""}} {
- variable $path
- upvar 0 $path data
-
- if { ![string length $first] } {
- return $data(items)
- }
-
- if { ![string length $last] } {
- return [lindex $data(items) $first]
- } else {
- return [lrange $data(items) $first $last]
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ListBox::see
-# ------------------------------------------------------------------------------
-proc ListBox::see { path item } {
- variable $path
- upvar 0 $path data
-
- if { [Widget::getoption $path -redraw] && $data(upd,afterid) != "" } {
- after cancel $data(upd,afterid)
- _redraw_listbox $path
- }
- set idn [$path:cmd find withtag n:$item]
- if { $idn != "" } {
- ListBox::_see $path $idn right
- ListBox::_see $path $idn left
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ListBox::edit
-# ------------------------------------------------------------------------------
-proc ListBox::edit { path item text {verifycmd ""} {clickres 0} {select 1}} {
- variable _edit
- variable $path
- upvar 0 $path data
-
- if { [Widget::getoption $path -redraw] && $data(upd,afterid) != "" } {
- after cancel $data(upd,afterid)
- _redraw_listbox $path
- }
- set idn [$path:cmd find withtag n:$item]
- if { $idn != "" } {
- ListBox::_see $path $idn right
- ListBox::_see $path $idn left
-
- set oldfg [$path:cmd itemcget $idn -fill]
- set sbg [Widget::getoption $path -selectbackground]
- set coords [$path:cmd coords $idn]
- set x [lindex $coords 0]
- set y [lindex $coords 1]
- set bd [expr {[$path:cmd cget -borderwidth]+[$path:cmd cget -highlightthickness]}]
- set w [expr {[winfo width $path] - 2*$bd}]
- set wmax [expr {[$path:cmd canvasx $w]-$x}]
-
- $path:cmd itemconfigure $idn -fill [Widget::getoption $path -background]
- $path:cmd itemconfigure s:$item -fill {} -outline {}
-
- set _edit(text) $text
- set _edit(wait) 0
-
- set frame [frame $path.edit \
- -relief flat -borderwidth 0 -highlightthickness 0 \
- -background [Widget::getoption $path -background]]
- set ent [entry $frame.edit \
- -width 0 \
- -relief solid \
- -borderwidth 1 \
- -highlightthickness 0 \
- -foreground [Widget::getoption $path.$item -fill] \
- -background [Widget::getoption $path -background] \
- -selectforeground [Widget::getoption $path -selectforeground] \
- -selectbackground $sbg \
- -font [Widget::getoption $path.$item -font] \
- -textvariable ListBox::_edit(text)]
- pack $ent -ipadx 8 -anchor w
-
- set idw [$path:cmd create window $x $y -window $frame -anchor w]
- trace variable ListBox::_edit(text) w "ListBox::_update_edit_size $path $ent $idw $wmax"
- tkwait visibility $ent
- grab $frame
- BWidget::focus set $ent
- _update_edit_size $path $ent $idw $wmax
- update
- if { $select } {
- $ent selection range 0 end
- $ent icursor end
- $ent xview end
- }
-
- bind $ent <Escape> {set ListBox::_edit(wait) 0}
- bind $ent <Return> {set ListBox::_edit(wait) 1}
- if { $clickres == 0 || $clickres == 1 } {
- bind $frame <Button> "set ListBox::_edit(wait) $clickres"
- }
-
- set ok 0
- while { !$ok } {
- tkwait variable ListBox::_edit(wait)
- if { !$_edit(wait) || $verifycmd == "" ||
- [uplevel \#0 $verifycmd [list $_edit(text)]] } {
- set ok 1
- }
- }
- trace vdelete ListBox::_edit(text) w "ListBox::_update_edit_size $path $ent $idw $wmax"
- grab release $frame
- BWidget::focus release $ent
- destroy $frame
- $path:cmd delete $idw
- $path:cmd itemconfigure $idn -fill $oldfg
- $path:cmd itemconfigure s:$item -fill $sbg -outline $sbg
-
- if { $_edit(wait) } {
- return $_edit(text)
- }
- }
- return ""
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ListBox::xview
-# ------------------------------------------------------------------------------
-proc ListBox::xview { path args } {
- return [eval $path:cmd xview $args]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ListBox::yview
-# ------------------------------------------------------------------------------
-proc ListBox::yview { path args } {
- return [eval $path:cmd yview $args]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ListBox::_update_edit_size
-# ------------------------------------------------------------------------------
-proc ListBox::_update_edit_size { path entry idw wmax args } {
- set entw [winfo reqwidth $entry]
- if { $entw >= $wmax } {
- $path:cmd itemconfigure $idw -width $wmax
- } else {
- $path:cmd itemconfigure $idw -width 0
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ListBox::_destroy
-# ------------------------------------------------------------------------------
-proc ListBox::_destroy { path } {
- variable $path
- upvar 0 $path data
-
- if { $data(upd,afterid) != "" } {
- after cancel $data(upd,afterid)
- }
- if { $data(dnd,afterid) != "" } {
- after cancel $data(dnd,afterid)
- }
- foreach item $data(items) {
- Widget::destroy $path.$item
- }
-
- Widget::destroy $path
- unset data
- rename $path {}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ListBox::_see
-# ------------------------------------------------------------------------------
-proc ListBox::_see { path idn side } {
- set bbox [$path:cmd bbox $idn]
- set scrl [$path:cmd cget -scrollregion]
-
- set ymax [lindex $scrl 3]
- set dy [$path:cmd cget -yscrollincrement]
- set yv [$path:cmd yview]
- set yv0 [expr {round([lindex $yv 0]*$ymax/$dy)}]
- set yv1 [expr {round([lindex $yv 1]*$ymax/$dy)}]
- set y [expr {int([lindex [$path:cmd coords $idn] 1]/$dy)}]
- if { $y < $yv0 } {
- $path:cmd yview scroll [expr {$y-$yv0}] units
- } elseif { $y >= $yv1 } {
- $path:cmd yview scroll [expr {$y-$yv1+1}] units
- }
-
- set xmax [lindex $scrl 2]
- set dx [$path:cmd cget -xscrollincrement]
- set xv [$path:cmd xview]
- if { ![string compare $side "right"] } {
- set xv1 [expr {round([lindex $xv 1]*$xmax/$dx)}]
- set x1 [expr {int([lindex $bbox 2]/$dx)}]
- if { $x1 >= $xv1 } {
- $path:cmd xview scroll [expr {$x1-$xv1+1}] units
- }
- } else {
- set xv0 [expr {round([lindex $xv 0]*$xmax/$dx)}]
- set x0 [expr {int([lindex $bbox 0]/$dx)}]
- if { $x0 < $xv0 } {
- $path:cmd xview scroll [expr {$x0-$xv0}] units
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ListBox::_update_scrollregion
-# ------------------------------------------------------------------------------
-proc ListBox::_update_scrollregion { path } {
- set bd [expr {2*([$path:cmd cget -borderwidth]+[$path:cmd cget -highlightthickness])}]
- set w [expr {[winfo width $path] - $bd}]
- set h [expr {[winfo height $path] - $bd}]
- set xinc [$path:cmd cget -xscrollincrement]
- set yinc [$path:cmd cget -yscrollincrement]
- set bbox [$path:cmd bbox all]
- if { [llength $bbox] } {
- set xs [lindex $bbox 2]
- set ys [lindex $bbox 3]
-
- if { $w < $xs } {
- set w [expr {int($xs)}]
- if { [set r [expr {$w % $xinc}]] } {
- set w [expr {$w+$xinc-$r}]
- }
- }
- if { $h < $ys } {
- set h [expr {int($ys)}]
- if { [set r [expr {$h % $yinc}]] } {
- set h [expr {$h+$yinc-$r}]
- }
- }
- }
-
- $path:cmd configure -scrollregion [list 0 0 $w $h]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ListBox::_draw_item
-# ------------------------------------------------------------------------------
-proc ListBox::_draw_item { path item x0 x1 y } {
- set indent [Widget::getoption $path.$item -indent]
- $path:cmd create text [expr {$x1+$indent}] $y \
- -text [Widget::getoption $path.$item -text] \
- -fill [Widget::getoption $path.$item -fill] \
- -font [Widget::getoption $path.$item -font] \
- -anchor w \
- -tags "item n:$item"
- if { [set win [Widget::getoption $path.$item -window]] != "" } {
- $path:cmd create window [expr {$x0+$indent}] $y \
- -window $win -anchor w -tags "win i:$item"
- } elseif { [set img [Widget::getoption $path.$item -image]] != "" } {
- $path:cmd create image [expr {$x0+$indent}] $y \
- -image $img -anchor w -tags "img i:$item"
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ListBox::_redraw_items
-# ------------------------------------------------------------------------------
-proc ListBox::_redraw_items { path } {
- variable $path
- upvar 0 $path data
-
- $path:cmd configure -cursor watch
- set dx [Widget::getoption $path -deltax]
- set dy [Widget::getoption $path -deltay]
- set padx [Widget::getoption $path -padx]
- set y0 [expr {$dy/2}]
- set x0 4
- set x1 [expr {$x0+$padx}]
- set nitem 0
- set drawn {}
- set data(xlist) {}
- if { [Widget::getoption $path -multicolumn] } {
- set nrows $data(nrows)
- } else {
- set nrows [llength $data(items)]
- }
- foreach item $data(upd,delete) {
- $path:cmd delete i:$item n:$item s:$item
- }
- foreach item $data(items) {
- if { [info exists data(upd,create,$item)] } {
- _draw_item $path $item $x0 $x1 $y0
- unset data(upd,create,$item)
- } else {
- set indent [Widget::getoption $path.$item -indent]
- $path:cmd coords n:$item [expr {$x1+$indent}] $y0
- $path:cmd coords i:$item [expr {$x0+$indent}] $y0
- }
- incr y0 $dy
- incr nitem
- lappend drawn n:$item
- if { $nitem == $nrows } {
- set y0 [expr {$dy/2}]
- set bbox [eval $path:cmd bbox $drawn]
- set drawn {}
- set x0 [expr {[lindex $bbox 2]+$dx}]
- set x1 [expr {$x0+$padx}]
- set nitem 0
- lappend data(xlist) [lindex $bbox 2]
- }
- }
- if { $nitem && $nitem < $nrows } {
- set bbox [eval $path:cmd bbox $drawn]
- lappend data(xlist) [lindex $bbox 2]
- }
- set data(upd,delete) {}
- $path:cmd configure -cursor [Widget::getoption $path -cursor]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ListBox::_redraw_selection
-# ------------------------------------------------------------------------------
-proc ListBox::_redraw_selection { path } {
- variable $path
- upvar 0 $path data
-
- set selbg [Widget::getoption $path -selectbackground]
- set selfg [Widget::getoption $path -selectforeground]
- foreach id [$path:cmd find withtag sel] {
- set item [string range [lindex [$path:cmd gettags $id] 1] 2 end]
- $path:cmd itemconfigure "n:$item" -fill [Widget::getoption $path.$item -fill]
- }
- $path:cmd delete sel
- foreach item $data(selitems) {
- set bbox [$path:cmd bbox "n:$item"]
- if { [llength $bbox] } {
- set id [eval $path:cmd create rectangle $bbox -fill $selbg -outline $selbg -tags [list "sel s:$item"]]
- $path:cmd itemconfigure "n:$item" -fill $selfg
- $path:cmd lower $id
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ListBox::_redraw_listbox
-# ------------------------------------------------------------------------------
-proc ListBox::_redraw_listbox { path } {
- variable $path
- upvar 0 $path data
-
- if { [Widget::getoption $path -redraw] } {
- if { $data(upd,level) == 2 } {
- _redraw_items $path
- }
- _redraw_selection $path
- _update_scrollregion $path
- set data(upd,level) 0
- set data(upd,afterid) ""
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ListBox::_redraw_idle
-# ------------------------------------------------------------------------------
-proc ListBox::_redraw_idle { path level } {
- variable $path
- upvar 0 $path data
-
- if { $data(nrows) != -1 } {
- # widget is realized
- if { [Widget::getoption $path -redraw] && $data(upd,afterid) == "" } {
- set data(upd,afterid) [after idle ListBox::_redraw_listbox $path]
- }
- }
- if { $level > $data(upd,level) } {
- set data(upd,level) $level
- }
- return ""
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ListBox::_resize
-# ------------------------------------------------------------------------------
-proc ListBox::_resize { path } {
- variable $path
- upvar 0 $path data
-
- if { [Widget::getoption $path -multicolumn] } {
- set bd [expr {[$path:cmd cget -borderwidth]+[$path:cmd cget -highlightthickness]}]
- set h [expr {[winfo height $path] - 2*$bd}]
- set nrows [expr {$h/[$path:cmd cget -yscrollincrement]}]
- if { $nrows == 0 } {
- set nrows 1
- }
- if { $nrows != $data(nrows) } {
- set data(nrows) $nrows
- _redraw_idle $path 2
- } else {
- _update_scrollregion $path
- }
- } elseif { $data(nrows) == -1 } {
- # first Configure event
- set data(nrows) 0
- ListBox::_redraw_listbox $path
- } else {
- _update_scrollregion $path
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ListBox::_init_drag_cmd
-# ------------------------------------------------------------------------------
-proc ListBox::_init_drag_cmd { path X Y top } {
- set ltags [$path:cmd gettags current]
- set item [lindex $ltags 0]
- if { ![string compare $item "item"] ||
- ![string compare $item "img"] ||
- ![string compare $item "win"] } {
- set item [string range [lindex $ltags 1] 2 end]
- if { [set cmd [Widget::getoption $path -draginitcmd]] != "" } {
- return [uplevel \#0 $cmd [list $path $item $top]]
- }
- if { [set type [Widget::getoption $path -dragtype]] == "" } {
- set type "LISTBOX_ITEM"
- }
- if { [set img [Widget::getoption $path.$item -image]] != "" } {
- pack [label $top.l -image $img -padx 0 -pady 0]
- }
- return [list $type {copy move link} $item]
- }
- return {}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ListBox::_drop_cmd
-# ------------------------------------------------------------------------------
-proc ListBox::_drop_cmd { path source X Y op type dnddata } {
- variable $path
- upvar 0 $path data
-
- if { [string length $data(dnd,afterid)] } {
- after cancel $data(dnd,afterid)
- set data(dnd,afterid) ""
- }
- $path:cmd delete drop
- set data(dnd,scroll) ""
- if { [llength $data(dnd,item)] } {
- if { [set cmd [Widget::getoption $path -dropcmd]] != "" } {
- return [uplevel \#0 $cmd [list $path $source $data(dnd,item) $op $type $dnddata]]
- }
- }
- return 0
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ListBox::_over_cmd
-# ------------------------------------------------------------------------------
-proc ListBox::_over_cmd { path source event X Y op type dnddata } {
- variable $path
- upvar 0 $path data
-
- if { ![string compare $event "leave"] } {
- # we leave the window listbox
- $path:cmd delete drop
- if { [string length $data(dnd,afterid)] } {
- after cancel $data(dnd,afterid)
- set data(dnd,afterid) ""
- }
- set data(dnd,scroll) ""
- return 0
- }
-
- if { ![string compare $event "enter"] } {
- # we enter the window listbox - dnd data initialization
- set mode [Widget::getoption $path -dropovermode]
- set data(dnd,mode) 0
- foreach c {w p i} {
- set data(dnd,mode) [expr {($data(dnd,mode) << 1) | ([string first $c $mode] != -1)}]
- }
- }
-
- set x [expr {$X-[winfo rootx $path]}]
- set y [expr {$Y-[winfo rooty $path]}]
- $path:cmd delete drop
- set data(dnd,item) ""
-
- # test for auto-scroll unless mode is widget only
- if { $data(dnd,mode) != 4 && [_auto_scroll $path $x $y] != "" } {
- return 2
- }
-
- if { $data(dnd,mode) & 4 } {
- # dropovermode includes widget
- set target [list widget]
- set vmode 4
- } else {
- set target [list ""]
- set vmode 0
- }
-
- if { $data(dnd,mode) & 3 } {
- # dropovermode includes item or position
- # we extract the box (xi,yi,xs,ys) where we can find item around x,y
- set len [llength $data(items)]
- set xc [$path:cmd canvasx $x]
- set yc [$path:cmd canvasy $y]
- set dy [$path:cmd cget -yscrollincrement]
- set line [expr {int($yc/$dy)}]
- set yi [expr {$line*$dy}]
- set ys [expr {$yi+$dy}]
- set xi 0
- set pos $line
- if { [Widget::getoption $path -multicolumn] } {
- set nrows $data(nrows)
- } else {
- set nrows $len
- }
- if { $line < $nrows } {
- foreach xs $data(xlist) {
- if { $xc <= $xs } {
- break
- }
- set xi $xs
- incr pos $nrows
- }
- if { $pos < $len } {
- set item [lindex $data(items) $pos]
- if { $data(dnd,mode) & 1 } {
- # dropovermode includes item
- lappend target $item
- set vmode [expr {$vmode | 1}]
- } else {
- lappend target ""
- }
-
- if { $data(dnd,mode) & 2 } {
- # dropovermode includes position
- if { $yc >= $yi+$dy/2 } {
- # position is after $item
- incr pos
- set yl $ys
- } else {
- # position is before $item
- set yl $yi
- }
- lappend target $pos
- set vmode [expr {$vmode | 2}]
- } else {
- lappend target ""
- }
- } else {
- lappend target "" ""
- }
- } else {
- lappend target "" ""
- }
-
- if { ($vmode & 3) == 3 } {
- # result have both item and position
- # we compute what is the preferred method
- if { $yc-$yi <= 3 || $ys-$yc <= 3 } {
- lappend target "position"
- } else {
- lappend target "item"
- }
- }
- }
-
- if { $vmode && [set cmd [Widget::getoption $path -dropovercmd]] != "" } {
- # user-defined dropover command
- set res [uplevel \#0 $cmd [list $source $target $op $type $dnddata]]
- set code [lindex $res 0]
- set vmode 0
- if { $code & 1 } {
- # update vmode
- set mode [lindex $res 1]
- if { ![string compare $mode "item"] } {
- set vmode 1
- } elseif { ![string compare $mode "position"] } {
- set vmode 2
- } elseif { ![string compare $mode "widget"] } {
- set vmode 4
- }
- }
- } else {
- if { ($vmode & 3) == 3 } {
- # result have both item and position
- # we choose the preferred method
- if { ![string compare [lindex $target 3] "position"] } {
- set vmode [expr {$vmode & ~1}]
- } else {
- set vmode [expr {$vmode & ~2}]
- }
- }
-
- if { $data(dnd,mode) == 4 || $data(dnd,mode) == 0 } {
- # dropovermode is widget or empty - recall is not necessary
- set code 1
- } else {
- set code 3
- }
- }
-
- # draw dnd visual following vmode
- if { $vmode & 1 } {
- set data(dnd,item) [list "item" [lindex $target 1]]
- $path:cmd create rectangle $xi $yi $xs $ys -tags drop
- } elseif { $vmode & 2 } {
- set data(dnd,item) [concat "position" [lindex $target 2]]
- $path:cmd create line $xi $yl $xs $yl -tags drop
- } elseif { $vmode & 4 } {
- set data(dnd,item) [list "widget"]
- } else {
- set code [expr {$code & 2}]
- }
-
- if { $code & 1 } {
- DropSite::setcursor based_arrow_down
- } else {
- DropSite::setcursor dot
- }
- return $code
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ListBox::_auto_scroll
-# ------------------------------------------------------------------------------
-proc ListBox::_auto_scroll { path x y } {
- variable $path
- upvar 0 $path data
-
- set xmax [winfo width $path]
- set ymax [winfo height $path]
- set scroll {}
- if { $y <= 6 } {
- if { [lindex [$path:cmd yview] 0] > 0 } {
- set scroll [list yview -1]
- DropSite::setcursor sb_up_arrow
- }
- } elseif { $y >= $ymax-6 } {
- if { [lindex [$path:cmd yview] 1] < 1 } {
- set scroll [list yview 1]
- DropSite::setcursor sb_down_arrow
- }
- } elseif { $x <= 6 } {
- if { [lindex [$path:cmd xview] 0] > 0 } {
- set scroll [list xview -1]
- DropSite::setcursor sb_left_arrow
- }
- } elseif { $x >= $xmax-6 } {
- if { [lindex [$path:cmd xview] 1] < 1 } {
- set scroll [list xview 1]
- DropSite::setcursor sb_right_arrow
- }
- }
-
- if { [string length $data(dnd,afterid)] && [string compare $data(dnd,scroll) $scroll] } {
- after cancel $data(dnd,afterid)
- set data(dnd,afterid) ""
- }
-
- set data(dnd,scroll) $scroll
- if { [llength $scroll] && ![string length $data(dnd,afterid)] } {
- set data(dnd,afterid) [after 200 ListBox::_scroll $path $scroll]
- }
- return $data(dnd,afterid)
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ListBox::_scroll
-# ------------------------------------------------------------------------------
-proc ListBox::_scroll { path cmd dir } {
- variable $path
- upvar 0 $path data
-
- if { ($dir == -1 && [lindex [$path:cmd $cmd] 0] > 0) ||
- ($dir == 1 && [lindex [$path:cmd $cmd] 1] < 1) } {
- $path $cmd scroll $dir units
- set data(dnd,afterid) [after 100 ListBox::_scroll $path $cmd $dir]
- } else {
- set data(dnd,afterid) ""
- DropSite::setcursor dot
- }
-}
Copied: grass/trunk/lib/external/bwidget/listbox.tcl (from rev 35192, grass/trunk/lib/external/bwidget/listbox.tcl)
===================================================================
--- grass/trunk/lib/external/bwidget/listbox.tcl (rev 0)
+++ grass/trunk/lib/external/bwidget/listbox.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,1179 @@
+# ------------------------------------------------------------------------------
+# listbox.tcl
+# This file is part of Unifix BWidget Toolkit
+# $Id$
+# ------------------------------------------------------------------------------
+# Index of commands:
+# - ListBox::create
+# - ListBox::configure
+# - ListBox::cget
+# - ListBox::insert
+# - ListBox::itemconfigure
+# - ListBox::itemcget
+# - ListBox::bindText
+# - ListBox::bindImage
+# - ListBox::delete
+# - ListBox::move
+# - ListBox::reorder
+# - ListBox::selection
+# - ListBox::exists
+# - ListBox::index
+# - ListBox::item - deprecated
+# - ListBox::items
+# - ListBox::see
+# - ListBox::edit
+# - ListBox::xview
+# - ListBox::yview
+# - ListBox::_update_edit_size
+# - ListBox::_destroy
+# - ListBox::_see
+# - ListBox::_update_scrollregion
+# - ListBox::_draw_item
+# - ListBox::_redraw_items
+# - ListBox::_redraw_selection
+# - ListBox::_redraw_listbox
+# - ListBox::_redraw_idle
+# - ListBox::_resize
+# - ListBox::_init_drag_cmd
+# - ListBox::_drop_cmd
+# - ListBox::_over_cmd
+# - ListBox::_auto_scroll
+# - ListBox::_scroll
+# ------------------------------------------------------------------------------
+
+
+namespace eval ListBox {
+ namespace eval Item {
+ Widget::declare ListBox::Item {
+ {-indent Int 0 0 {=0}}
+ {-text String "" 0}
+ {-font TkResource "" 0 listbox}
+ {-image TkResource "" 0 label}
+ {-window String "" 0}
+ {-fill TkResource black 0 {listbox -foreground}}
+ {-data String "" 0}
+ }
+ }
+
+ Widget::tkinclude ListBox canvas :cmd \
+ remove {-insertwidth -insertbackground -insertborderwidth -insertofftime \
+ -insertontime -selectborderwidth -closeenough -confine -scrollregion \
+ -xscrollincrement -yscrollincrement -width -height} \
+ initialize {-relief sunken -borderwidth 2 -takefocus 1 \
+ -highlightthickness 1 -width 200}
+
+ Widget::declare ListBox {
+ {-deltax Int 10 0 {=0 ""}}
+ {-deltay Int 15 0 {=0 ""}}
+ {-padx Int 20 0 {=0 ""}}
+ {-background TkResource "" 0 listbox}
+ {-selectbackground TkResource "" 0 listbox}
+ {-selectforeground TkResource "" 0 listbox}
+ {-width TkResource "" 0 listbox}
+ {-height TkResource "" 0 listbox}
+ {-redraw Boolean 1 0}
+ {-multicolumn Boolean 0 0}
+ {-dropovermode Flag "wpi" 0 "wpi"}
+ {-bg Synonym -background}
+ }
+ DragSite::include ListBox "LISTBOX_ITEM" 1
+ DropSite::include ListBox {
+ LISTBOX_ITEM {copy {} move {}}
+ }
+
+ Widget::addmap ListBox "" :cmd {-deltay -yscrollincrement}
+
+ proc ::ListBox { path args } { return [eval ListBox::create $path $args] }
+ proc use {} {}
+
+ variable _edit
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ListBox::create
+# ------------------------------------------------------------------------------
+proc ListBox::create { path args } {
+ Widget::init ListBox $path $args
+
+ variable $path
+ upvar 0 $path data
+
+ # widget informations
+ set data(nrows) -1
+
+ # items informations
+ set data(items) {}
+ set data(selitems) {}
+
+ # update informations
+ set data(upd,level) 0
+ set data(upd,afterid) ""
+ set data(upd,level) 0
+ set data(upd,delete) {}
+
+ # drag and drop informations
+ set data(dnd,scroll) ""
+ set data(dnd,afterid) ""
+ set data(dnd,item) ""
+
+ eval canvas $path [Widget::subcget $path :cmd] \
+ -width [expr {[Widget::getoption $path -width]*8}] \
+ -height [expr {[Widget::getoption $path -height]*[Widget::getoption $path -deltay]}] \
+ -xscrollincrement 8
+
+ bind $path <Configure> "ListBox::_resize $path"
+ bind $path <Destroy> "ListBox::_destroy $path"
+
+ DragSite::setdrag $path $path ListBox::_init_drag_cmd [Widget::getoption $path -dragendcmd] 1
+ DropSite::setdrop $path $path ListBox::_over_cmd ListBox::_drop_cmd 1
+
+ rename $path ::$path:cmd
+ proc ::$path { cmd args } "return \[eval ListBox::\$cmd $path \$args\]"
+
+ return $path
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ListBox::configure
+# ------------------------------------------------------------------------------
+proc ListBox::configure { path args } {
+ set res [Widget::configure $path $args]
+
+ set ch1 [expr {[Widget::hasChanged $path -deltay dy] |
+ [Widget::hasChanged $path -padx val] |
+ [Widget::hasChanged $path -multicolumn val]}]
+
+ set ch2 [expr {[Widget::hasChanged $path -selectbackground val] |
+ [Widget::hasChanged $path -selectforeground val]}]
+
+ set redraw 0
+ if { [Widget::hasChanged $path -height h] } {
+ $path:cmd configure -height [expr {$h*$dy}]
+ set redraw 1
+ }
+ if { [Widget::hasChanged $path -width w] } {
+ $path:cmd configure -width [expr {$w*8}]
+ set redraw 1
+ }
+
+ if { !$redraw } {
+ if { $ch1 } {
+ _redraw_idle $path 2
+ } elseif { $ch2 } {
+ _redraw_idle $path 1
+ }
+ }
+
+ if { [Widget::hasChanged $path -redraw bool] && $bool } {
+ variable $path
+ upvar 0 $path data
+ set lvl $data(upd,level)
+ set data(upd,level) 0
+ _redraw_idle $path $lvl
+ }
+ set force [Widget::hasChanged $path -dragendcmd dragend]
+ DragSite::setdrag $path $path ListBox::_init_drag_cmd $dragend $force
+ DropSite::setdrop $path $path ListBox::_over_cmd ListBox::_drop_cmd
+
+ return $res
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ListBox::cget
+# ------------------------------------------------------------------------------
+proc ListBox::cget { path option } {
+ return [Widget::cget $path $option]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ListBox::insert
+# ------------------------------------------------------------------------------
+proc ListBox::insert { path index item args } {
+ variable $path
+ upvar 0 $path data
+
+ if { [lsearch $data(items) $item] != -1 } {
+ return -code error "item \"$item\" already exists"
+ }
+
+ Widget::init ListBox::Item $path.$item $args
+
+ if { ![string compare $index "end"] } {
+ lappend data(items) $item
+ } else {
+ set data(items) [linsert $data(items) $index $item]
+ }
+ set data(upd,create,$item) $item
+
+ _redraw_idle $path 2
+ return $item
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ListBox::itemconfigure
+# ------------------------------------------------------------------------------
+proc ListBox::itemconfigure { path item args } {
+ variable $path
+ upvar 0 $path data
+
+ if { [lsearch $data(items) $item] == -1 } {
+ return -code error "item \"$item\" does not exist"
+ }
+
+ set oldind [Widget::getoption $path.$item -indent]
+
+ set res [Widget::configure $path.$item $args]
+ set chind [Widget::hasChanged $path.$item -indent indent]
+ set chw [Widget::hasChanged $path.$item -window win]
+ set chi [Widget::hasChanged $path.$item -image img]
+ set cht [Widget::hasChanged $path.$item -text txt]
+ set chf [Widget::hasChanged $path.$item -font fnt]
+ set chfg [Widget::hasChanged $path.$item -fill fg]
+ set idn [$path:cmd find withtag n:$item]
+
+ if { $idn == "" } {
+ # item is not drawn yet
+ _redraw_idle $path 2
+ return $res
+ }
+
+ set oldb [$path:cmd bbox $idn]
+ set coords [$path:cmd coords $idn]
+ set padx [Widget::getoption $path -padx]
+ set x0 [expr {[lindex $coords 0]-$padx-$oldind+$indent}]
+ set y0 [lindex $coords 1]
+ if { $chw || $chi } {
+ # -window or -image modified
+ set idi [$path:cmd find withtag i:$item]
+ set type [lindex [$path:cmd gettags $idi] 0]
+ if { [string length $win] } {
+ if { ![string compare $type "win"] } {
+ $path:cmd itemconfigure $idi -window $win
+ } else {
+ $path:cmd delete $idi
+ $path:cmd create window $x0 $y0 -window $win -anchor w -tags "win i:$item"
+ }
+ } elseif { [string length $img] } {
+ if { ![string compare $type "img"] } {
+ $path:cmd itemconfigure $idi -image $img
+ } else {
+ $path:cmd delete $idi
+ $path:cmd create image $x0 $y0 -image $img -anchor w -tags "img i:$item"
+ }
+ } else {
+ $path:cmd delete $idi
+ }
+ }
+
+ if { $cht || $chf || $chfg } {
+ # -text or -font modified, or -fill modified
+ $path:cmd itemconfigure $idn -text $txt -font $fnt -fill $fg
+ _redraw_idle $path 1
+ }
+
+ if { $chind } {
+ # -indent modified
+ $path:cmd coords $idn [expr {$x0+$padx}] $y0
+ $path:cmd coords i:$item $x0 $y0
+ _redraw_idle $path 1
+ }
+
+ if { [Widget::getoption $path -multicolumn] && ($cht || $chf || $chind) } {
+ set bbox [$path:cmd bbox $idn]
+ if { [lindex $bbox 2] > [lindex $oldb 2] } {
+ _redraw_idle $path 2
+ }
+ }
+
+ return $res
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ListBox::itemcget
+# ------------------------------------------------------------------------------
+proc ListBox::itemcget { path item option } {
+ return [Widget::cget $path.$item $option]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ListBox::bindText
+# ------------------------------------------------------------------------------
+proc ListBox::bindText { path event script } {
+ if { $script != "" } {
+ $path:cmd bind "item" $event \
+ "$script \[string range \[lindex \[$path:cmd gettags current\] 1\] 2 end\]"
+ } else {
+ $path:cmd bind "item" $event {}
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ListBox::bindImage
+# ------------------------------------------------------------------------------
+proc ListBox::bindImage { path event script } {
+ if { $script != "" } {
+ $path:cmd bind "img" $event \
+ "$script \[string range \[lindex \[$path:cmd gettags current\] 1\] 2 end\]"
+ } else {
+ $path:cmd bind "img" $event {}
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ListBox::delete
+# ------------------------------------------------------------------------------
+proc ListBox::delete { path args } {
+ variable $path
+ upvar 0 $path data
+
+ foreach litems $args {
+ foreach item $litems {
+ set idx [lsearch $data(items) $item]
+ if { $idx != -1 } {
+ set data(items) [lreplace $data(items) $idx $idx]
+ Widget::destroy $path.$item
+ if { [info exists data(upd,create,$item)] } {
+ unset data(upd,create,$item)
+ } else {
+ lappend data(upd,delete) $item
+ }
+ }
+ }
+ }
+
+ set sel $data(selitems)
+ set data(selitems) {}
+ eval selection $path set $sel
+ _redraw_idle $path 2
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ListBox::move
+# ------------------------------------------------------------------------------
+proc ListBox::move { path item index } {
+ variable $path
+ upvar 0 $path data
+
+ if { [set idx [lsearch $data(items) $item]] == -1 } {
+ return -code error "item \"$item\" does not exist"
+ }
+
+ set data(items) [lreplace $data(items) $idx $idx]
+ if { ![string compare $index "end"] } {
+ lappend data($path,item) $item
+ } else {
+ set data(items) [linsert $data(items) $index $item]
+ }
+
+ _redraw_idle $path 2
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ListBox::reorder
+# ------------------------------------------------------------------------------
+proc ListBox::reorder { path neworder } {
+ variable $path
+ upvar 0 $path data
+
+ set data(items) [BWidget::lreorder $data(items) $neworder]
+ _redraw_idle $path 2
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ListBox::selection
+# ------------------------------------------------------------------------------
+proc ListBox::selection { path cmd args } {
+ variable $path
+ upvar 0 $path data
+
+ switch -- $cmd {
+ set {
+ set data(selitems) {}
+ foreach item $args {
+ if { [lsearch $data(selitems) $item] == -1 } {
+ if { [lsearch $data(items) $item] != -1 } {
+ lappend data(selitems) $item
+ }
+ }
+ }
+ }
+ add {
+ foreach item $args {
+ if { [lsearch $data(selitems) $item] == -1 } {
+ if { [lsearch $data(items) $item] != -1 } {
+ lappend data(selitems) $item
+ }
+ }
+ }
+ }
+ remove {
+ foreach item $args {
+ if { [set idx [lsearch $data(selitems) $item]] != -1 } {
+ set data(selitems) [lreplace $data(selitems) $idx $idx]
+ }
+ }
+ }
+ clear {
+ set data(selitems) {}
+ }
+ get {
+ return $data(selitems)
+ }
+ default {
+ return
+ }
+ }
+ _redraw_idle $path 1
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ListBox::exists
+# ------------------------------------------------------------------------------
+proc ListBox::exists { path item } {
+ variable $path
+ upvar 0 $path data
+
+ return [expr {[lsearch $data(items) $item] != -1}]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ListBox::index
+# ------------------------------------------------------------------------------
+proc ListBox::index { path item } {
+ variable $path
+ upvar 0 $path data
+
+ return [lsearch $data(items) $item]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ListBox::item - deprecated
+# ------------------------------------------------------------------------------
+proc ListBox::item { path first {last ""} } {
+ variable $path
+ upvar 0 $path data
+
+ if { ![string length $last] } {
+ return [lindex $data(items) $first]
+ } else {
+ return [lrange $data(items) $first $last]
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ListBox::items
+# ------------------------------------------------------------------------------
+proc ListBox::items { path {first ""} {last ""}} {
+ variable $path
+ upvar 0 $path data
+
+ if { ![string length $first] } {
+ return $data(items)
+ }
+
+ if { ![string length $last] } {
+ return [lindex $data(items) $first]
+ } else {
+ return [lrange $data(items) $first $last]
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ListBox::see
+# ------------------------------------------------------------------------------
+proc ListBox::see { path item } {
+ variable $path
+ upvar 0 $path data
+
+ if { [Widget::getoption $path -redraw] && $data(upd,afterid) != "" } {
+ after cancel $data(upd,afterid)
+ _redraw_listbox $path
+ }
+ set idn [$path:cmd find withtag n:$item]
+ if { $idn != "" } {
+ ListBox::_see $path $idn right
+ ListBox::_see $path $idn left
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ListBox::edit
+# ------------------------------------------------------------------------------
+proc ListBox::edit { path item text {verifycmd ""} {clickres 0} {select 1}} {
+ variable _edit
+ variable $path
+ upvar 0 $path data
+
+ if { [Widget::getoption $path -redraw] && $data(upd,afterid) != "" } {
+ after cancel $data(upd,afterid)
+ _redraw_listbox $path
+ }
+ set idn [$path:cmd find withtag n:$item]
+ if { $idn != "" } {
+ ListBox::_see $path $idn right
+ ListBox::_see $path $idn left
+
+ set oldfg [$path:cmd itemcget $idn -fill]
+ set sbg [Widget::getoption $path -selectbackground]
+ set coords [$path:cmd coords $idn]
+ set x [lindex $coords 0]
+ set y [lindex $coords 1]
+ set bd [expr {[$path:cmd cget -borderwidth]+[$path:cmd cget -highlightthickness]}]
+ set w [expr {[winfo width $path] - 2*$bd}]
+ set wmax [expr {[$path:cmd canvasx $w]-$x}]
+
+ $path:cmd itemconfigure $idn -fill [Widget::getoption $path -background]
+ $path:cmd itemconfigure s:$item -fill {} -outline {}
+
+ set _edit(text) $text
+ set _edit(wait) 0
+
+ set frame [frame $path.edit \
+ -relief flat -borderwidth 0 -highlightthickness 0 \
+ -background [Widget::getoption $path -background]]
+ set ent [entry $frame.edit \
+ -width 0 \
+ -relief solid \
+ -borderwidth 1 \
+ -highlightthickness 0 \
+ -foreground [Widget::getoption $path.$item -fill] \
+ -background [Widget::getoption $path -background] \
+ -selectforeground [Widget::getoption $path -selectforeground] \
+ -selectbackground $sbg \
+ -font [Widget::getoption $path.$item -font] \
+ -textvariable ListBox::_edit(text)]
+ pack $ent -ipadx 8 -anchor w
+
+ set idw [$path:cmd create window $x $y -window $frame -anchor w]
+ trace variable ListBox::_edit(text) w "ListBox::_update_edit_size $path $ent $idw $wmax"
+ tkwait visibility $ent
+ grab $frame
+ BWidget::focus set $ent
+ _update_edit_size $path $ent $idw $wmax
+ update
+ if { $select } {
+ $ent selection range 0 end
+ $ent icursor end
+ $ent xview end
+ }
+
+ bind $ent <Escape> {set ListBox::_edit(wait) 0}
+ bind $ent <Return> {set ListBox::_edit(wait) 1}
+ if { $clickres == 0 || $clickres == 1 } {
+ bind $frame <Button> "set ListBox::_edit(wait) $clickres"
+ }
+
+ set ok 0
+ while { !$ok } {
+ tkwait variable ListBox::_edit(wait)
+ if { !$_edit(wait) || $verifycmd == "" ||
+ [uplevel \#0 $verifycmd [list $_edit(text)]] } {
+ set ok 1
+ }
+ }
+ trace vdelete ListBox::_edit(text) w "ListBox::_update_edit_size $path $ent $idw $wmax"
+ grab release $frame
+ BWidget::focus release $ent
+ destroy $frame
+ $path:cmd delete $idw
+ $path:cmd itemconfigure $idn -fill $oldfg
+ $path:cmd itemconfigure s:$item -fill $sbg -outline $sbg
+
+ if { $_edit(wait) } {
+ return $_edit(text)
+ }
+ }
+ return ""
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ListBox::xview
+# ------------------------------------------------------------------------------
+proc ListBox::xview { path args } {
+ return [eval $path:cmd xview $args]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ListBox::yview
+# ------------------------------------------------------------------------------
+proc ListBox::yview { path args } {
+ return [eval $path:cmd yview $args]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ListBox::_update_edit_size
+# ------------------------------------------------------------------------------
+proc ListBox::_update_edit_size { path entry idw wmax args } {
+ set entw [winfo reqwidth $entry]
+ if { $entw >= $wmax } {
+ $path:cmd itemconfigure $idw -width $wmax
+ } else {
+ $path:cmd itemconfigure $idw -width 0
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ListBox::_destroy
+# ------------------------------------------------------------------------------
+proc ListBox::_destroy { path } {
+ variable $path
+ upvar 0 $path data
+
+ if { $data(upd,afterid) != "" } {
+ after cancel $data(upd,afterid)
+ }
+ if { $data(dnd,afterid) != "" } {
+ after cancel $data(dnd,afterid)
+ }
+ foreach item $data(items) {
+ Widget::destroy $path.$item
+ }
+
+ Widget::destroy $path
+ unset data
+ rename $path {}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ListBox::_see
+# ------------------------------------------------------------------------------
+proc ListBox::_see { path idn side } {
+ set bbox [$path:cmd bbox $idn]
+ set scrl [$path:cmd cget -scrollregion]
+
+ set ymax [lindex $scrl 3]
+ set dy [$path:cmd cget -yscrollincrement]
+ set yv [$path:cmd yview]
+ set yv0 [expr {round([lindex $yv 0]*$ymax/$dy)}]
+ set yv1 [expr {round([lindex $yv 1]*$ymax/$dy)}]
+ set y [expr {int([lindex [$path:cmd coords $idn] 1]/$dy)}]
+ if { $y < $yv0 } {
+ $path:cmd yview scroll [expr {$y-$yv0}] units
+ } elseif { $y >= $yv1 } {
+ $path:cmd yview scroll [expr {$y-$yv1+1}] units
+ }
+
+ set xmax [lindex $scrl 2]
+ set dx [$path:cmd cget -xscrollincrement]
+ set xv [$path:cmd xview]
+ if { ![string compare $side "right"] } {
+ set xv1 [expr {round([lindex $xv 1]*$xmax/$dx)}]
+ set x1 [expr {int([lindex $bbox 2]/$dx)}]
+ if { $x1 >= $xv1 } {
+ $path:cmd xview scroll [expr {$x1-$xv1+1}] units
+ }
+ } else {
+ set xv0 [expr {round([lindex $xv 0]*$xmax/$dx)}]
+ set x0 [expr {int([lindex $bbox 0]/$dx)}]
+ if { $x0 < $xv0 } {
+ $path:cmd xview scroll [expr {$x0-$xv0}] units
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ListBox::_update_scrollregion
+# ------------------------------------------------------------------------------
+proc ListBox::_update_scrollregion { path } {
+ set bd [expr {2*([$path:cmd cget -borderwidth]+[$path:cmd cget -highlightthickness])}]
+ set w [expr {[winfo width $path] - $bd}]
+ set h [expr {[winfo height $path] - $bd}]
+ set xinc [$path:cmd cget -xscrollincrement]
+ set yinc [$path:cmd cget -yscrollincrement]
+ set bbox [$path:cmd bbox all]
+ if { [llength $bbox] } {
+ set xs [lindex $bbox 2]
+ set ys [lindex $bbox 3]
+
+ if { $w < $xs } {
+ set w [expr {int($xs)}]
+ if { [set r [expr {$w % $xinc}]] } {
+ set w [expr {$w+$xinc-$r}]
+ }
+ }
+ if { $h < $ys } {
+ set h [expr {int($ys)}]
+ if { [set r [expr {$h % $yinc}]] } {
+ set h [expr {$h+$yinc-$r}]
+ }
+ }
+ }
+
+ $path:cmd configure -scrollregion [list 0 0 $w $h]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ListBox::_draw_item
+# ------------------------------------------------------------------------------
+proc ListBox::_draw_item { path item x0 x1 y } {
+ set indent [Widget::getoption $path.$item -indent]
+ $path:cmd create text [expr {$x1+$indent}] $y \
+ -text [Widget::getoption $path.$item -text] \
+ -fill [Widget::getoption $path.$item -fill] \
+ -font [Widget::getoption $path.$item -font] \
+ -anchor w \
+ -tags "item n:$item"
+ if { [set win [Widget::getoption $path.$item -window]] != "" } {
+ $path:cmd create window [expr {$x0+$indent}] $y \
+ -window $win -anchor w -tags "win i:$item"
+ } elseif { [set img [Widget::getoption $path.$item -image]] != "" } {
+ $path:cmd create image [expr {$x0+$indent}] $y \
+ -image $img -anchor w -tags "img i:$item"
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ListBox::_redraw_items
+# ------------------------------------------------------------------------------
+proc ListBox::_redraw_items { path } {
+ variable $path
+ upvar 0 $path data
+
+ $path:cmd configure -cursor watch
+ set dx [Widget::getoption $path -deltax]
+ set dy [Widget::getoption $path -deltay]
+ set padx [Widget::getoption $path -padx]
+ set y0 [expr {$dy/2}]
+ set x0 4
+ set x1 [expr {$x0+$padx}]
+ set nitem 0
+ set drawn {}
+ set data(xlist) {}
+ if { [Widget::getoption $path -multicolumn] } {
+ set nrows $data(nrows)
+ } else {
+ set nrows [llength $data(items)]
+ }
+ foreach item $data(upd,delete) {
+ $path:cmd delete i:$item n:$item s:$item
+ }
+ foreach item $data(items) {
+ if { [info exists data(upd,create,$item)] } {
+ _draw_item $path $item $x0 $x1 $y0
+ unset data(upd,create,$item)
+ } else {
+ set indent [Widget::getoption $path.$item -indent]
+ $path:cmd coords n:$item [expr {$x1+$indent}] $y0
+ $path:cmd coords i:$item [expr {$x0+$indent}] $y0
+ }
+ incr y0 $dy
+ incr nitem
+ lappend drawn n:$item
+ if { $nitem == $nrows } {
+ set y0 [expr {$dy/2}]
+ set bbox [eval $path:cmd bbox $drawn]
+ set drawn {}
+ set x0 [expr {[lindex $bbox 2]+$dx}]
+ set x1 [expr {$x0+$padx}]
+ set nitem 0
+ lappend data(xlist) [lindex $bbox 2]
+ }
+ }
+ if { $nitem && $nitem < $nrows } {
+ set bbox [eval $path:cmd bbox $drawn]
+ lappend data(xlist) [lindex $bbox 2]
+ }
+ set data(upd,delete) {}
+ $path:cmd configure -cursor [Widget::getoption $path -cursor]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ListBox::_redraw_selection
+# ------------------------------------------------------------------------------
+proc ListBox::_redraw_selection { path } {
+ variable $path
+ upvar 0 $path data
+
+ set selbg [Widget::getoption $path -selectbackground]
+ set selfg [Widget::getoption $path -selectforeground]
+ foreach id [$path:cmd find withtag sel] {
+ set item [string range [lindex [$path:cmd gettags $id] 1] 2 end]
+ $path:cmd itemconfigure "n:$item" -fill [Widget::getoption $path.$item -fill]
+ }
+ $path:cmd delete sel
+ foreach item $data(selitems) {
+ set bbox [$path:cmd bbox "n:$item"]
+ if { [llength $bbox] } {
+ set id [eval $path:cmd create rectangle $bbox -fill $selbg -outline $selbg -tags [list "sel s:$item"]]
+ $path:cmd itemconfigure "n:$item" -fill $selfg
+ $path:cmd lower $id
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ListBox::_redraw_listbox
+# ------------------------------------------------------------------------------
+proc ListBox::_redraw_listbox { path } {
+ variable $path
+ upvar 0 $path data
+
+ if { [Widget::getoption $path -redraw] } {
+ if { $data(upd,level) == 2 } {
+ _redraw_items $path
+ }
+ _redraw_selection $path
+ _update_scrollregion $path
+ set data(upd,level) 0
+ set data(upd,afterid) ""
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ListBox::_redraw_idle
+# ------------------------------------------------------------------------------
+proc ListBox::_redraw_idle { path level } {
+ variable $path
+ upvar 0 $path data
+
+ if { $data(nrows) != -1 } {
+ # widget is realized
+ if { [Widget::getoption $path -redraw] && $data(upd,afterid) == "" } {
+ set data(upd,afterid) [after idle ListBox::_redraw_listbox $path]
+ }
+ }
+ if { $level > $data(upd,level) } {
+ set data(upd,level) $level
+ }
+ return ""
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ListBox::_resize
+# ------------------------------------------------------------------------------
+proc ListBox::_resize { path } {
+ variable $path
+ upvar 0 $path data
+
+ if { [Widget::getoption $path -multicolumn] } {
+ set bd [expr {[$path:cmd cget -borderwidth]+[$path:cmd cget -highlightthickness]}]
+ set h [expr {[winfo height $path] - 2*$bd}]
+ set nrows [expr {$h/[$path:cmd cget -yscrollincrement]}]
+ if { $nrows == 0 } {
+ set nrows 1
+ }
+ if { $nrows != $data(nrows) } {
+ set data(nrows) $nrows
+ _redraw_idle $path 2
+ } else {
+ _update_scrollregion $path
+ }
+ } elseif { $data(nrows) == -1 } {
+ # first Configure event
+ set data(nrows) 0
+ ListBox::_redraw_listbox $path
+ } else {
+ _update_scrollregion $path
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ListBox::_init_drag_cmd
+# ------------------------------------------------------------------------------
+proc ListBox::_init_drag_cmd { path X Y top } {
+ set ltags [$path:cmd gettags current]
+ set item [lindex $ltags 0]
+ if { ![string compare $item "item"] ||
+ ![string compare $item "img"] ||
+ ![string compare $item "win"] } {
+ set item [string range [lindex $ltags 1] 2 end]
+ if { [set cmd [Widget::getoption $path -draginitcmd]] != "" } {
+ return [uplevel \#0 $cmd [list $path $item $top]]
+ }
+ if { [set type [Widget::getoption $path -dragtype]] == "" } {
+ set type "LISTBOX_ITEM"
+ }
+ if { [set img [Widget::getoption $path.$item -image]] != "" } {
+ pack [label $top.l -image $img -padx 0 -pady 0]
+ }
+ return [list $type {copy move link} $item]
+ }
+ return {}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ListBox::_drop_cmd
+# ------------------------------------------------------------------------------
+proc ListBox::_drop_cmd { path source X Y op type dnddata } {
+ variable $path
+ upvar 0 $path data
+
+ if { [string length $data(dnd,afterid)] } {
+ after cancel $data(dnd,afterid)
+ set data(dnd,afterid) ""
+ }
+ $path:cmd delete drop
+ set data(dnd,scroll) ""
+ if { [llength $data(dnd,item)] } {
+ if { [set cmd [Widget::getoption $path -dropcmd]] != "" } {
+ return [uplevel \#0 $cmd [list $path $source $data(dnd,item) $op $type $dnddata]]
+ }
+ }
+ return 0
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ListBox::_over_cmd
+# ------------------------------------------------------------------------------
+proc ListBox::_over_cmd { path source event X Y op type dnddata } {
+ variable $path
+ upvar 0 $path data
+
+ if { ![string compare $event "leave"] } {
+ # we leave the window listbox
+ $path:cmd delete drop
+ if { [string length $data(dnd,afterid)] } {
+ after cancel $data(dnd,afterid)
+ set data(dnd,afterid) ""
+ }
+ set data(dnd,scroll) ""
+ return 0
+ }
+
+ if { ![string compare $event "enter"] } {
+ # we enter the window listbox - dnd data initialization
+ set mode [Widget::getoption $path -dropovermode]
+ set data(dnd,mode) 0
+ foreach c {w p i} {
+ set data(dnd,mode) [expr {($data(dnd,mode) << 1) | ([string first $c $mode] != -1)}]
+ }
+ }
+
+ set x [expr {$X-[winfo rootx $path]}]
+ set y [expr {$Y-[winfo rooty $path]}]
+ $path:cmd delete drop
+ set data(dnd,item) ""
+
+ # test for auto-scroll unless mode is widget only
+ if { $data(dnd,mode) != 4 && [_auto_scroll $path $x $y] != "" } {
+ return 2
+ }
+
+ if { $data(dnd,mode) & 4 } {
+ # dropovermode includes widget
+ set target [list widget]
+ set vmode 4
+ } else {
+ set target [list ""]
+ set vmode 0
+ }
+
+ if { $data(dnd,mode) & 3 } {
+ # dropovermode includes item or position
+ # we extract the box (xi,yi,xs,ys) where we can find item around x,y
+ set len [llength $data(items)]
+ set xc [$path:cmd canvasx $x]
+ set yc [$path:cmd canvasy $y]
+ set dy [$path:cmd cget -yscrollincrement]
+ set line [expr {int($yc/$dy)}]
+ set yi [expr {$line*$dy}]
+ set ys [expr {$yi+$dy}]
+ set xi 0
+ set pos $line
+ if { [Widget::getoption $path -multicolumn] } {
+ set nrows $data(nrows)
+ } else {
+ set nrows $len
+ }
+ if { $line < $nrows } {
+ foreach xs $data(xlist) {
+ if { $xc <= $xs } {
+ break
+ }
+ set xi $xs
+ incr pos $nrows
+ }
+ if { $pos < $len } {
+ set item [lindex $data(items) $pos]
+ if { $data(dnd,mode) & 1 } {
+ # dropovermode includes item
+ lappend target $item
+ set vmode [expr {$vmode | 1}]
+ } else {
+ lappend target ""
+ }
+
+ if { $data(dnd,mode) & 2 } {
+ # dropovermode includes position
+ if { $yc >= $yi+$dy/2 } {
+ # position is after $item
+ incr pos
+ set yl $ys
+ } else {
+ # position is before $item
+ set yl $yi
+ }
+ lappend target $pos
+ set vmode [expr {$vmode | 2}]
+ } else {
+ lappend target ""
+ }
+ } else {
+ lappend target "" ""
+ }
+ } else {
+ lappend target "" ""
+ }
+
+ if { ($vmode & 3) == 3 } {
+ # result have both item and position
+ # we compute what is the preferred method
+ if { $yc-$yi <= 3 || $ys-$yc <= 3 } {
+ lappend target "position"
+ } else {
+ lappend target "item"
+ }
+ }
+ }
+
+ if { $vmode && [set cmd [Widget::getoption $path -dropovercmd]] != "" } {
+ # user-defined dropover command
+ set res [uplevel \#0 $cmd [list $source $target $op $type $dnddata]]
+ set code [lindex $res 0]
+ set vmode 0
+ if { $code & 1 } {
+ # update vmode
+ set mode [lindex $res 1]
+ if { ![string compare $mode "item"] } {
+ set vmode 1
+ } elseif { ![string compare $mode "position"] } {
+ set vmode 2
+ } elseif { ![string compare $mode "widget"] } {
+ set vmode 4
+ }
+ }
+ } else {
+ if { ($vmode & 3) == 3 } {
+ # result have both item and position
+ # we choose the preferred method
+ if { ![string compare [lindex $target 3] "position"] } {
+ set vmode [expr {$vmode & ~1}]
+ } else {
+ set vmode [expr {$vmode & ~2}]
+ }
+ }
+
+ if { $data(dnd,mode) == 4 || $data(dnd,mode) == 0 } {
+ # dropovermode is widget or empty - recall is not necessary
+ set code 1
+ } else {
+ set code 3
+ }
+ }
+
+ # draw dnd visual following vmode
+ if { $vmode & 1 } {
+ set data(dnd,item) [list "item" [lindex $target 1]]
+ $path:cmd create rectangle $xi $yi $xs $ys -tags drop
+ } elseif { $vmode & 2 } {
+ set data(dnd,item) [concat "position" [lindex $target 2]]
+ $path:cmd create line $xi $yl $xs $yl -tags drop
+ } elseif { $vmode & 4 } {
+ set data(dnd,item) [list "widget"]
+ } else {
+ set code [expr {$code & 2}]
+ }
+
+ if { $code & 1 } {
+ DropSite::setcursor based_arrow_down
+ } else {
+ DropSite::setcursor dot
+ }
+ return $code
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ListBox::_auto_scroll
+# ------------------------------------------------------------------------------
+proc ListBox::_auto_scroll { path x y } {
+ variable $path
+ upvar 0 $path data
+
+ set xmax [winfo width $path]
+ set ymax [winfo height $path]
+ set scroll {}
+ if { $y <= 6 } {
+ if { [lindex [$path:cmd yview] 0] > 0 } {
+ set scroll [list yview -1]
+ DropSite::setcursor sb_up_arrow
+ }
+ } elseif { $y >= $ymax-6 } {
+ if { [lindex [$path:cmd yview] 1] < 1 } {
+ set scroll [list yview 1]
+ DropSite::setcursor sb_down_arrow
+ }
+ } elseif { $x <= 6 } {
+ if { [lindex [$path:cmd xview] 0] > 0 } {
+ set scroll [list xview -1]
+ DropSite::setcursor sb_left_arrow
+ }
+ } elseif { $x >= $xmax-6 } {
+ if { [lindex [$path:cmd xview] 1] < 1 } {
+ set scroll [list xview 1]
+ DropSite::setcursor sb_right_arrow
+ }
+ }
+
+ if { [string length $data(dnd,afterid)] && [string compare $data(dnd,scroll) $scroll] } {
+ after cancel $data(dnd,afterid)
+ set data(dnd,afterid) ""
+ }
+
+ set data(dnd,scroll) $scroll
+ if { [llength $scroll] && ![string length $data(dnd,afterid)] } {
+ set data(dnd,afterid) [after 200 ListBox::_scroll $path $scroll]
+ }
+ return $data(dnd,afterid)
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ListBox::_scroll
+# ------------------------------------------------------------------------------
+proc ListBox::_scroll { path cmd dir } {
+ variable $path
+ upvar 0 $path data
+
+ if { ($dir == -1 && [lindex [$path:cmd $cmd] 0] > 0) ||
+ ($dir == 1 && [lindex [$path:cmd $cmd] 1] < 1) } {
+ $path $cmd scroll $dir units
+ set data(dnd,afterid) [after 100 ListBox::_scroll $path $cmd $dir]
+ } else {
+ set data(dnd,afterid) ""
+ DropSite::setcursor dot
+ }
+}
Deleted: grass/trunk/lib/external/bwidget/mainframe.tcl
===================================================================
--- grass/trunk/lib/external/bwidget/mainframe.tcl 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/mainframe.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,517 +0,0 @@
-# ------------------------------------------------------------------------------
-# mainframe.tcl
-# This file is part of Unifix BWidget Toolkit
-# $Id$
-# ------------------------------------------------------------------------------
-# Index of commands:
-# - MainFrame::create
-# - MainFrame::configure
-# - MainFrame::cget
-# - MainFrame::getframe
-# - MainFrame::addtoolbar
-# - MainFrame::gettoolbar
-# - MainFrame::addindicator
-# - MainFrame::getindicator
-# - MainFrame::getmenu
-# - MainFrame::showtoolbar
-# - MainFrame::showstatusbar
-# - MainFrame::_create_menubar
-# - MainFrame::_create_entries
-# - MainFrame::_parse_name
-# - MainFrame::_parse_accelerator
-# ------------------------------------------------------------------------------
-
-if [catch {package require msgcat}] {
- proc G_msg {message} {
- return $message
- }
-} else {
- ::msgcat::mcload $env(GISBASE)/etc/msgs
- proc G_msg {message} {
- return [::msgcat::mc $message]
- }
-}
-
-namespace eval MainFrame {
- ProgressBar::use
-
- Widget::bwinclude MainFrame ProgressBar .status.prg \
- remove {
- -fg -bg -bd -troughcolor -background -borderwidth
- -relief -orient -width -height
- } \
- rename {
- -maximum -progressmax
- -variable -progressvar
- -type -progresstype
- -foreground -progressfg
- }
-
- Widget::declare MainFrame {
- {-width TkResource 0 0 frame}
- {-height TkResource 0 0 frame}
- {-background TkResource "" 0 frame}
- {-textvariable String "" 0}
- {-menu String {} 1}
- {-separator Enum both 1 {none top bottom both}}
- {-bg Synonym -background}
- }
-
- Widget::addmap MainFrame "" .frame {-width {} -height {} -background {}}
- Widget::addmap MainFrame "" .topf {-background {}}
- Widget::addmap MainFrame "" .botf {-background {}}
- Widget::addmap MainFrame "" .status {-background {}}
- Widget::addmap MainFrame "" .status.label {-background {}}
- Widget::addmap MainFrame "" .status.indf {-background {}}
- Widget::addmap MainFrame "" .status.prgf {-background {}}
- Widget::addmap MainFrame ProgressBar .status.prg {-background {} -background -troughcolor}
-
- proc ::MainFrame { path args } { return [eval MainFrame::create $path $args] }
- proc use {} {}
-
- variable _widget
-}
-
-
-# ------------------------------------------------------------------------------
-# Command MainFrame::create
-# ------------------------------------------------------------------------------
-proc MainFrame::create { path args } {
- global tcl_platform
- variable _widget
-
- set path [frame $path -takefocus 0 -highlightthickness 0]
- set top [winfo parent $path]
- if { [string compare [winfo toplevel $path] $top] } {
- destroy $path
- return -code error "parent must be a toplevel"
- }
- Widget::init MainFrame $path $args
-
- set bg [Widget::getoption $path -background]
- if { $tcl_platform(platform) == "unix" } {
- set relief raised
- set bd 1
- } else {
- set relief flat
- set bd 0
- }
- $path configure -background $bg
- set topframe [frame $path.topf -relief flat -borderwidth 0 -background $bg]
- set userframe [eval frame $path.frame [Widget::subcget $path .frame] \
- -relief $relief -borderwidth $bd]
- set botframe [frame $path.botf -relief $relief -borderwidth $bd -background $bg]
-
- pack $topframe -fill x
- grid columnconfigure $topframe 0 -weight 1
-
- if { $tcl_platform(platform) != "unix" } {
- set sepopt [Widget::getoption $path -separator]
- if { $sepopt == "both" || $sepopt == "top" } {
- set sep [Separator::create $path.sep -orient horizontal -background $bg]
- pack $sep -fill x
- }
- if { $sepopt == "both" || $sepopt == "bottom" } {
- set sep [Separator::create $botframe.sep -orient horizontal -background $bg]
- pack $sep -fill x
- }
- }
-
- # --- status bar -------------------------------------------------------------------------
- set status [frame $path.status -relief flat -borderwidth 0 \
- -takefocus 0 -highlightthickness 0 -background $bg]
- set label [label $status.label -textvariable [Widget::getoption $path -textvariable] \
- -takefocus 0 -highlightthickness 0 -background $bg]
- set indframe [frame $status.indf -relief flat -borderwidth 0 \
- -takefocus 0 -highlightthickness 0 -background $bg]
- set prgframe [frame $status.prgf -relief flat -borderwidth 0 \
- -takefocus 0 -highlightthickness 0 -background $bg]
-
- place $label -anchor w -x 0 -rely 0.5
- place $indframe -anchor e -relx 1 -rely 0.5
- pack $prgframe -in $indframe -side left -padx 2
- $status configure -height [winfo reqheight $label]
-
- set progress [eval ProgressBar::create $status.prg [Widget::subcget $path .status.prg] \
- -width 50 \
- -height [expr {[winfo reqheight $label]-2}] \
- -borderwidth 1 \
- -relief sunken]
- pack $status -in $botframe -fill x -pady 2
- pack $botframe -side bottom -fill x
- pack $userframe -fill both -expand yes
-
- set _widget($path,top) $top
- set _widget($path,ntoolbar) 0
- set _widget($path,nindic) 0
-
- set menu [Widget::getoption $path -menu]
- if { [llength $menu] } {
- _create_menubar $path $menu
- }
-
- bind $path <Destroy> {MainFrame::_destroy %W}
-
- rename $path ::$path:cmd
- proc ::$path { cmd args } "return \[eval MainFrame::\$cmd $path \$args\]"
-
- return $path
-}
-
-
-# ------------------------------------------------------------------------------
-# Command MainFrame::configure
-# ------------------------------------------------------------------------------
-proc MainFrame::configure { path args } {
- variable _widget
-
- set res [Widget::configure $path $args]
-
- if { [Widget::hasChanged $path -textvariable newv] } {
- uplevel \#0 $path.status.label configure -textvariable [list $newv]
- }
-
- if { [Widget::hasChanged $path -background bg] } {
- set listmenu [$_widget($path,top) cget -menu]
- while { [llength $listmenu] } {
- set newlist {}
- foreach menu $listmenu {
- $menu configure -background $bg
- set newlist [concat $newlist [winfo children $menu]]
- }
- set listmenu $newlist
- }
- foreach sep {.sep .botf.sep} {
- if { [winfo exists $path.$sep] } {
- Separator::configure $path.$sep -background $bg
- }
- }
- foreach w [winfo children $path.topf] {
- $w configure -background $bg
- }
- }
- return $res
-}
-
-
-# ------------------------------------------------------------------------------
-# Command MainFrame::cget
-# ------------------------------------------------------------------------------
-proc MainFrame::cget { path option } {
- return [Widget::cget $path $option]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command MainFrame::getframe
-# ------------------------------------------------------------------------------
-proc MainFrame::getframe { path } {
- return $path.frame
-}
-
-
-# ------------------------------------------------------------------------------
-# Command MainFrame::addtoolbar
-# ------------------------------------------------------------------------------
-proc MainFrame::addtoolbar { path } {
- global tcl_platform
- variable _widget
-
- set index $_widget($path,ntoolbar)
- set toolframe $path.topf.f$index
- set toolbar $path.topf.tb$index
- set bg [Widget::getoption $path -background]
- if { $tcl_platform(platform) == "unix" } {
- frame $toolframe -relief raised -borderwidth 1 \
- -takefocus 0 -highlightthickness 0 -background $bg
- } else {
- frame $toolframe -relief flat -borderwidth 0 -takefocus 0 \
- -highlightthickness 0 -background $bg
- set sep [Separator::create $toolframe.sep -orient horizontal -background $bg]
- pack $sep -fill x
- }
- set toolbar [frame $toolbar -relief flat -borderwidth 2 \
- -takefocus 0 -highlightthickness 0 -background $bg]
- pack $toolbar -in $toolframe -anchor w
- incr _widget($path,ntoolbar)
- grid $toolframe -column 0 -row $index -sticky ew
- return $toolbar
-}
-
-
-# ------------------------------------------------------------------------------
-# Command MainFrame::gettoolbar
-# ------------------------------------------------------------------------------
-proc MainFrame::gettoolbar { path index } {
- return $path.topf.tb$index
-}
-
-
-# ------------------------------------------------------------------------------
-# Command MainFrame::addindicator
-# ------------------------------------------------------------------------------
-proc MainFrame::addindicator { path args } {
- variable _widget
-
- set index $_widget($path,nindic)
- set indic $path.status.indf.f$index
- eval label $indic $args -relief sunken -borderwidth 1 \
- -takefocus 0 -highlightthickness 0
-
- pack $indic -side left -anchor w -padx 2
-
- incr _widget($path,nindic)
-
- return $indic
-}
-
-
-# ------------------------------------------------------------------------------
-# Command MainFrame::getindicator
-# ------------------------------------------------------------------------------
-proc MainFrame::getindicator { path index } {
- return $path.status.indf.f$index
-}
-
-
-# ------------------------------------------------------------------------------
-# Command MainFrame::getmenu
-# ------------------------------------------------------------------------------
-proc MainFrame::getmenu { path menuid } {
- variable _widget
-
- if { [info exists _widget($path,menuid,$menuid)] } {
- return $_widget($path,menuid,$menuid)
- }
- return ""
-}
-
-
-# ------------------------------------------------------------------------------
-# Command MainFrame::setmenustate
-# ------------------------------------------------------------------------------
-proc MainFrame::setmenustate { path tag state } {
- variable _widget
-
- if { [info exists _widget($path,tags,$tag)] } {
- foreach {menu entry} $_widget($path,tags,$tag) {
- $menu entryconfigure $entry -state $state
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command MainFrame::showtoolbar
-# ------------------------------------------------------------------------------
-proc MainFrame::showtoolbar { path index bool } {
- variable _widget
-
- set toolframe $path.topf.f$index
- if { [winfo exists $toolframe] } {
- if { !$bool && [llength [grid info $toolframe]] } {
- grid forget $toolframe
- $path.topf configure -height 1
- } elseif { $bool && ![llength [grid info $toolframe]] } {
- grid $toolframe -column 0 -row $index -sticky ew
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command MainFrame::showstatusbar
-# ------------------------------------------------------------------------------
-proc MainFrame::showstatusbar { path name } {
- set status $path.status
- if { ![string compare $name "none"] } {
- pack forget $status
- } else {
- pack $status -fill x
- switch -- $name {
- status {
- catch {pack forget $status.prg}
- }
- progression {
- pack $status.prg -in $status.prgf
- }
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command MainFrame::_destroy
-# ------------------------------------------------------------------------------
-proc MainFrame::_destroy { path } {
- variable _widget
-
- Widget::destroy $path
- catch {destroy [$_widget($path,top) cget -menu]}
- $_widget($path,top) configure -menu {}
- unset _widget($path,top)
- unset _widget($path,ntoolbar)
- unset _widget($path,nindic)
- rename $path {}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command MainFrame::_create_menubar
-# ------------------------------------------------------------------------------
-proc MainFrame::_create_menubar { path descmenu } {
- variable _widget
- global tcl_platform
-
- set bg [Widget::getoption $path -background]
- set top $_widget($path,top)
- if { $tcl_platform(platform) == "unix" } {
- set menubar [menu $top.menubar -tearoff 0 -background $bg -borderwidth 1]
- } else {
- set menubar [menu $top.menubar -tearoff 0 -background $bg]
- }
- $top configure -menu $menubar
-
- set count 0
- foreach {name tags menuid tearoff entries} $descmenu {
- set opt [_parse_name [G_msg $name]]
- if { [string length $menuid] && ![info exists _widget($path,menuid,$menuid)] } {
- # menu has identifier
- # we use it for its pathname, to enable special menu entries
- # (help, system, ...)
- set menu $menubar.$menuid
- } else {
- set menu $menubar.menu$count
- }
- eval $menubar add cascad $opt -menu $menu
- menu $menu -tearoff $tearoff -background $bg
- foreach tag $tags {
- lappend _widget($path,tags,$tag) $menubar $count
- }
- if { [string length $menuid] } {
- # menu has identifier
- set _widget($path,menuid,$menuid) $menu
- }
- _create_entries $path $menu $bg $entries
- incr count
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command MainFrame::_create_entries
-# ------------------------------------------------------------------------------
-proc MainFrame::_create_entries { path menu bg entries } {
- variable _widget
-
- set count [$menu cget -tearoff]
- set registered 0
- foreach entry $entries {
- set len [llength $entry]
- set type [lindex $entry 0]
-
- if { ![string compare $type "separator"] } {
- $menu add separator
- incr count
- continue
- }
-
- # entry name and tags
- set opt [_parse_name [G_msg [lindex $entry 1]]]
- set tags [lindex $entry 2]
- foreach tag $tags {
- lappend _widget($path,tags,$tag) $menu $count
- }
-
- if { ![string compare $type "cascad"] } {
- set menuid [lindex $entry 3]
- set tearoff [lindex $entry 4]
- set submenu $menu.menu$count
- eval $menu add cascad $opt -menu $submenu
- menu $submenu -tearoff $tearoff -background $bg
- if { [string length $menuid] } {
- # menu has identifier
- set _widget($path,menuid,$menuid) $submenu
- }
- _create_entries $path $submenu $bg [lindex $entry 5]
- incr count
- continue
- }
-
- # entry help description
- set desc [G_msg [lindex $entry 3]]
- if { [string length $desc] } {
- if { !$registered } {
- DynamicHelp::register $menu menu [Widget::getoption $path -textvariable]
- set registered 1
- }
- DynamicHelp::register $menu menuentry $count $desc
- }
-
- # entry accelerator
- set accel [_parse_accelerator [lindex $entry 4]]
- if { [llength $accel] } {
- lappend opt -accelerator [lindex $accel 0]
- bind $_widget($path,top) [lindex $accel 1] "$menu invoke $count"
- }
-
- # user options
- set useropt [lrange $entry 5 end]
- if { ![string compare $type "command"] ||
- ![string compare $type "radiobutton"] ||
- ![string compare $type "checkbutton"] } {
- eval $menu add $type $opt $useropt
- } else {
- return -code error "invalid menu type \"$type\""
- }
- incr count
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command MainFrame::_parse_name
-# ------------------------------------------------------------------------------
-proc MainFrame::_parse_name { menuname } {
- set idx [string first "&" $menuname]
- if { $idx == -1 } {
- return [list -label $menuname]
- } else {
- set beg [string range $menuname 0 [expr $idx-1]]
- set end [string range $menuname [expr $idx+1] end]
- append beg $end
- return [list -label $beg -underline $idx]
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command MainFrame::_parse_accelerator
-# ------------------------------------------------------------------------------
-proc MainFrame::_parse_accelerator { desc } {
- if { [llength $desc] == 2 } {
- set seq [lindex $desc 0]
- set key [lindex $desc 1]
- switch -- $seq {
- Ctrl {
- set accel "Ctrl+[string toupper $key]"
- set event "<Control-Key-[string tolower $key]>"
- }
- Alt {
- set accel "Atl+[string toupper $key]"
- set event "<Alt-Key-[string tolower $key]>"
- }
- CtrlAlt {
- set accel "Ctrl+Alt+[string toupper $key]"
- set event "<Control-Alt-Key-[string tolower $key]>"
- }
- default {
- return -code error "invalid accelerator code $seq"
- }
- }
- return [list $accel $event]
- }
- return {}
-}
-
-
Copied: grass/trunk/lib/external/bwidget/mainframe.tcl (from rev 35192, grass/trunk/lib/external/bwidget/mainframe.tcl)
===================================================================
--- grass/trunk/lib/external/bwidget/mainframe.tcl (rev 0)
+++ grass/trunk/lib/external/bwidget/mainframe.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,517 @@
+# ------------------------------------------------------------------------------
+# mainframe.tcl
+# This file is part of Unifix BWidget Toolkit
+# $Id$
+# ------------------------------------------------------------------------------
+# Index of commands:
+# - MainFrame::create
+# - MainFrame::configure
+# - MainFrame::cget
+# - MainFrame::getframe
+# - MainFrame::addtoolbar
+# - MainFrame::gettoolbar
+# - MainFrame::addindicator
+# - MainFrame::getindicator
+# - MainFrame::getmenu
+# - MainFrame::showtoolbar
+# - MainFrame::showstatusbar
+# - MainFrame::_create_menubar
+# - MainFrame::_create_entries
+# - MainFrame::_parse_name
+# - MainFrame::_parse_accelerator
+# ------------------------------------------------------------------------------
+
+if [catch {package require msgcat}] {
+ proc G_msg {message} {
+ return $message
+ }
+} else {
+ ::msgcat::mcload $env(GISBASE)/etc/msgs
+ proc G_msg {message} {
+ return [::msgcat::mc $message]
+ }
+}
+
+namespace eval MainFrame {
+ ProgressBar::use
+
+ Widget::bwinclude MainFrame ProgressBar .status.prg \
+ remove {
+ -fg -bg -bd -troughcolor -background -borderwidth
+ -relief -orient -width -height
+ } \
+ rename {
+ -maximum -progressmax
+ -variable -progressvar
+ -type -progresstype
+ -foreground -progressfg
+ }
+
+ Widget::declare MainFrame {
+ {-width TkResource 0 0 frame}
+ {-height TkResource 0 0 frame}
+ {-background TkResource "" 0 frame}
+ {-textvariable String "" 0}
+ {-menu String {} 1}
+ {-separator Enum both 1 {none top bottom both}}
+ {-bg Synonym -background}
+ }
+
+ Widget::addmap MainFrame "" .frame {-width {} -height {} -background {}}
+ Widget::addmap MainFrame "" .topf {-background {}}
+ Widget::addmap MainFrame "" .botf {-background {}}
+ Widget::addmap MainFrame "" .status {-background {}}
+ Widget::addmap MainFrame "" .status.label {-background {}}
+ Widget::addmap MainFrame "" .status.indf {-background {}}
+ Widget::addmap MainFrame "" .status.prgf {-background {}}
+ Widget::addmap MainFrame ProgressBar .status.prg {-background {} -background -troughcolor}
+
+ proc ::MainFrame { path args } { return [eval MainFrame::create $path $args] }
+ proc use {} {}
+
+ variable _widget
+}
+
+
+# ------------------------------------------------------------------------------
+# Command MainFrame::create
+# ------------------------------------------------------------------------------
+proc MainFrame::create { path args } {
+ global tcl_platform
+ variable _widget
+
+ set path [frame $path -takefocus 0 -highlightthickness 0]
+ set top [winfo parent $path]
+ if { [string compare [winfo toplevel $path] $top] } {
+ destroy $path
+ return -code error "parent must be a toplevel"
+ }
+ Widget::init MainFrame $path $args
+
+ set bg [Widget::getoption $path -background]
+ if { $tcl_platform(platform) == "unix" } {
+ set relief raised
+ set bd 1
+ } else {
+ set relief flat
+ set bd 0
+ }
+ $path configure -background $bg
+ set topframe [frame $path.topf -relief flat -borderwidth 0 -background $bg]
+ set userframe [eval frame $path.frame [Widget::subcget $path .frame] \
+ -relief $relief -borderwidth $bd]
+ set botframe [frame $path.botf -relief $relief -borderwidth $bd -background $bg]
+
+ pack $topframe -fill x
+ grid columnconfigure $topframe 0 -weight 1
+
+ if { $tcl_platform(platform) != "unix" } {
+ set sepopt [Widget::getoption $path -separator]
+ if { $sepopt == "both" || $sepopt == "top" } {
+ set sep [Separator::create $path.sep -orient horizontal -background $bg]
+ pack $sep -fill x
+ }
+ if { $sepopt == "both" || $sepopt == "bottom" } {
+ set sep [Separator::create $botframe.sep -orient horizontal -background $bg]
+ pack $sep -fill x
+ }
+ }
+
+ # --- status bar -------------------------------------------------------------------------
+ set status [frame $path.status -relief flat -borderwidth 0 \
+ -takefocus 0 -highlightthickness 0 -background $bg]
+ set label [label $status.label -textvariable [Widget::getoption $path -textvariable] \
+ -takefocus 0 -highlightthickness 0 -background $bg]
+ set indframe [frame $status.indf -relief flat -borderwidth 0 \
+ -takefocus 0 -highlightthickness 0 -background $bg]
+ set prgframe [frame $status.prgf -relief flat -borderwidth 0 \
+ -takefocus 0 -highlightthickness 0 -background $bg]
+
+ place $label -anchor w -x 0 -rely 0.5
+ place $indframe -anchor e -relx 1 -rely 0.5
+ pack $prgframe -in $indframe -side left -padx 2
+ $status configure -height [winfo reqheight $label]
+
+ set progress [eval ProgressBar::create $status.prg [Widget::subcget $path .status.prg] \
+ -width 50 \
+ -height [expr {[winfo reqheight $label]-2}] \
+ -borderwidth 1 \
+ -relief sunken]
+ pack $status -in $botframe -fill x -pady 2
+ pack $botframe -side bottom -fill x
+ pack $userframe -fill both -expand yes
+
+ set _widget($path,top) $top
+ set _widget($path,ntoolbar) 0
+ set _widget($path,nindic) 0
+
+ set menu [Widget::getoption $path -menu]
+ if { [llength $menu] } {
+ _create_menubar $path $menu
+ }
+
+ bind $path <Destroy> {MainFrame::_destroy %W}
+
+ rename $path ::$path:cmd
+ proc ::$path { cmd args } "return \[eval MainFrame::\$cmd $path \$args\]"
+
+ return $path
+}
+
+
+# ------------------------------------------------------------------------------
+# Command MainFrame::configure
+# ------------------------------------------------------------------------------
+proc MainFrame::configure { path args } {
+ variable _widget
+
+ set res [Widget::configure $path $args]
+
+ if { [Widget::hasChanged $path -textvariable newv] } {
+ uplevel \#0 $path.status.label configure -textvariable [list $newv]
+ }
+
+ if { [Widget::hasChanged $path -background bg] } {
+ set listmenu [$_widget($path,top) cget -menu]
+ while { [llength $listmenu] } {
+ set newlist {}
+ foreach menu $listmenu {
+ $menu configure -background $bg
+ set newlist [concat $newlist [winfo children $menu]]
+ }
+ set listmenu $newlist
+ }
+ foreach sep {.sep .botf.sep} {
+ if { [winfo exists $path.$sep] } {
+ Separator::configure $path.$sep -background $bg
+ }
+ }
+ foreach w [winfo children $path.topf] {
+ $w configure -background $bg
+ }
+ }
+ return $res
+}
+
+
+# ------------------------------------------------------------------------------
+# Command MainFrame::cget
+# ------------------------------------------------------------------------------
+proc MainFrame::cget { path option } {
+ return [Widget::cget $path $option]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command MainFrame::getframe
+# ------------------------------------------------------------------------------
+proc MainFrame::getframe { path } {
+ return $path.frame
+}
+
+
+# ------------------------------------------------------------------------------
+# Command MainFrame::addtoolbar
+# ------------------------------------------------------------------------------
+proc MainFrame::addtoolbar { path } {
+ global tcl_platform
+ variable _widget
+
+ set index $_widget($path,ntoolbar)
+ set toolframe $path.topf.f$index
+ set toolbar $path.topf.tb$index
+ set bg [Widget::getoption $path -background]
+ if { $tcl_platform(platform) == "unix" } {
+ frame $toolframe -relief raised -borderwidth 1 \
+ -takefocus 0 -highlightthickness 0 -background $bg
+ } else {
+ frame $toolframe -relief flat -borderwidth 0 -takefocus 0 \
+ -highlightthickness 0 -background $bg
+ set sep [Separator::create $toolframe.sep -orient horizontal -background $bg]
+ pack $sep -fill x
+ }
+ set toolbar [frame $toolbar -relief flat -borderwidth 2 \
+ -takefocus 0 -highlightthickness 0 -background $bg]
+ pack $toolbar -in $toolframe -anchor w
+ incr _widget($path,ntoolbar)
+ grid $toolframe -column 0 -row $index -sticky ew
+ return $toolbar
+}
+
+
+# ------------------------------------------------------------------------------
+# Command MainFrame::gettoolbar
+# ------------------------------------------------------------------------------
+proc MainFrame::gettoolbar { path index } {
+ return $path.topf.tb$index
+}
+
+
+# ------------------------------------------------------------------------------
+# Command MainFrame::addindicator
+# ------------------------------------------------------------------------------
+proc MainFrame::addindicator { path args } {
+ variable _widget
+
+ set index $_widget($path,nindic)
+ set indic $path.status.indf.f$index
+ eval label $indic $args -relief sunken -borderwidth 1 \
+ -takefocus 0 -highlightthickness 0
+
+ pack $indic -side left -anchor w -padx 2
+
+ incr _widget($path,nindic)
+
+ return $indic
+}
+
+
+# ------------------------------------------------------------------------------
+# Command MainFrame::getindicator
+# ------------------------------------------------------------------------------
+proc MainFrame::getindicator { path index } {
+ return $path.status.indf.f$index
+}
+
+
+# ------------------------------------------------------------------------------
+# Command MainFrame::getmenu
+# ------------------------------------------------------------------------------
+proc MainFrame::getmenu { path menuid } {
+ variable _widget
+
+ if { [info exists _widget($path,menuid,$menuid)] } {
+ return $_widget($path,menuid,$menuid)
+ }
+ return ""
+}
+
+
+# ------------------------------------------------------------------------------
+# Command MainFrame::setmenustate
+# ------------------------------------------------------------------------------
+proc MainFrame::setmenustate { path tag state } {
+ variable _widget
+
+ if { [info exists _widget($path,tags,$tag)] } {
+ foreach {menu entry} $_widget($path,tags,$tag) {
+ $menu entryconfigure $entry -state $state
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command MainFrame::showtoolbar
+# ------------------------------------------------------------------------------
+proc MainFrame::showtoolbar { path index bool } {
+ variable _widget
+
+ set toolframe $path.topf.f$index
+ if { [winfo exists $toolframe] } {
+ if { !$bool && [llength [grid info $toolframe]] } {
+ grid forget $toolframe
+ $path.topf configure -height 1
+ } elseif { $bool && ![llength [grid info $toolframe]] } {
+ grid $toolframe -column 0 -row $index -sticky ew
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command MainFrame::showstatusbar
+# ------------------------------------------------------------------------------
+proc MainFrame::showstatusbar { path name } {
+ set status $path.status
+ if { ![string compare $name "none"] } {
+ pack forget $status
+ } else {
+ pack $status -fill x
+ switch -- $name {
+ status {
+ catch {pack forget $status.prg}
+ }
+ progression {
+ pack $status.prg -in $status.prgf
+ }
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command MainFrame::_destroy
+# ------------------------------------------------------------------------------
+proc MainFrame::_destroy { path } {
+ variable _widget
+
+ Widget::destroy $path
+ catch {destroy [$_widget($path,top) cget -menu]}
+ $_widget($path,top) configure -menu {}
+ unset _widget($path,top)
+ unset _widget($path,ntoolbar)
+ unset _widget($path,nindic)
+ rename $path {}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command MainFrame::_create_menubar
+# ------------------------------------------------------------------------------
+proc MainFrame::_create_menubar { path descmenu } {
+ variable _widget
+ global tcl_platform
+
+ set bg [Widget::getoption $path -background]
+ set top $_widget($path,top)
+ if { $tcl_platform(platform) == "unix" } {
+ set menubar [menu $top.menubar -tearoff 0 -background $bg -borderwidth 1]
+ } else {
+ set menubar [menu $top.menubar -tearoff 0 -background $bg]
+ }
+ $top configure -menu $menubar
+
+ set count 0
+ foreach {name tags menuid tearoff entries} $descmenu {
+ set opt [_parse_name [G_msg $name]]
+ if { [string length $menuid] && ![info exists _widget($path,menuid,$menuid)] } {
+ # menu has identifier
+ # we use it for its pathname, to enable special menu entries
+ # (help, system, ...)
+ set menu $menubar.$menuid
+ } else {
+ set menu $menubar.menu$count
+ }
+ eval $menubar add cascad $opt -menu $menu
+ menu $menu -tearoff $tearoff -background $bg
+ foreach tag $tags {
+ lappend _widget($path,tags,$tag) $menubar $count
+ }
+ if { [string length $menuid] } {
+ # menu has identifier
+ set _widget($path,menuid,$menuid) $menu
+ }
+ _create_entries $path $menu $bg $entries
+ incr count
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command MainFrame::_create_entries
+# ------------------------------------------------------------------------------
+proc MainFrame::_create_entries { path menu bg entries } {
+ variable _widget
+
+ set count [$menu cget -tearoff]
+ set registered 0
+ foreach entry $entries {
+ set len [llength $entry]
+ set type [lindex $entry 0]
+
+ if { ![string compare $type "separator"] } {
+ $menu add separator
+ incr count
+ continue
+ }
+
+ # entry name and tags
+ set opt [_parse_name [G_msg [lindex $entry 1]]]
+ set tags [lindex $entry 2]
+ foreach tag $tags {
+ lappend _widget($path,tags,$tag) $menu $count
+ }
+
+ if { ![string compare $type "cascad"] } {
+ set menuid [lindex $entry 3]
+ set tearoff [lindex $entry 4]
+ set submenu $menu.menu$count
+ eval $menu add cascad $opt -menu $submenu
+ menu $submenu -tearoff $tearoff -background $bg
+ if { [string length $menuid] } {
+ # menu has identifier
+ set _widget($path,menuid,$menuid) $submenu
+ }
+ _create_entries $path $submenu $bg [lindex $entry 5]
+ incr count
+ continue
+ }
+
+ # entry help description
+ set desc [G_msg [lindex $entry 3]]
+ if { [string length $desc] } {
+ if { !$registered } {
+ DynamicHelp::register $menu menu [Widget::getoption $path -textvariable]
+ set registered 1
+ }
+ DynamicHelp::register $menu menuentry $count $desc
+ }
+
+ # entry accelerator
+ set accel [_parse_accelerator [lindex $entry 4]]
+ if { [llength $accel] } {
+ lappend opt -accelerator [lindex $accel 0]
+ bind $_widget($path,top) [lindex $accel 1] "$menu invoke $count"
+ }
+
+ # user options
+ set useropt [lrange $entry 5 end]
+ if { ![string compare $type "command"] ||
+ ![string compare $type "radiobutton"] ||
+ ![string compare $type "checkbutton"] } {
+ eval $menu add $type $opt $useropt
+ } else {
+ return -code error "invalid menu type \"$type\""
+ }
+ incr count
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command MainFrame::_parse_name
+# ------------------------------------------------------------------------------
+proc MainFrame::_parse_name { menuname } {
+ set idx [string first "&" $menuname]
+ if { $idx == -1 } {
+ return [list -label $menuname]
+ } else {
+ set beg [string range $menuname 0 [expr $idx-1]]
+ set end [string range $menuname [expr $idx+1] end]
+ append beg $end
+ return [list -label $beg -underline $idx]
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command MainFrame::_parse_accelerator
+# ------------------------------------------------------------------------------
+proc MainFrame::_parse_accelerator { desc } {
+ if { [llength $desc] == 2 } {
+ set seq [lindex $desc 0]
+ set key [lindex $desc 1]
+ switch -- $seq {
+ Ctrl {
+ set accel "Ctrl+[string toupper $key]"
+ set event "<Control-Key-[string tolower $key]>"
+ }
+ Alt {
+ set accel "Atl+[string toupper $key]"
+ set event "<Alt-Key-[string tolower $key]>"
+ }
+ CtrlAlt {
+ set accel "Ctrl+Alt+[string toupper $key]"
+ set event "<Control-Alt-Key-[string tolower $key]>"
+ }
+ default {
+ return -code error "invalid accelerator code $seq"
+ }
+ }
+ return [list $accel $event]
+ }
+ return {}
+}
+
+
Deleted: grass/trunk/lib/external/bwidget/messagedlg.tcl
===================================================================
--- grass/trunk/lib/external/bwidget/messagedlg.tcl 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/messagedlg.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,111 +0,0 @@
-# ------------------------------------------------------------------------------
-# messagedlg.tcl
-# This file is part of Unifix BWidget Toolkit
-# ------------------------------------------------------------------------------
-# Index of commands:
-# - MessageDlg::create
-# ------------------------------------------------------------------------------
-
-namespace eval MessageDlg {
- Dialog::use
-
- Widget::tkinclude MessageDlg message .frame.msg \
- remove {-cursor -highlightthickness -highlightbackground -highlightcolor \
- -relief -borderwidth -takefocus -textvariable} \
- rename {-text -message} \
- initialize {-aspect 800 -anchor c -justify center}
-
- Widget::bwinclude MessageDlg Dialog "" \
- remove {-modal -image -bitmap -side -anchor -separator \
- -homogeneous -padx -pady -spacing}
-
- Widget::declare MessageDlg {
- {-icon Enum info 0 {none error info question warning}}
- {-type Enum user 0 {abortretryignore ok okcancel retrycancel yesno yesnocancel user}}
- {-buttons String "" 0}
- }
-
- proc ::MessageDlg { path args } { return [eval MessageDlg::create $path $args] }
- proc use { } {}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command MessageDlg::create
-# ------------------------------------------------------------------------------
-proc MessageDlg::create { path args } {
- global tcl_platform
-
- Widget::init MessageDlg "$path#Message" $args
- set type [Widget::getoption "$path#Message" -type]
- set title [Widget::getoption "$path#Message" -title]
- set icon [Widget::getoption "$path#Message" -icon]
- set defb -1
- set canb -1
- switch -- $type {
- abortretryignore {set lbut {abort retry ignore}}
- ok {set lbut {ok}; set defb 0 }
- okcancel {set lbut {ok cancel}; set defb 0; set canb 1}
- retrycancel {set lbut {retry cancel}; set defb 0; set canb 1}
- yesno {set lbut {yes no}; set defb 0; set canb 1}
- yesnocancel {set lbut {yes no cancel}; set defb 0; set canb 2}
- user {set lbut [Widget::getoption "$path#Message" -buttons]}
- }
- if { [Widget::getoption "$path#Message" -default] == -1 } {
- Widget::setoption "$path#Message" -default $defb
- }
- if { [Widget::getoption "$path#Message" -cancel] == -1 } {
- Widget::setoption "$path#Message" -cancel $canb
- }
- if { $title == "" } {
- set frame [frame $path -class MessageDlg]
- set title [option get $frame "${icon}Title" MessageDlg]
- destroy $frame
- if { $title == "" } {
- set title "Message"
- }
- }
- Widget::setoption "$path#Message" -title $title
- if { $tcl_platform(platform) == "unix" || $type == "user" } {
- if { $icon != "none" } {
- set image [Bitmap::get $icon]
- } else {
- set image ""
- }
- eval Dialog::create $path [Widget::subcget "$path#Message" ""] \
- -image $image -modal local -side bottom -anchor c
- set idbut 0
- foreach but $lbut {
- Dialog::add $path -text $but -name $but
- }
- set frame [Dialog::getframe $path]
-
- eval message $frame.msg [Widget::subcget "$path#Message" .frame.msg] \
- -relief flat -borderwidth 0 -highlightthickness 0 -textvariable {""}
- pack $frame.msg -side left -padx 3m -pady 1m -fill x -expand yes
-
- set res [Dialog::draw $path]
- } else {
- set parent [Widget::getoption "$path#Message" -parent]
- set def [lindex $lbut [Widget::getoption "$path#Message" -default]]
- set opt [list \
- -message [Widget::getoption "$path#Message" -message] \
- -type $type \
- -title $title]
- if { [winfo exists $parent] } {
- lappend opt -parent $parent
- }
- if { $def != "" } {
- lappend opt -default $def
- }
- if { $icon != "none" } {
- lappend opt -icon $icon
- }
- set res [eval tk_messageBox $opt]
- set res [lsearch $lbut $res]
- }
- Widget::destroy "$path#Message"
- destroy $path
-
- return $res
-}
Copied: grass/trunk/lib/external/bwidget/messagedlg.tcl (from rev 35192, grass/trunk/lib/external/bwidget/messagedlg.tcl)
===================================================================
--- grass/trunk/lib/external/bwidget/messagedlg.tcl (rev 0)
+++ grass/trunk/lib/external/bwidget/messagedlg.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,111 @@
+# ------------------------------------------------------------------------------
+# messagedlg.tcl
+# This file is part of Unifix BWidget Toolkit
+# ------------------------------------------------------------------------------
+# Index of commands:
+# - MessageDlg::create
+# ------------------------------------------------------------------------------
+
+namespace eval MessageDlg {
+ Dialog::use
+
+ Widget::tkinclude MessageDlg message .frame.msg \
+ remove {-cursor -highlightthickness -highlightbackground -highlightcolor \
+ -relief -borderwidth -takefocus -textvariable} \
+ rename {-text -message} \
+ initialize {-aspect 800 -anchor c -justify center}
+
+ Widget::bwinclude MessageDlg Dialog "" \
+ remove {-modal -image -bitmap -side -anchor -separator \
+ -homogeneous -padx -pady -spacing}
+
+ Widget::declare MessageDlg {
+ {-icon Enum info 0 {none error info question warning}}
+ {-type Enum user 0 {abortretryignore ok okcancel retrycancel yesno yesnocancel user}}
+ {-buttons String "" 0}
+ }
+
+ proc ::MessageDlg { path args } { return [eval MessageDlg::create $path $args] }
+ proc use { } {}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command MessageDlg::create
+# ------------------------------------------------------------------------------
+proc MessageDlg::create { path args } {
+ global tcl_platform
+
+ Widget::init MessageDlg "$path#Message" $args
+ set type [Widget::getoption "$path#Message" -type]
+ set title [Widget::getoption "$path#Message" -title]
+ set icon [Widget::getoption "$path#Message" -icon]
+ set defb -1
+ set canb -1
+ switch -- $type {
+ abortretryignore {set lbut {abort retry ignore}}
+ ok {set lbut {ok}; set defb 0 }
+ okcancel {set lbut {ok cancel}; set defb 0; set canb 1}
+ retrycancel {set lbut {retry cancel}; set defb 0; set canb 1}
+ yesno {set lbut {yes no}; set defb 0; set canb 1}
+ yesnocancel {set lbut {yes no cancel}; set defb 0; set canb 2}
+ user {set lbut [Widget::getoption "$path#Message" -buttons]}
+ }
+ if { [Widget::getoption "$path#Message" -default] == -1 } {
+ Widget::setoption "$path#Message" -default $defb
+ }
+ if { [Widget::getoption "$path#Message" -cancel] == -1 } {
+ Widget::setoption "$path#Message" -cancel $canb
+ }
+ if { $title == "" } {
+ set frame [frame $path -class MessageDlg]
+ set title [option get $frame "${icon}Title" MessageDlg]
+ destroy $frame
+ if { $title == "" } {
+ set title "Message"
+ }
+ }
+ Widget::setoption "$path#Message" -title $title
+ if { $tcl_platform(platform) == "unix" || $type == "user" } {
+ if { $icon != "none" } {
+ set image [Bitmap::get $icon]
+ } else {
+ set image ""
+ }
+ eval Dialog::create $path [Widget::subcget "$path#Message" ""] \
+ -image $image -modal local -side bottom -anchor c
+ set idbut 0
+ foreach but $lbut {
+ Dialog::add $path -text $but -name $but
+ }
+ set frame [Dialog::getframe $path]
+
+ eval message $frame.msg [Widget::subcget "$path#Message" .frame.msg] \
+ -relief flat -borderwidth 0 -highlightthickness 0 -textvariable {""}
+ pack $frame.msg -side left -padx 3m -pady 1m -fill x -expand yes
+
+ set res [Dialog::draw $path]
+ } else {
+ set parent [Widget::getoption "$path#Message" -parent]
+ set def [lindex $lbut [Widget::getoption "$path#Message" -default]]
+ set opt [list \
+ -message [Widget::getoption "$path#Message" -message] \
+ -type $type \
+ -title $title]
+ if { [winfo exists $parent] } {
+ lappend opt -parent $parent
+ }
+ if { $def != "" } {
+ lappend opt -default $def
+ }
+ if { $icon != "none" } {
+ lappend opt -icon $icon
+ }
+ set res [eval tk_messageBox $opt]
+ set res [lsearch $lbut $res]
+ }
+ Widget::destroy "$path#Message"
+ destroy $path
+
+ return $res
+}
Deleted: grass/trunk/lib/external/bwidget/notebook.tcl
===================================================================
--- grass/trunk/lib/external/bwidget/notebook.tcl 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/notebook.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,866 +0,0 @@
-# ------------------------------------------------------------------------------
-# notebook.tcl
-# This file is part of Unifix BWidget Toolkit
-# $Id$
-# ------------------------------------------------------------------------------
-# Index of commands:
-# - NoteBook::create
-# - NoteBook::configure
-# - NoteBook::cget
-# - NoteBook::compute_size
-# - NoteBook::insert
-# - NoteBook::delete
-# - NoteBook::itemconfigure
-# - NoteBook::itemcget
-# - NoteBook::bindtabs
-# - NoteBook::raise
-# - NoteBook::see
-# - NoteBook::page
-# - NoteBook::pages
-# - NoteBook::index
-# - NoteBook::getframe
-# - NoteBook::_test_page
-# - NoteBook::_itemconfigure
-# - NoteBook::_compute_width
-# - NoteBook::_get_x_page
-# - NoteBook::_xview
-# - NoteBook::_highlight
-# - NoteBook::_select
-# - NoteBook::_redraw
-# - NoteBook::_draw_page
-# - NoteBook::_draw_arrows
-# - NoteBook::_draw_area
-# - NoteBook::_resize
-# - NoteBook::_realize
-# ------------------------------------------------------------------------------
-
-namespace eval NoteBook {
- ArrowButton::use
-
- namespace eval Page {
- Widget::declare NoteBook::Page {
- {-state Enum normal 0 {normal disabled}}
- {-createcmd String "" 0}
- {-raisecmd String "" 0}
- {-leavecmd String "" 0}
- {-image TkResource "" 0 label}
- {-text String "" 0}
- }
- }
-
- Widget::declare NoteBook {
- {-foreground TkResource "" 0 button}
- {-background TkResource "" 0 button}
- {-activebackground TkResource "" 0 button}
- {-activeforeground TkResource "" 0 button}
- {-disabledforeground TkResource "" 0 button}
- {-font TkResource "" 0 button}
- {-side Enum top 1 {top bottom}}
- {-homogeneous Boolean 0 0}
- {-borderwidth Int 1 0 {=1 =2}}
- {-width Int 0 0 {=0 ""}}
- {-height Int 0 0 {=0 ""}}
-
- {-repeatdelay BwResource "" 0 ArrowButton}
- {-repeatinterval BwResource "" 0 ArrowButton}
-
- {-fg Synonym -foreground}
- {-bg Synonym -background}
- {-bd Synonym -borderwidth}
- }
-
- Widget::addmap NoteBook "" :cmd {-background {}}
- Widget::addmap NoteBook ArrowButton .fg \
- {-foreground {} -background {} -activeforeground {} -activebackground {} \
- -borderwidth {} -repeatinterval {} -repeatdelay {} -disabledforeground {}}
- Widget::addmap NoteBook ArrowButton .fd \
- {-foreground {} -background {} -activeforeground {} -activebackground {} \
- -borderwidth {} -repeatinterval {} -repeatdelay {} -disabledforeground {}}
-
- variable _warrow 12
-
- proc ::NoteBook { path args } { return [eval NoteBook::create $path $args] }
- proc use {} {}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command NoteBook::create
-# ------------------------------------------------------------------------------
-proc NoteBook::create { path args } {
- variable $path
- upvar 0 $path data
-
- Widget::init NoteBook $path $args
-
- set data(base) 0
- set data(select) ""
- set data(pages) {}
- set data(pages) {}
- set data(cpt) 0
- set data(realized) 0
- set data(wpage) 0
- set data(hpage) [expr {[font metrics [Widget::getoption $path -font] -linespace] + 6}]
- set bg [Widget::getoption $path -background]
-
- # --- creation du canvas -----------------------------------------------------------------
- set w [expr {[Widget::getoption $path -width]+4}]
- set h [expr {[Widget::getoption $path -height]+$data(hpage)+4}]
- canvas $path -relief flat -bd 0 -highlightthickness 0 -bg $bg -width $w -height $h
-
- # --- creation des arrow -----------------------------------------------------------------
- eval ArrowButton::create $path.fg [Widget::subcget $path .fg] \
- -highlightthickness 0 \
- -type button -dir left \
- -armcommand [list "NoteBook::_xview $path -1"]
-
- eval ArrowButton::create $path.fd [Widget::subcget $path .fd] \
- -highlightthickness 0 \
- -type button -dir right \
- -armcommand [list "NoteBook::_xview $path 1"]
-
- set col [BWidget::get3dcolor $path $bg]
- set data(dbg) [lindex $col 0]
- set data(lbg) [lindex $col 1]
-
- bind $path <Configure> "NoteBook::_realize $path"
- bind $path <Destroy> "NoteBook::_destroy $path"
-
- rename $path ::$path:cmd
- proc ::$path { cmd args } "return \[eval NoteBook::\$cmd $path \$args\]"
-
- return $path
-}
-
-
-# ------------------------------------------------------------------------------
-# Command NoteBook::configure
-# ------------------------------------------------------------------------------
-proc NoteBook::configure { path args } {
- variable $path
- upvar 0 $path data
-
- set res [Widget::configure $path $args]
- set redraw 0
- if { [set chf [Widget::hasChanged $path -font font]] ||
- [Widget::hasChanged $path -homogeneous foo] } {
- if { $chf } {
- set data(hpage) [expr {[font metrics $font -linespace] + 6}]
- }
- _compute_width $path
- set redraw 1
- }
- if { [Widget::hasChanged $path -background bg] } {
- set col [BWidget::get3dcolor $path $bg]
- set data(dbg) [lindex $col 0]
- set data(lbg) [lindex $col 1]
- set redraw 1
- }
- if { [Widget::hasChanged $path -foreground fg] ||
- [Widget::hasChanged $path -borderwidth bd] } {
- set redraw 1
- }
- set wc [Widget::hasChanged $path -width w]
- set hc [Widget::hasChanged $path -height h]
- if { $wc || $hc } {
- $path:cmd configure -width [expr {$w+4}] -height [expr {$h + $data(hpage)+4}]
- } elseif { $redraw } {
- _redraw $path
- }
-
- return $res
-}
-
-
-# ------------------------------------------------------------------------------
-# Command NoteBook::cget
-# ------------------------------------------------------------------------------
-proc NoteBook::cget { path option } {
- return [Widget::cget $path $option]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command NoteBook::compute_size
-# ------------------------------------------------------------------------------
-proc NoteBook::compute_size { path } {
- variable $path
- upvar 0 $path data
-
- set wmax 0
- set hmax 0
- update idletasks
- foreach page $data(pages) {
- set w [winfo reqwidth $path.f$page]
- set h [winfo reqheight $path.f$page]
- set wmax [expr {$w>$wmax ? $w : $wmax}]
- set hmax [expr {$h>$hmax ? $h : $hmax}]
- }
- configure $path -width $wmax -height $hmax
-}
-
-
-# ------------------------------------------------------------------------------
-# Command NoteBook::insert
-# ------------------------------------------------------------------------------
-proc NoteBook::insert { path index page args } {
- variable $path
- upvar 0 $path data
-
- if { [lsearch $data(pages) $page] != -1 } {
- return -code error "page \"$page\" already exists"
- }
-
- Widget::init NoteBook::Page $path.f$page $args
-
- set data(pages) [linsert $data(pages) $index $page]
- if { ![winfo exists $path.f$page] } {
- frame $path.f$page \
- -relief flat -background [Widget::getoption $path -background] -borderwidth 10
- set data($page,realized) 0
- }
- _compute_width $path
- _draw_page $path $page 1
- _redraw $path
-
- return $path.f$page
-}
-
-
-# ------------------------------------------------------------------------------
-# Command NoteBook::delete
-# ------------------------------------------------------------------------------
-proc NoteBook::delete { path page {destroyframe 1} } {
- variable $path
- upvar 0 $path data
-
- set pos [_test_page $path $page]
- set data(pages) [lreplace $data(pages) $pos $pos]
- _compute_width $path
- $path:cmd delete p:$page
- if { $data(select) == $page } {
- set data(select) ""
- }
- if { $pos < $data(base) } {
- incr data(base) -1
- }
- if { $destroyframe } {
- destroy $path.f$page
- }
- _redraw $path
-}
-
-
-# ------------------------------------------------------------------------------
-# Command NoteBook::itemconfigure
-# ------------------------------------------------------------------------------
-proc NoteBook::itemconfigure { path page args } {
- _test_page $path $page
- set res [_itemconfigure $path $page $args]
- _redraw $path
-
- return $res
-}
-
-
-# ------------------------------------------------------------------------------
-# Command NoteBook::itemcget
-# ------------------------------------------------------------------------------
-proc NoteBook::itemcget { path page option } {
- _test_page $path $page
- return [Widget::cget $path.f$page $option]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command NoteBook::bindtabs
-# ------------------------------------------------------------------------------
-proc NoteBook::bindtabs { path event script } {
- if { $script != "" } {
- $path:cmd bind "page" $event \
- "$script \[string range \[lindex \[$path:cmd gettags current\] 1\] 2 end\]"
- } else {
- $path:cmd bind "page" $event {}
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command NoteBook::move
-# ------------------------------------------------------------------------------
-proc NoteBook::move { path page index } {
- variable $path
- upvar 0 $path data
-
- set pos [_test_page $path $page]
- set data(pages) [linsert [lreplace $data(pages) $pos $pos] $index $page]
- _redraw $path
-}
-
-
-# ------------------------------------------------------------------------------
-# Command NoteBook::raise
-# ------------------------------------------------------------------------------
-proc NoteBook::raise { path {page ""} } {
- variable $path
- upvar 0 $path data
-
- if { $page != "" } {
- _test_page $path $page
- _select $path $page
- }
- return $data(select)
-}
-
-
-# ------------------------------------------------------------------------------
-# Command NoteBook::see
-# ------------------------------------------------------------------------------
-proc NoteBook::see { path page } {
- variable $path
- upvar 0 $path data
-
- set pos [_test_page $path $page]
- if { $pos < $data(base) } {
- set data(base) $pos
- _redraw $path
- } else {
- set w [expr {[winfo width $path]-1}]
- set fpage [expr {[_get_x_page $path $pos] + $data($page,width) + 6}]
- set idx $data(base)
- while { $idx < $pos && $fpage > $w } {
- set fpage [expr {$fpage - $data([lindex $data(pages) $idx],width)}]
- incr idx
- }
- if { $idx != $data(base) } {
- set data(base) $idx
- _redraw $path
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command NoteBook::page
-# ------------------------------------------------------------------------------
-proc NoteBook::page { path first {last ""} } {
- variable $path
- upvar 0 $path data
-
- if { $last == "" } {
- return [lindex $data(pages) $first]
- } else {
- return [lrange $data(pages) $first $last]
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command NoteBook::pages
-# ------------------------------------------------------------------------------
-proc NoteBook::pages { path {first ""} {last ""}} {
- variable $path
- upvar 0 $path data
-
- if { ![string length $first] } {
- return $data(pages)
- }
-
- if { ![string length $last] } {
- return [lindex $data(pages) $first]
- } else {
- return [lrange $data(pages) $first $last]
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command NoteBook::index
-# ------------------------------------------------------------------------------
-proc NoteBook::index { path page } {
- variable $path
- upvar 0 $path data
-
- return [lsearch $data(pages) $page]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command NoteBook::_destroy
-# ------------------------------------------------------------------------------
-proc NoteBook::_destroy { path } {
- variable $path
- upvar 0 $path data
-
- foreach page $data(pages) {
- Widget::destroy $path.f$page
- }
- Widget::destroy $path
- unset data
- rename $path {}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command NoteBook::getframe
-# ------------------------------------------------------------------------------
-proc NoteBook::getframe { path page } {
- return $path.f$page
-}
-
-
-# ------------------------------------------------------------------------------
-# Command NoteBook::_test_page
-# ------------------------------------------------------------------------------
-proc NoteBook::_test_page { path page } {
- variable $path
- upvar 0 $path data
-
- if { [set pos [lsearch $data(pages) $page]] == -1 } {
- return -code error "page \"$page\" does not exists"
- }
- return $pos
-}
-
-
-# ------------------------------------------------------------------------------
-# Command NoteBook::_itemconfigure
-# ------------------------------------------------------------------------------
-proc NoteBook::_itemconfigure { path page lres } {
- variable $path
- upvar 0 $path data
-
- set res [Widget::configure $path.f$page $lres]
- if { [Widget::hasChanged $path.f$page -text foo] } {
- _compute_width $path
- } elseif { [Widget::hasChanged $path.f$page -image foo] } {
- set data(hpage) [expr {[font metrics [Widget::getoption $path -font] -linespace] + 6}]
- _compute_width $path
- }
- if { [Widget::hasChanged $path.f$page -state state] &&
- $state == "disabled" && $data(select) == $page } {
- set data(select) ""
- }
- return $res
-}
-
-
-# ------------------------------------------------------------------------------
-# Command NoteBook::_compute_width
-# ------------------------------------------------------------------------------
-proc NoteBook::_compute_width { path } {
- variable $path
- upvar 0 $path data
-
- set font [Widget::getoption $path -font]
- set wmax 0
- set hmax $data(hpage)
- set wtot 0
- if { ![info exists data(textid)] } {
- set data(textid) [$path:cmd create text 0 -100 -font [Widget::getoption $path -font] -anchor nw]
- }
- set id $data(textid)
- $path:cmd itemconfigure $id -font [Widget::getoption $path -font]
- foreach page $data(pages) {
- $path:cmd itemconfigure $id -text [Widget::getoption $path.f$page -text]
- set wtext [expr {[lindex [$path:cmd bbox $id] 2]+20}]
- if { [set img [Widget::getoption $path.f$page -image]] != "" } {
- set wtext [expr {$wtext+[image width $img]+4}]
- set himg [expr {[image height $img]+6}]
- if { $himg > $hmax } {
- set hmax $himg
- }
- }
- set wmax [expr {$wtext>$wmax ? $wtext : $wmax}]
- incr wtot $wtext
- set data($page,width) $wtext
- }
- if { [Widget::getoption $path -homogeneous] } {
- foreach page $data(pages) {
- set data($page,width) $wmax
- }
- set wtot [expr {$wmax * [llength $data(pages)]}]
- }
- set data(hpage) $hmax
- set data(wpage) $wtot
-}
-
-
-# ------------------------------------------------------------------------------
-# Command NoteBook::_get_x_page
-# ------------------------------------------------------------------------------
-proc NoteBook::_get_x_page { path pos } {
- variable _warrow
- variable $path
- upvar 0 $path data
-
- set base $data(base)
- set x [expr {$_warrow+1}]
- if { $pos < $base } {
- foreach page [lrange $data(pages) $pos [expr {$base-1}]] {
- incr x [expr {-$data($page,width)}]
- }
- } elseif { $pos > $base } {
- foreach page [lrange $data(pages) $base [expr {$pos-1}]] {
- incr x $data($page,width)
- }
- }
- return $x
-}
-
-
-# ------------------------------------------------------------------------------
-# Command NoteBook::_xview
-# ------------------------------------------------------------------------------
-proc NoteBook::_xview { path inc } {
- variable $path
- upvar 0 $path data
-
- if { $inc == -1 } {
- set base [expr {$data(base)-1}]
- set dx $data([lindex $data(pages) $base],width)
- } else {
- set dx [expr {-$data([lindex $data(pages) $data(base)],width)}]
- set base [expr {$data(base)+1}]
- }
-
- if { $base >= 0 && $base < [llength $data(pages)] } {
- set data(base) $base
- $path:cmd move page $dx 0
- _draw_area $path
- _draw_arrows $path
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command NoteBook::_highlight
-# ------------------------------------------------------------------------------
-proc NoteBook::_highlight { type path page } {
- variable $path
- upvar 0 $path data
-
- if { ![string compare [Widget::getoption $path.f$page -state] "disabled"] } {
- return
- }
-
- switch -- $type {
- on {
- $path:cmd itemconfigure "$page:poly" -fill [Widget::getoption $path -activebackground]
- $path:cmd itemconfigure "$page:text" -fill [Widget::getoption $path -activeforeground]
- }
- off {
- $path:cmd itemconfigure "$page:poly" -fill [Widget::getoption $path -background]
- $path:cmd itemconfigure "$page:text" -fill [Widget::getoption $path -foreground]
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command NoteBook::_select
-# ------------------------------------------------------------------------------
-proc NoteBook::_select { path page } {
- variable $path
- upvar 0 $path data
-
- if { ![string compare [Widget::getoption $path.f$page -state] "normal"] } {
- set oldsel $data(select)
- if { [string compare $page $oldsel] } {
- if { $oldsel != "" } {
- if { [set cmd [Widget::getoption $path.f$oldsel -leavecmd]] != "" } {
- if { [set code [catch {uplevel \#0 $cmd} res]] == 1 || $res == 0 } {
- return -code $code $res
- }
- }
- set data(select) ""
- _draw_page $path $oldsel 0
- }
- set data(select) $page
- if { $page != "" } {
- if { !$data($page,realized) } {
- set data($page,realized) 1
- if { [set cmd [Widget::getoption $path.f$page -createcmd]] != "" } {
- uplevel \#0 $cmd
- }
- }
- if { [set cmd [Widget::getoption $path.f$page -raisecmd]] != "" } {
- uplevel \#0 $cmd
- }
- _draw_page $path $page 0
- }
- _draw_area $path
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command NoteBook::_redraw
-# ------------------------------------------------------------------------------
-proc NoteBook::_redraw { path } {
- variable $path
- upvar 0 $path data
-
- if { !$data(realized) } {
- return
- }
-
- foreach page $data(pages) {
- _draw_page $path $page 0
- }
- _draw_area $path
- _draw_arrows $path
-}
-
-
-# ------------------------------------------------------------------------------
-# Command NoteBook::_draw_page
-# ------------------------------------------------------------------------------
-proc NoteBook::_draw_page { path page create } {
- variable $path
- upvar 0 $path data
-
- # --- calcul des coordonnees et des couleurs de l'onglet ---------------------------------
- set pos [lsearch $data(pages) $page]
- set bg [Widget::getoption $path -background]
- set h $data(hpage)
- set xd [_get_x_page $path $pos]
- set xf [expr {$xd + $data($page,width)}]
- set lt [list $xd $h $xd 4 [expr {$xd+3}] 1 $xf 1]
- set lb [list $xf 1 [expr {$xf+3}] 4 [expr {$xf+3}] [expr {$h-3}] [expr {$xf+6}] $h]
- set img [Widget::getoption $path.f$page -image]
- if { $data(select) == $page } {
- set fgt $data(lbg)
- set fgb $data(dbg)
- set ytext [expr {$h/2-1}]
- if { $img == "" } {
- set xtext [expr {$xd+9}]
- } else {
- set ximg [expr {$xd+9}]
- set xtext [expr {$ximg+[image width $img]+4}]
- }
- set bd [Widget::getoption $path -borderwidth]
- set fg [Widget::getoption $path -foreground]
- } else {
- set fgt $data(dbg)
- set fgb $fgt
- set ytext [expr {$h/2}]
- if { $img == "" } {
- set xtext [expr {$xd+10}]
- } else {
- set ximg [expr {$xd+10}]
- set xtext [expr {$ximg+[image width $img]+4}]
- }
- set bd 1
- if { [Widget::getoption $path.f$page -state] == "normal" } {
- set fg [Widget::getoption $path -foreground]
- } else {
- set fg [Widget::getoption $path -disabledforeground]
- }
- }
-
- # --- creation ou modification de l'onglet -----------------------------------------------
- if { $create } {
- eval $path:cmd create polygon [concat $lt $lb] \
- -tag {"page p:$page $page:poly"} \
- -outline $bg \
- -fill $bg
- eval $path:cmd create line $lt -tags {"page p:$page $page:top top"} -fill $fgt -width $bd
- eval $path:cmd create line $lb -tags {"page p:$page $page:bot bot"} -fill $fgb -width $bd
- $path:cmd create text $xtext $ytext \
- -text [Widget::getoption $path.f$page -text] \
- -font [Widget::getoption $path -font] \
- -fill $fg \
- -anchor w \
- -tags "page p:$page $page:text"
-
- $path:cmd bind p:$page <ButtonPress-1> "NoteBook::_select $path $page"
- $path:cmd bind p:$page <Enter> "NoteBook::_highlight on $path $page"
- $path:cmd bind p:$page <Leave> "NoteBook::_highlight off $path $page"
- } else {
- eval $path:cmd coords "$page:poly" [concat $lt $lb]
- eval $path:cmd coords "$page:top" $lt
- eval $path:cmd coords "$page:bot" $lb
- $path:cmd coords "$page:text" $xtext $ytext
-
- $path:cmd itemconfigure "$page:poly" -fill $bg -outline $bg
- $path:cmd itemconfigure "$page:top" -fill $fgt -width $bd
- $path:cmd itemconfigure "$page:bot" -fill $fgb -width $bd
- $path:cmd itemconfigure "$page:text" \
- -text [Widget::getoption $path.f$page -text] \
- -font [Widget::getoption $path -font] \
- -fill $fg
- }
- if { $img != "" } {
- if { [set id [$path:cmd find withtag $page:img]] == "" } {
- $path:cmd create image $ximg $ytext \
- -image $img \
- -anchor w \
- -tags "page p:$page $page:img"
- } else {
- $path:cmd coords $id $ximg $ytext
- $path:cmd itemconfigure $id -image $img
- }
- } else {
- $path:cmd delete $page:img
- }
-
- if { $data(select) == $page } {
- $path:cmd raise p:$page
- } elseif { $pos == 0 } {
- if { $data(select) == "" } {
- $path:cmd raise p:$page
- } else {
- $path:cmd lower p:$page p:$data(select)
- }
- } else {
- set pred [lindex $data(pages) [expr {$pos-1}]]
- if { $data(select) != $pred || $pos == 1 } {
- $path:cmd lower p:$page p:$pred
- } else {
- $path:cmd lower p:$page p:[lindex $data(pages) [expr {$pos-2}]]
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command NoteBook::_draw_arrows
-# ------------------------------------------------------------------------------
-proc NoteBook::_draw_arrows { path } {
- variable _warrow
- variable $path
- upvar 0 $path data
-
- set w [expr {[winfo width $path]-1}]
- set h [expr {$data(hpage)-1}]
- set nbpages [llength $data(pages)]
- set xl 0
- set xr [expr {$w-$_warrow+1}]
-
- if { $data(base) > 0 } {
- if { ![llength [$path:cmd find withtag "leftarrow"]] } {
- $path:cmd create window $xl 1 \
- -width $_warrow \
- -height $h \
- -anchor nw \
- -window $path.fg \
- -tags "leftarrow"
- } else {
- $path:cmd coords "leftarrow" $xl 1
- $path:cmd itemconfigure "leftarrow" -width $_warrow -height $h
- }
- } else {
- $path:cmd delete "leftarrow"
- }
-
- if { $data(base) < $nbpages-1 &&
- $data(wpage) + [_get_x_page $path 0] + 6 > $w } {
- if { ![llength [$path:cmd find withtag "rightarrow"]] } {
- $path:cmd create window $xr 1 \
- -width $_warrow \
- -height $h \
- -window $path.fd \
- -anchor nw \
- -tags "rightarrow"
- } else {
- $path:cmd coords "rightarrow" $xr 1
- $path:cmd itemconfigure "rightarrow" -width $_warrow -height $h
- }
- } else {
- $path:cmd delete "rightarrow"
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command NoteBook::_draw_area
-# ------------------------------------------------------------------------------
-proc NoteBook::_draw_area { path } {
- variable $path
- upvar 0 $path data
-
- set w [expr {[winfo width $path]-1}]
- set h [expr {[winfo height $path]-1}]
- set bd [Widget::getoption $path -borderwidth]
- set x0 [expr {$bd-1}]
- set y0 $data(hpage)
- set y1 $h
- set dbg $data(dbg)
- set sel $data(select)
- if { $sel == "" } {
- set xd [expr {$w/2}]
- set xf $xd
- set lbg $data(dbg)
- } else {
- set xd [_get_x_page $path [lsearch $data(pages) $data(select)]]
- set xf [expr {$xd + $data($sel,width)+6}]
- set lbg $data(lbg)
- }
-
- if { [llength [$path:cmd find withtag rect]] } {
- $path:cmd coords "toprect1" $xd $y0 $x0 $y0 $x0 $h
- $path:cmd coords "toprect2" $w $y0 $xf $y0
- $path:cmd coords "botrect" $x0 $h $w $h $w $y0
- $path:cmd itemconfigure "toprect1" -fill $lbg -width $bd
- $path:cmd itemconfigure "toprect2" -fill $lbg -width $bd
- $path:cmd itemconfigure "botrect" -width $bd
- $path:cmd raise "rect"
- } else {
- $path:cmd create line $xd $y0 $x0 $y0 $x0 $y1 \
- -tags "rect toprect1" -fill $lbg -width $bd
- $path:cmd create line $w $y0 $xf $y0 \
- -tags "rect toprect2" -fill $lbg -width $bd
- $path:cmd create line 1 $h $w $h $w $y0 \
- -tags "rect botrect" -fill $dbg -width $bd
- }
-
- if { $sel != "" } {
- if { [llength [$path:cmd find withtag "window"]] } {
- $path:cmd coords "window" 2 [expr {$y0+1}]
- $path:cmd itemconfigure "window" \
- -width [expr {$w-3}] \
- -height [expr {$h-$y0-3}] \
- -window $path.f$sel
- } else {
- set y0 $data(hpage)
- $path:cmd create window 2 [expr {$y0+1}] \
- -width [expr {$w-3}] \
- -height [expr {$h-$y0-3}] \
- -anchor nw \
- -tags "window" \
- -window $path.f$sel
- }
- } else {
- $path:cmd delete "window"
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command NoteBook::_resize
-# ------------------------------------------------------------------------------
-proc NoteBook::_resize { path } {
- _draw_area $path
- _draw_arrows $path
-}
-
-
-# ------------------------------------------------------------------------------
-# Command NoteBook::_realize
-# ------------------------------------------------------------------------------
-proc NoteBook::_realize { path } {
- variable $path
- upvar 0 $path data
-
- if { [set width [Widget::getoption $path -width]] == 0 ||
- [set height [Widget::getoption $path -height]] == 0 } {
- compute_size $path
- }
-
- set data(realized) 1
- _draw_area $path
- _draw_arrows $path
- bind $path <Configure> "NoteBook::_resize $path"
-}
Copied: grass/trunk/lib/external/bwidget/notebook.tcl (from rev 35192, grass/trunk/lib/external/bwidget/notebook.tcl)
===================================================================
--- grass/trunk/lib/external/bwidget/notebook.tcl (rev 0)
+++ grass/trunk/lib/external/bwidget/notebook.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,866 @@
+# ------------------------------------------------------------------------------
+# notebook.tcl
+# This file is part of Unifix BWidget Toolkit
+# $Id$
+# ------------------------------------------------------------------------------
+# Index of commands:
+# - NoteBook::create
+# - NoteBook::configure
+# - NoteBook::cget
+# - NoteBook::compute_size
+# - NoteBook::insert
+# - NoteBook::delete
+# - NoteBook::itemconfigure
+# - NoteBook::itemcget
+# - NoteBook::bindtabs
+# - NoteBook::raise
+# - NoteBook::see
+# - NoteBook::page
+# - NoteBook::pages
+# - NoteBook::index
+# - NoteBook::getframe
+# - NoteBook::_test_page
+# - NoteBook::_itemconfigure
+# - NoteBook::_compute_width
+# - NoteBook::_get_x_page
+# - NoteBook::_xview
+# - NoteBook::_highlight
+# - NoteBook::_select
+# - NoteBook::_redraw
+# - NoteBook::_draw_page
+# - NoteBook::_draw_arrows
+# - NoteBook::_draw_area
+# - NoteBook::_resize
+# - NoteBook::_realize
+# ------------------------------------------------------------------------------
+
+namespace eval NoteBook {
+ ArrowButton::use
+
+ namespace eval Page {
+ Widget::declare NoteBook::Page {
+ {-state Enum normal 0 {normal disabled}}
+ {-createcmd String "" 0}
+ {-raisecmd String "" 0}
+ {-leavecmd String "" 0}
+ {-image TkResource "" 0 label}
+ {-text String "" 0}
+ }
+ }
+
+ Widget::declare NoteBook {
+ {-foreground TkResource "" 0 button}
+ {-background TkResource "" 0 button}
+ {-activebackground TkResource "" 0 button}
+ {-activeforeground TkResource "" 0 button}
+ {-disabledforeground TkResource "" 0 button}
+ {-font TkResource "" 0 button}
+ {-side Enum top 1 {top bottom}}
+ {-homogeneous Boolean 0 0}
+ {-borderwidth Int 1 0 {=1 =2}}
+ {-width Int 0 0 {=0 ""}}
+ {-height Int 0 0 {=0 ""}}
+
+ {-repeatdelay BwResource "" 0 ArrowButton}
+ {-repeatinterval BwResource "" 0 ArrowButton}
+
+ {-fg Synonym -foreground}
+ {-bg Synonym -background}
+ {-bd Synonym -borderwidth}
+ }
+
+ Widget::addmap NoteBook "" :cmd {-background {}}
+ Widget::addmap NoteBook ArrowButton .fg \
+ {-foreground {} -background {} -activeforeground {} -activebackground {} \
+ -borderwidth {} -repeatinterval {} -repeatdelay {} -disabledforeground {}}
+ Widget::addmap NoteBook ArrowButton .fd \
+ {-foreground {} -background {} -activeforeground {} -activebackground {} \
+ -borderwidth {} -repeatinterval {} -repeatdelay {} -disabledforeground {}}
+
+ variable _warrow 12
+
+ proc ::NoteBook { path args } { return [eval NoteBook::create $path $args] }
+ proc use {} {}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command NoteBook::create
+# ------------------------------------------------------------------------------
+proc NoteBook::create { path args } {
+ variable $path
+ upvar 0 $path data
+
+ Widget::init NoteBook $path $args
+
+ set data(base) 0
+ set data(select) ""
+ set data(pages) {}
+ set data(pages) {}
+ set data(cpt) 0
+ set data(realized) 0
+ set data(wpage) 0
+ set data(hpage) [expr {[font metrics [Widget::getoption $path -font] -linespace] + 6}]
+ set bg [Widget::getoption $path -background]
+
+ # --- creation du canvas -----------------------------------------------------------------
+ set w [expr {[Widget::getoption $path -width]+4}]
+ set h [expr {[Widget::getoption $path -height]+$data(hpage)+4}]
+ canvas $path -relief flat -bd 0 -highlightthickness 0 -bg $bg -width $w -height $h
+
+ # --- creation des arrow -----------------------------------------------------------------
+ eval ArrowButton::create $path.fg [Widget::subcget $path .fg] \
+ -highlightthickness 0 \
+ -type button -dir left \
+ -armcommand [list "NoteBook::_xview $path -1"]
+
+ eval ArrowButton::create $path.fd [Widget::subcget $path .fd] \
+ -highlightthickness 0 \
+ -type button -dir right \
+ -armcommand [list "NoteBook::_xview $path 1"]
+
+ set col [BWidget::get3dcolor $path $bg]
+ set data(dbg) [lindex $col 0]
+ set data(lbg) [lindex $col 1]
+
+ bind $path <Configure> "NoteBook::_realize $path"
+ bind $path <Destroy> "NoteBook::_destroy $path"
+
+ rename $path ::$path:cmd
+ proc ::$path { cmd args } "return \[eval NoteBook::\$cmd $path \$args\]"
+
+ return $path
+}
+
+
+# ------------------------------------------------------------------------------
+# Command NoteBook::configure
+# ------------------------------------------------------------------------------
+proc NoteBook::configure { path args } {
+ variable $path
+ upvar 0 $path data
+
+ set res [Widget::configure $path $args]
+ set redraw 0
+ if { [set chf [Widget::hasChanged $path -font font]] ||
+ [Widget::hasChanged $path -homogeneous foo] } {
+ if { $chf } {
+ set data(hpage) [expr {[font metrics $font -linespace] + 6}]
+ }
+ _compute_width $path
+ set redraw 1
+ }
+ if { [Widget::hasChanged $path -background bg] } {
+ set col [BWidget::get3dcolor $path $bg]
+ set data(dbg) [lindex $col 0]
+ set data(lbg) [lindex $col 1]
+ set redraw 1
+ }
+ if { [Widget::hasChanged $path -foreground fg] ||
+ [Widget::hasChanged $path -borderwidth bd] } {
+ set redraw 1
+ }
+ set wc [Widget::hasChanged $path -width w]
+ set hc [Widget::hasChanged $path -height h]
+ if { $wc || $hc } {
+ $path:cmd configure -width [expr {$w+4}] -height [expr {$h + $data(hpage)+4}]
+ } elseif { $redraw } {
+ _redraw $path
+ }
+
+ return $res
+}
+
+
+# ------------------------------------------------------------------------------
+# Command NoteBook::cget
+# ------------------------------------------------------------------------------
+proc NoteBook::cget { path option } {
+ return [Widget::cget $path $option]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command NoteBook::compute_size
+# ------------------------------------------------------------------------------
+proc NoteBook::compute_size { path } {
+ variable $path
+ upvar 0 $path data
+
+ set wmax 0
+ set hmax 0
+ update idletasks
+ foreach page $data(pages) {
+ set w [winfo reqwidth $path.f$page]
+ set h [winfo reqheight $path.f$page]
+ set wmax [expr {$w>$wmax ? $w : $wmax}]
+ set hmax [expr {$h>$hmax ? $h : $hmax}]
+ }
+ configure $path -width $wmax -height $hmax
+}
+
+
+# ------------------------------------------------------------------------------
+# Command NoteBook::insert
+# ------------------------------------------------------------------------------
+proc NoteBook::insert { path index page args } {
+ variable $path
+ upvar 0 $path data
+
+ if { [lsearch $data(pages) $page] != -1 } {
+ return -code error "page \"$page\" already exists"
+ }
+
+ Widget::init NoteBook::Page $path.f$page $args
+
+ set data(pages) [linsert $data(pages) $index $page]
+ if { ![winfo exists $path.f$page] } {
+ frame $path.f$page \
+ -relief flat -background [Widget::getoption $path -background] -borderwidth 10
+ set data($page,realized) 0
+ }
+ _compute_width $path
+ _draw_page $path $page 1
+ _redraw $path
+
+ return $path.f$page
+}
+
+
+# ------------------------------------------------------------------------------
+# Command NoteBook::delete
+# ------------------------------------------------------------------------------
+proc NoteBook::delete { path page {destroyframe 1} } {
+ variable $path
+ upvar 0 $path data
+
+ set pos [_test_page $path $page]
+ set data(pages) [lreplace $data(pages) $pos $pos]
+ _compute_width $path
+ $path:cmd delete p:$page
+ if { $data(select) == $page } {
+ set data(select) ""
+ }
+ if { $pos < $data(base) } {
+ incr data(base) -1
+ }
+ if { $destroyframe } {
+ destroy $path.f$page
+ }
+ _redraw $path
+}
+
+
+# ------------------------------------------------------------------------------
+# Command NoteBook::itemconfigure
+# ------------------------------------------------------------------------------
+proc NoteBook::itemconfigure { path page args } {
+ _test_page $path $page
+ set res [_itemconfigure $path $page $args]
+ _redraw $path
+
+ return $res
+}
+
+
+# ------------------------------------------------------------------------------
+# Command NoteBook::itemcget
+# ------------------------------------------------------------------------------
+proc NoteBook::itemcget { path page option } {
+ _test_page $path $page
+ return [Widget::cget $path.f$page $option]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command NoteBook::bindtabs
+# ------------------------------------------------------------------------------
+proc NoteBook::bindtabs { path event script } {
+ if { $script != "" } {
+ $path:cmd bind "page" $event \
+ "$script \[string range \[lindex \[$path:cmd gettags current\] 1\] 2 end\]"
+ } else {
+ $path:cmd bind "page" $event {}
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command NoteBook::move
+# ------------------------------------------------------------------------------
+proc NoteBook::move { path page index } {
+ variable $path
+ upvar 0 $path data
+
+ set pos [_test_page $path $page]
+ set data(pages) [linsert [lreplace $data(pages) $pos $pos] $index $page]
+ _redraw $path
+}
+
+
+# ------------------------------------------------------------------------------
+# Command NoteBook::raise
+# ------------------------------------------------------------------------------
+proc NoteBook::raise { path {page ""} } {
+ variable $path
+ upvar 0 $path data
+
+ if { $page != "" } {
+ _test_page $path $page
+ _select $path $page
+ }
+ return $data(select)
+}
+
+
+# ------------------------------------------------------------------------------
+# Command NoteBook::see
+# ------------------------------------------------------------------------------
+proc NoteBook::see { path page } {
+ variable $path
+ upvar 0 $path data
+
+ set pos [_test_page $path $page]
+ if { $pos < $data(base) } {
+ set data(base) $pos
+ _redraw $path
+ } else {
+ set w [expr {[winfo width $path]-1}]
+ set fpage [expr {[_get_x_page $path $pos] + $data($page,width) + 6}]
+ set idx $data(base)
+ while { $idx < $pos && $fpage > $w } {
+ set fpage [expr {$fpage - $data([lindex $data(pages) $idx],width)}]
+ incr idx
+ }
+ if { $idx != $data(base) } {
+ set data(base) $idx
+ _redraw $path
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command NoteBook::page
+# ------------------------------------------------------------------------------
+proc NoteBook::page { path first {last ""} } {
+ variable $path
+ upvar 0 $path data
+
+ if { $last == "" } {
+ return [lindex $data(pages) $first]
+ } else {
+ return [lrange $data(pages) $first $last]
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command NoteBook::pages
+# ------------------------------------------------------------------------------
+proc NoteBook::pages { path {first ""} {last ""}} {
+ variable $path
+ upvar 0 $path data
+
+ if { ![string length $first] } {
+ return $data(pages)
+ }
+
+ if { ![string length $last] } {
+ return [lindex $data(pages) $first]
+ } else {
+ return [lrange $data(pages) $first $last]
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command NoteBook::index
+# ------------------------------------------------------------------------------
+proc NoteBook::index { path page } {
+ variable $path
+ upvar 0 $path data
+
+ return [lsearch $data(pages) $page]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command NoteBook::_destroy
+# ------------------------------------------------------------------------------
+proc NoteBook::_destroy { path } {
+ variable $path
+ upvar 0 $path data
+
+ foreach page $data(pages) {
+ Widget::destroy $path.f$page
+ }
+ Widget::destroy $path
+ unset data
+ rename $path {}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command NoteBook::getframe
+# ------------------------------------------------------------------------------
+proc NoteBook::getframe { path page } {
+ return $path.f$page
+}
+
+
+# ------------------------------------------------------------------------------
+# Command NoteBook::_test_page
+# ------------------------------------------------------------------------------
+proc NoteBook::_test_page { path page } {
+ variable $path
+ upvar 0 $path data
+
+ if { [set pos [lsearch $data(pages) $page]] == -1 } {
+ return -code error "page \"$page\" does not exists"
+ }
+ return $pos
+}
+
+
+# ------------------------------------------------------------------------------
+# Command NoteBook::_itemconfigure
+# ------------------------------------------------------------------------------
+proc NoteBook::_itemconfigure { path page lres } {
+ variable $path
+ upvar 0 $path data
+
+ set res [Widget::configure $path.f$page $lres]
+ if { [Widget::hasChanged $path.f$page -text foo] } {
+ _compute_width $path
+ } elseif { [Widget::hasChanged $path.f$page -image foo] } {
+ set data(hpage) [expr {[font metrics [Widget::getoption $path -font] -linespace] + 6}]
+ _compute_width $path
+ }
+ if { [Widget::hasChanged $path.f$page -state state] &&
+ $state == "disabled" && $data(select) == $page } {
+ set data(select) ""
+ }
+ return $res
+}
+
+
+# ------------------------------------------------------------------------------
+# Command NoteBook::_compute_width
+# ------------------------------------------------------------------------------
+proc NoteBook::_compute_width { path } {
+ variable $path
+ upvar 0 $path data
+
+ set font [Widget::getoption $path -font]
+ set wmax 0
+ set hmax $data(hpage)
+ set wtot 0
+ if { ![info exists data(textid)] } {
+ set data(textid) [$path:cmd create text 0 -100 -font [Widget::getoption $path -font] -anchor nw]
+ }
+ set id $data(textid)
+ $path:cmd itemconfigure $id -font [Widget::getoption $path -font]
+ foreach page $data(pages) {
+ $path:cmd itemconfigure $id -text [Widget::getoption $path.f$page -text]
+ set wtext [expr {[lindex [$path:cmd bbox $id] 2]+20}]
+ if { [set img [Widget::getoption $path.f$page -image]] != "" } {
+ set wtext [expr {$wtext+[image width $img]+4}]
+ set himg [expr {[image height $img]+6}]
+ if { $himg > $hmax } {
+ set hmax $himg
+ }
+ }
+ set wmax [expr {$wtext>$wmax ? $wtext : $wmax}]
+ incr wtot $wtext
+ set data($page,width) $wtext
+ }
+ if { [Widget::getoption $path -homogeneous] } {
+ foreach page $data(pages) {
+ set data($page,width) $wmax
+ }
+ set wtot [expr {$wmax * [llength $data(pages)]}]
+ }
+ set data(hpage) $hmax
+ set data(wpage) $wtot
+}
+
+
+# ------------------------------------------------------------------------------
+# Command NoteBook::_get_x_page
+# ------------------------------------------------------------------------------
+proc NoteBook::_get_x_page { path pos } {
+ variable _warrow
+ variable $path
+ upvar 0 $path data
+
+ set base $data(base)
+ set x [expr {$_warrow+1}]
+ if { $pos < $base } {
+ foreach page [lrange $data(pages) $pos [expr {$base-1}]] {
+ incr x [expr {-$data($page,width)}]
+ }
+ } elseif { $pos > $base } {
+ foreach page [lrange $data(pages) $base [expr {$pos-1}]] {
+ incr x $data($page,width)
+ }
+ }
+ return $x
+}
+
+
+# ------------------------------------------------------------------------------
+# Command NoteBook::_xview
+# ------------------------------------------------------------------------------
+proc NoteBook::_xview { path inc } {
+ variable $path
+ upvar 0 $path data
+
+ if { $inc == -1 } {
+ set base [expr {$data(base)-1}]
+ set dx $data([lindex $data(pages) $base],width)
+ } else {
+ set dx [expr {-$data([lindex $data(pages) $data(base)],width)}]
+ set base [expr {$data(base)+1}]
+ }
+
+ if { $base >= 0 && $base < [llength $data(pages)] } {
+ set data(base) $base
+ $path:cmd move page $dx 0
+ _draw_area $path
+ _draw_arrows $path
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command NoteBook::_highlight
+# ------------------------------------------------------------------------------
+proc NoteBook::_highlight { type path page } {
+ variable $path
+ upvar 0 $path data
+
+ if { ![string compare [Widget::getoption $path.f$page -state] "disabled"] } {
+ return
+ }
+
+ switch -- $type {
+ on {
+ $path:cmd itemconfigure "$page:poly" -fill [Widget::getoption $path -activebackground]
+ $path:cmd itemconfigure "$page:text" -fill [Widget::getoption $path -activeforeground]
+ }
+ off {
+ $path:cmd itemconfigure "$page:poly" -fill [Widget::getoption $path -background]
+ $path:cmd itemconfigure "$page:text" -fill [Widget::getoption $path -foreground]
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command NoteBook::_select
+# ------------------------------------------------------------------------------
+proc NoteBook::_select { path page } {
+ variable $path
+ upvar 0 $path data
+
+ if { ![string compare [Widget::getoption $path.f$page -state] "normal"] } {
+ set oldsel $data(select)
+ if { [string compare $page $oldsel] } {
+ if { $oldsel != "" } {
+ if { [set cmd [Widget::getoption $path.f$oldsel -leavecmd]] != "" } {
+ if { [set code [catch {uplevel \#0 $cmd} res]] == 1 || $res == 0 } {
+ return -code $code $res
+ }
+ }
+ set data(select) ""
+ _draw_page $path $oldsel 0
+ }
+ set data(select) $page
+ if { $page != "" } {
+ if { !$data($page,realized) } {
+ set data($page,realized) 1
+ if { [set cmd [Widget::getoption $path.f$page -createcmd]] != "" } {
+ uplevel \#0 $cmd
+ }
+ }
+ if { [set cmd [Widget::getoption $path.f$page -raisecmd]] != "" } {
+ uplevel \#0 $cmd
+ }
+ _draw_page $path $page 0
+ }
+ _draw_area $path
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command NoteBook::_redraw
+# ------------------------------------------------------------------------------
+proc NoteBook::_redraw { path } {
+ variable $path
+ upvar 0 $path data
+
+ if { !$data(realized) } {
+ return
+ }
+
+ foreach page $data(pages) {
+ _draw_page $path $page 0
+ }
+ _draw_area $path
+ _draw_arrows $path
+}
+
+
+# ------------------------------------------------------------------------------
+# Command NoteBook::_draw_page
+# ------------------------------------------------------------------------------
+proc NoteBook::_draw_page { path page create } {
+ variable $path
+ upvar 0 $path data
+
+ # --- calcul des coordonnees et des couleurs de l'onglet ---------------------------------
+ set pos [lsearch $data(pages) $page]
+ set bg [Widget::getoption $path -background]
+ set h $data(hpage)
+ set xd [_get_x_page $path $pos]
+ set xf [expr {$xd + $data($page,width)}]
+ set lt [list $xd $h $xd 4 [expr {$xd+3}] 1 $xf 1]
+ set lb [list $xf 1 [expr {$xf+3}] 4 [expr {$xf+3}] [expr {$h-3}] [expr {$xf+6}] $h]
+ set img [Widget::getoption $path.f$page -image]
+ if { $data(select) == $page } {
+ set fgt $data(lbg)
+ set fgb $data(dbg)
+ set ytext [expr {$h/2-1}]
+ if { $img == "" } {
+ set xtext [expr {$xd+9}]
+ } else {
+ set ximg [expr {$xd+9}]
+ set xtext [expr {$ximg+[image width $img]+4}]
+ }
+ set bd [Widget::getoption $path -borderwidth]
+ set fg [Widget::getoption $path -foreground]
+ } else {
+ set fgt $data(dbg)
+ set fgb $fgt
+ set ytext [expr {$h/2}]
+ if { $img == "" } {
+ set xtext [expr {$xd+10}]
+ } else {
+ set ximg [expr {$xd+10}]
+ set xtext [expr {$ximg+[image width $img]+4}]
+ }
+ set bd 1
+ if { [Widget::getoption $path.f$page -state] == "normal" } {
+ set fg [Widget::getoption $path -foreground]
+ } else {
+ set fg [Widget::getoption $path -disabledforeground]
+ }
+ }
+
+ # --- creation ou modification de l'onglet -----------------------------------------------
+ if { $create } {
+ eval $path:cmd create polygon [concat $lt $lb] \
+ -tag {"page p:$page $page:poly"} \
+ -outline $bg \
+ -fill $bg
+ eval $path:cmd create line $lt -tags {"page p:$page $page:top top"} -fill $fgt -width $bd
+ eval $path:cmd create line $lb -tags {"page p:$page $page:bot bot"} -fill $fgb -width $bd
+ $path:cmd create text $xtext $ytext \
+ -text [Widget::getoption $path.f$page -text] \
+ -font [Widget::getoption $path -font] \
+ -fill $fg \
+ -anchor w \
+ -tags "page p:$page $page:text"
+
+ $path:cmd bind p:$page <ButtonPress-1> "NoteBook::_select $path $page"
+ $path:cmd bind p:$page <Enter> "NoteBook::_highlight on $path $page"
+ $path:cmd bind p:$page <Leave> "NoteBook::_highlight off $path $page"
+ } else {
+ eval $path:cmd coords "$page:poly" [concat $lt $lb]
+ eval $path:cmd coords "$page:top" $lt
+ eval $path:cmd coords "$page:bot" $lb
+ $path:cmd coords "$page:text" $xtext $ytext
+
+ $path:cmd itemconfigure "$page:poly" -fill $bg -outline $bg
+ $path:cmd itemconfigure "$page:top" -fill $fgt -width $bd
+ $path:cmd itemconfigure "$page:bot" -fill $fgb -width $bd
+ $path:cmd itemconfigure "$page:text" \
+ -text [Widget::getoption $path.f$page -text] \
+ -font [Widget::getoption $path -font] \
+ -fill $fg
+ }
+ if { $img != "" } {
+ if { [set id [$path:cmd find withtag $page:img]] == "" } {
+ $path:cmd create image $ximg $ytext \
+ -image $img \
+ -anchor w \
+ -tags "page p:$page $page:img"
+ } else {
+ $path:cmd coords $id $ximg $ytext
+ $path:cmd itemconfigure $id -image $img
+ }
+ } else {
+ $path:cmd delete $page:img
+ }
+
+ if { $data(select) == $page } {
+ $path:cmd raise p:$page
+ } elseif { $pos == 0 } {
+ if { $data(select) == "" } {
+ $path:cmd raise p:$page
+ } else {
+ $path:cmd lower p:$page p:$data(select)
+ }
+ } else {
+ set pred [lindex $data(pages) [expr {$pos-1}]]
+ if { $data(select) != $pred || $pos == 1 } {
+ $path:cmd lower p:$page p:$pred
+ } else {
+ $path:cmd lower p:$page p:[lindex $data(pages) [expr {$pos-2}]]
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command NoteBook::_draw_arrows
+# ------------------------------------------------------------------------------
+proc NoteBook::_draw_arrows { path } {
+ variable _warrow
+ variable $path
+ upvar 0 $path data
+
+ set w [expr {[winfo width $path]-1}]
+ set h [expr {$data(hpage)-1}]
+ set nbpages [llength $data(pages)]
+ set xl 0
+ set xr [expr {$w-$_warrow+1}]
+
+ if { $data(base) > 0 } {
+ if { ![llength [$path:cmd find withtag "leftarrow"]] } {
+ $path:cmd create window $xl 1 \
+ -width $_warrow \
+ -height $h \
+ -anchor nw \
+ -window $path.fg \
+ -tags "leftarrow"
+ } else {
+ $path:cmd coords "leftarrow" $xl 1
+ $path:cmd itemconfigure "leftarrow" -width $_warrow -height $h
+ }
+ } else {
+ $path:cmd delete "leftarrow"
+ }
+
+ if { $data(base) < $nbpages-1 &&
+ $data(wpage) + [_get_x_page $path 0] + 6 > $w } {
+ if { ![llength [$path:cmd find withtag "rightarrow"]] } {
+ $path:cmd create window $xr 1 \
+ -width $_warrow \
+ -height $h \
+ -window $path.fd \
+ -anchor nw \
+ -tags "rightarrow"
+ } else {
+ $path:cmd coords "rightarrow" $xr 1
+ $path:cmd itemconfigure "rightarrow" -width $_warrow -height $h
+ }
+ } else {
+ $path:cmd delete "rightarrow"
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command NoteBook::_draw_area
+# ------------------------------------------------------------------------------
+proc NoteBook::_draw_area { path } {
+ variable $path
+ upvar 0 $path data
+
+ set w [expr {[winfo width $path]-1}]
+ set h [expr {[winfo height $path]-1}]
+ set bd [Widget::getoption $path -borderwidth]
+ set x0 [expr {$bd-1}]
+ set y0 $data(hpage)
+ set y1 $h
+ set dbg $data(dbg)
+ set sel $data(select)
+ if { $sel == "" } {
+ set xd [expr {$w/2}]
+ set xf $xd
+ set lbg $data(dbg)
+ } else {
+ set xd [_get_x_page $path [lsearch $data(pages) $data(select)]]
+ set xf [expr {$xd + $data($sel,width)+6}]
+ set lbg $data(lbg)
+ }
+
+ if { [llength [$path:cmd find withtag rect]] } {
+ $path:cmd coords "toprect1" $xd $y0 $x0 $y0 $x0 $h
+ $path:cmd coords "toprect2" $w $y0 $xf $y0
+ $path:cmd coords "botrect" $x0 $h $w $h $w $y0
+ $path:cmd itemconfigure "toprect1" -fill $lbg -width $bd
+ $path:cmd itemconfigure "toprect2" -fill $lbg -width $bd
+ $path:cmd itemconfigure "botrect" -width $bd
+ $path:cmd raise "rect"
+ } else {
+ $path:cmd create line $xd $y0 $x0 $y0 $x0 $y1 \
+ -tags "rect toprect1" -fill $lbg -width $bd
+ $path:cmd create line $w $y0 $xf $y0 \
+ -tags "rect toprect2" -fill $lbg -width $bd
+ $path:cmd create line 1 $h $w $h $w $y0 \
+ -tags "rect botrect" -fill $dbg -width $bd
+ }
+
+ if { $sel != "" } {
+ if { [llength [$path:cmd find withtag "window"]] } {
+ $path:cmd coords "window" 2 [expr {$y0+1}]
+ $path:cmd itemconfigure "window" \
+ -width [expr {$w-3}] \
+ -height [expr {$h-$y0-3}] \
+ -window $path.f$sel
+ } else {
+ set y0 $data(hpage)
+ $path:cmd create window 2 [expr {$y0+1}] \
+ -width [expr {$w-3}] \
+ -height [expr {$h-$y0-3}] \
+ -anchor nw \
+ -tags "window" \
+ -window $path.f$sel
+ }
+ } else {
+ $path:cmd delete "window"
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command NoteBook::_resize
+# ------------------------------------------------------------------------------
+proc NoteBook::_resize { path } {
+ _draw_area $path
+ _draw_arrows $path
+}
+
+
+# ------------------------------------------------------------------------------
+# Command NoteBook::_realize
+# ------------------------------------------------------------------------------
+proc NoteBook::_realize { path } {
+ variable $path
+ upvar 0 $path data
+
+ if { [set width [Widget::getoption $path -width]] == 0 ||
+ [set height [Widget::getoption $path -height]] == 0 } {
+ compute_size $path
+ }
+
+ set data(realized) 1
+ _draw_area $path
+ _draw_arrows $path
+ bind $path <Configure> "NoteBook::_resize $path"
+}
Deleted: grass/trunk/lib/external/bwidget/pagesmgr.tcl
===================================================================
--- grass/trunk/lib/external/bwidget/pagesmgr.tcl 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/pagesmgr.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,298 +0,0 @@
-# ------------------------------------------------------------------------------
-# pagesmgr.tcl
-# This file is part of Unifix BWidget Toolkit
-# $Id$
-# ------------------------------------------------------------------------------
-# Index of commands:
-# - PagesManager::create
-# - PagesManager::configure
-# - PagesManager::cget
-# - PagesManager::compute_size
-# - PagesManager::add
-# - PagesManager::delete
-# - PagesManager::raise
-# - PagesManager::page
-# - PagesManager::pages
-# - PagesManager::getframe
-# - PagesManager::_test_page
-# - PagesManager::_select
-# - PagesManager::_redraw
-# - PagesManager::_draw_area
-# - PagesManager::_realize
-# ------------------------------------------------------------------------------
-
-namespace eval PagesManager {
- Widget::declare PagesManager {
- {-background TkResource "" 0 frame}
- {-width Int 0 0 {=0 ""}}
- {-height Int 0 0 {=0 ""}}
- }
-
- Widget::addmap PagesManager "" :cmd {-width {} -height {}}
-
- proc ::PagesManager { path args } { return [eval PagesManager::create $path $args] }
- proc use {} {}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command PagesManager::create
-# ------------------------------------------------------------------------------
-proc PagesManager::create { path args } {
- variable $path
- upvar 0 $path data
-
- Widget::init PagesManager $path $args
-
- set data(select) ""
- set data(pages) {}
- set data(cpt) 0
- set data(realized) 0
-
- # --- creation du canvas -----------------------------------------------------------------
- set w [Widget::cget $path -width]
- set h [Widget::cget $path -height]
- canvas $path -relief flat -bd 0 -highlightthickness 0 -width $w -height $h
-
- bind $path <Configure> "PagesManager::_realize $path"
- bind $path <Destroy> "PagesManager::_destroy $path"
-
- rename $path ::$path:cmd
- proc ::$path { cmd args } "return \[eval PagesManager::\$cmd $path \$args\]"
-
- return $path
-}
-
-
-# ------------------------------------------------------------------------------
-# Command PagesManager::configure
-# ------------------------------------------------------------------------------
-proc PagesManager::configure { path args } {
- return [Widget::configure $path $args]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command PagesManager::cget
-# ------------------------------------------------------------------------------
-proc PagesManager::cget { path option } {
- return [Widget::cget $path $option]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command PagesManager::compute_size
-# ------------------------------------------------------------------------------
-proc PagesManager::compute_size { path } {
- variable $path
- upvar 0 $path data
-
- set wmax 0
- set hmax 0
- update idletasks
- foreach page $data(pages) {
- set w [winfo reqwidth $path.f$page]
- set h [winfo reqheight $path.f$page]
- set wmax [expr {$w>$wmax ? $w : $wmax}]
- set hmax [expr {$h>$hmax ? $h : $hmax}]
- }
- configure $path -width $wmax -height $hmax
-}
-
-
-# ------------------------------------------------------------------------------
-# Command PagesManager::add
-# ------------------------------------------------------------------------------
-proc PagesManager::add { path page } {
- variable $path
- upvar 0 $path data
-
- if { [lsearch $data(pages) $page] != -1 } {
- return -code error "page \"$page\" already exists"
- }
-
- lappend data(pages) $page
-
- frame $path.f$page -relief flat -background [Widget::cget $path -background] -borderwidth 0
-
- return $path.f$page
-}
-
-
-# ------------------------------------------------------------------------------
-# Command PagesManager::delete
-# ------------------------------------------------------------------------------
-proc PagesManager::delete { path page } {
- variable $path
- upvar 0 $path data
-
- set pos [_test_page $path $page]
- set data(pages) [lreplace $data(pages) $pos $pos]
- if { $data(select) == $page } {
- set data(select) ""
- }
- destroy $path.f$page
- _redraw $path
-}
-
-
-# ------------------------------------------------------------------------------
-# Command PagesManager::raise
-# ------------------------------------------------------------------------------
-proc PagesManager::raise { path {page ""} } {
- variable $path
- upvar 0 $path data
-
- if { $page != "" } {
- _test_page $path $page
- _select $path $page
- }
- return $data(select)
-}
-
-
-# ------------------------------------------------------------------------------
-# Command PagesManager::page - deprecated, use pages
-# ------------------------------------------------------------------------------
-proc PagesManager::page { path first {last ""} } {
- variable $path
- upvar 0 $path data
-
- if { $last == "" } {
- return [lindex $data(pages) $first]
- } else {
- return [lrange $data(pages) $first $last]
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command PagesManager::pages
-# ------------------------------------------------------------------------------
-proc PagesManager::pages { path {first ""} {last ""} } {
- variable $path
- upvar 0 $path data
-
- if { ![string length $first] } {
- return $data(pages)
- }
-
- if { ![string length $last] } {
- return [lindex $data(pages) $first]
- } else {
- return [lrange $data(pages) $first $last]
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command PagesManager::_destroy
-# ------------------------------------------------------------------------------
-proc PagesManager::_destroy { path } {
- variable $path
- upvar 0 $path data
-
- Widget::destroy $path
- unset data
- rename $path {}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command PagesManager::getframe
-# ------------------------------------------------------------------------------
-proc PagesManager::getframe { path page } {
- return $path.f$page
-}
-
-
-# ------------------------------------------------------------------------------
-# Command PagesManager::_test_page
-# ------------------------------------------------------------------------------
-proc PagesManager::_test_page { path page } {
- variable $path
- upvar 0 $path data
-
- if { [set pos [lsearch $data(pages) $page]] == -1 } {
- return -code error "page \"$page\" does not exists"
- }
- return $pos
-}
-
-
-# ------------------------------------------------------------------------------
-# Command PagesManager::_select
-# ------------------------------------------------------------------------------
-proc PagesManager::_select { path page } {
- variable $path
- upvar 0 $path data
-
- set oldsel $data(select)
- if { $page != $oldsel } {
- set data(select) $page
- _draw_area $path
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command PagesManager::_redraw
-# ------------------------------------------------------------------------------
-proc PagesManager::_redraw { path } {
- variable $path
- upvar 0 $path data
-
- if { !$data(realized) } {
- return
- }
- _draw_area $path
-}
-
-
-# ------------------------------------------------------------------------------
-# Command PagesManager::_draw_area
-# ------------------------------------------------------------------------------
-proc PagesManager::_draw_area { path } {
- variable $path
- upvar 0 $path data
-
- set w [winfo width $path]
- set h [winfo height $path]
- set sel $data(select)
- if { $sel != "" } {
- if { [llength [$path:cmd find withtag "window"]] } {
- $path:cmd coords "window" 0 0
- $path:cmd itemconfigure "window" \
- -width $w \
- -height $h \
- -window $path.f$sel
- } else {
- $path:cmd create window 0 0 \
- -width $w \
- -height $h \
- -anchor nw \
- -tags "window" \
- -window $path.f$sel
- }
- } else {
- $path:cmd delete "window"
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command PagesManager::_realize
-# ------------------------------------------------------------------------------
-proc PagesManager::_realize { path } {
- variable $path
- upvar 0 $path data
-
- if { [set width [Widget::cget $path -width]] == 0 ||
- [set height [Widget::cget $path -height]] == 0 } {
- compute_size $path
- }
-
- set data(realized) 1
- _draw_area $path
- bind $path <Configure> "PagesManager::_draw_area $path"
-}
Copied: grass/trunk/lib/external/bwidget/pagesmgr.tcl (from rev 35192, grass/trunk/lib/external/bwidget/pagesmgr.tcl)
===================================================================
--- grass/trunk/lib/external/bwidget/pagesmgr.tcl (rev 0)
+++ grass/trunk/lib/external/bwidget/pagesmgr.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,298 @@
+# ------------------------------------------------------------------------------
+# pagesmgr.tcl
+# This file is part of Unifix BWidget Toolkit
+# $Id$
+# ------------------------------------------------------------------------------
+# Index of commands:
+# - PagesManager::create
+# - PagesManager::configure
+# - PagesManager::cget
+# - PagesManager::compute_size
+# - PagesManager::add
+# - PagesManager::delete
+# - PagesManager::raise
+# - PagesManager::page
+# - PagesManager::pages
+# - PagesManager::getframe
+# - PagesManager::_test_page
+# - PagesManager::_select
+# - PagesManager::_redraw
+# - PagesManager::_draw_area
+# - PagesManager::_realize
+# ------------------------------------------------------------------------------
+
+namespace eval PagesManager {
+ Widget::declare PagesManager {
+ {-background TkResource "" 0 frame}
+ {-width Int 0 0 {=0 ""}}
+ {-height Int 0 0 {=0 ""}}
+ }
+
+ Widget::addmap PagesManager "" :cmd {-width {} -height {}}
+
+ proc ::PagesManager { path args } { return [eval PagesManager::create $path $args] }
+ proc use {} {}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command PagesManager::create
+# ------------------------------------------------------------------------------
+proc PagesManager::create { path args } {
+ variable $path
+ upvar 0 $path data
+
+ Widget::init PagesManager $path $args
+
+ set data(select) ""
+ set data(pages) {}
+ set data(cpt) 0
+ set data(realized) 0
+
+ # --- creation du canvas -----------------------------------------------------------------
+ set w [Widget::cget $path -width]
+ set h [Widget::cget $path -height]
+ canvas $path -relief flat -bd 0 -highlightthickness 0 -width $w -height $h
+
+ bind $path <Configure> "PagesManager::_realize $path"
+ bind $path <Destroy> "PagesManager::_destroy $path"
+
+ rename $path ::$path:cmd
+ proc ::$path { cmd args } "return \[eval PagesManager::\$cmd $path \$args\]"
+
+ return $path
+}
+
+
+# ------------------------------------------------------------------------------
+# Command PagesManager::configure
+# ------------------------------------------------------------------------------
+proc PagesManager::configure { path args } {
+ return [Widget::configure $path $args]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command PagesManager::cget
+# ------------------------------------------------------------------------------
+proc PagesManager::cget { path option } {
+ return [Widget::cget $path $option]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command PagesManager::compute_size
+# ------------------------------------------------------------------------------
+proc PagesManager::compute_size { path } {
+ variable $path
+ upvar 0 $path data
+
+ set wmax 0
+ set hmax 0
+ update idletasks
+ foreach page $data(pages) {
+ set w [winfo reqwidth $path.f$page]
+ set h [winfo reqheight $path.f$page]
+ set wmax [expr {$w>$wmax ? $w : $wmax}]
+ set hmax [expr {$h>$hmax ? $h : $hmax}]
+ }
+ configure $path -width $wmax -height $hmax
+}
+
+
+# ------------------------------------------------------------------------------
+# Command PagesManager::add
+# ------------------------------------------------------------------------------
+proc PagesManager::add { path page } {
+ variable $path
+ upvar 0 $path data
+
+ if { [lsearch $data(pages) $page] != -1 } {
+ return -code error "page \"$page\" already exists"
+ }
+
+ lappend data(pages) $page
+
+ frame $path.f$page -relief flat -background [Widget::cget $path -background] -borderwidth 0
+
+ return $path.f$page
+}
+
+
+# ------------------------------------------------------------------------------
+# Command PagesManager::delete
+# ------------------------------------------------------------------------------
+proc PagesManager::delete { path page } {
+ variable $path
+ upvar 0 $path data
+
+ set pos [_test_page $path $page]
+ set data(pages) [lreplace $data(pages) $pos $pos]
+ if { $data(select) == $page } {
+ set data(select) ""
+ }
+ destroy $path.f$page
+ _redraw $path
+}
+
+
+# ------------------------------------------------------------------------------
+# Command PagesManager::raise
+# ------------------------------------------------------------------------------
+proc PagesManager::raise { path {page ""} } {
+ variable $path
+ upvar 0 $path data
+
+ if { $page != "" } {
+ _test_page $path $page
+ _select $path $page
+ }
+ return $data(select)
+}
+
+
+# ------------------------------------------------------------------------------
+# Command PagesManager::page - deprecated, use pages
+# ------------------------------------------------------------------------------
+proc PagesManager::page { path first {last ""} } {
+ variable $path
+ upvar 0 $path data
+
+ if { $last == "" } {
+ return [lindex $data(pages) $first]
+ } else {
+ return [lrange $data(pages) $first $last]
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command PagesManager::pages
+# ------------------------------------------------------------------------------
+proc PagesManager::pages { path {first ""} {last ""} } {
+ variable $path
+ upvar 0 $path data
+
+ if { ![string length $first] } {
+ return $data(pages)
+ }
+
+ if { ![string length $last] } {
+ return [lindex $data(pages) $first]
+ } else {
+ return [lrange $data(pages) $first $last]
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command PagesManager::_destroy
+# ------------------------------------------------------------------------------
+proc PagesManager::_destroy { path } {
+ variable $path
+ upvar 0 $path data
+
+ Widget::destroy $path
+ unset data
+ rename $path {}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command PagesManager::getframe
+# ------------------------------------------------------------------------------
+proc PagesManager::getframe { path page } {
+ return $path.f$page
+}
+
+
+# ------------------------------------------------------------------------------
+# Command PagesManager::_test_page
+# ------------------------------------------------------------------------------
+proc PagesManager::_test_page { path page } {
+ variable $path
+ upvar 0 $path data
+
+ if { [set pos [lsearch $data(pages) $page]] == -1 } {
+ return -code error "page \"$page\" does not exists"
+ }
+ return $pos
+}
+
+
+# ------------------------------------------------------------------------------
+# Command PagesManager::_select
+# ------------------------------------------------------------------------------
+proc PagesManager::_select { path page } {
+ variable $path
+ upvar 0 $path data
+
+ set oldsel $data(select)
+ if { $page != $oldsel } {
+ set data(select) $page
+ _draw_area $path
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command PagesManager::_redraw
+# ------------------------------------------------------------------------------
+proc PagesManager::_redraw { path } {
+ variable $path
+ upvar 0 $path data
+
+ if { !$data(realized) } {
+ return
+ }
+ _draw_area $path
+}
+
+
+# ------------------------------------------------------------------------------
+# Command PagesManager::_draw_area
+# ------------------------------------------------------------------------------
+proc PagesManager::_draw_area { path } {
+ variable $path
+ upvar 0 $path data
+
+ set w [winfo width $path]
+ set h [winfo height $path]
+ set sel $data(select)
+ if { $sel != "" } {
+ if { [llength [$path:cmd find withtag "window"]] } {
+ $path:cmd coords "window" 0 0
+ $path:cmd itemconfigure "window" \
+ -width $w \
+ -height $h \
+ -window $path.f$sel
+ } else {
+ $path:cmd create window 0 0 \
+ -width $w \
+ -height $h \
+ -anchor nw \
+ -tags "window" \
+ -window $path.f$sel
+ }
+ } else {
+ $path:cmd delete "window"
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command PagesManager::_realize
+# ------------------------------------------------------------------------------
+proc PagesManager::_realize { path } {
+ variable $path
+ upvar 0 $path data
+
+ if { [set width [Widget::cget $path -width]] == 0 ||
+ [set height [Widget::cget $path -height]] == 0 } {
+ compute_size $path
+ }
+
+ set data(realized) 1
+ _draw_area $path
+ bind $path <Configure> "PagesManager::_draw_area $path"
+}
Deleted: grass/trunk/lib/external/bwidget/panedw.tcl
===================================================================
--- grass/trunk/lib/external/bwidget/panedw.tcl 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/panedw.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,303 +0,0 @@
-# ------------------------------------------------------------------------------
-# panedw.tcl
-# This file is part of Unifix BWidget Toolkit
-# ------------------------------------------------------------------------------
-# Index of commands:
-# - PanedWindow::create
-# - PanedWindow::configure
-# - PanedWindow::cget
-# - PanedWindow::add
-# - PanedWindow::getframe
-# - PanedWindow::_destroy
-# - PanedWindow::_beg_move_sash
-# - PanedWindow::_move_sash
-# - PanedWindow::_end_move_sash
-# - PanedWindow::_realize
-# ------------------------------------------------------------------------------
-
-namespace eval PanedWindow {
- namespace eval Pane {
- Widget::declare PanedWindow::Pane {
- {-minsize Int 0 0 {=0}}
- {-weight Int 1 0 {=0}}
- }
- }
-
- Widget::declare PanedWindow {
- {-side Enum top 1 {top left bottom right}}
- {-width Int 10 1 {=6 ""}}
- {-pad Int 4 1 {=0 ""}}
- {-background TkResource "" 0 frame}
- {-bg Synonym -background}
- }
-
- variable _panedw
-
- proc ::PanedWindow { path args } { return [eval PanedWindow::create $path $args] }
- proc use {} {}
-}
-
-
-
-# ------------------------------------------------------------------------------
-# Command PanedWindow::create
-# ------------------------------------------------------------------------------
-proc PanedWindow::create { path args } {
- variable _panedw
-
- Widget::init PanedWindow $path $args
-
- frame $path -background [Widget::getoption $path -background]
- set _panedw($path,nbpanes) 0
-
- bind $path <Configure> "PanedWindow::_realize $path %w %h"
- bind $path <Destroy> "PanedWindow::_destroy $path"
-
- rename $path ::$path:cmd
- proc ::$path { cmd args } "return \[eval PanedWindow::\$cmd $path \$args\]"
-
- return $path
-}
-
-
-# ------------------------------------------------------------------------------
-# Command PanedWindow::configure
-# ------------------------------------------------------------------------------
-proc PanedWindow::configure { path args } {
- variable _panedw
-
- set res [Widget::configure $path $args]
-
- if { [Widget::hasChanged $path -background bg] && $_panedw($path,nbpanes) > 0 } {
- $path:cmd configure -background $bg
- $path.f0 configure -background $bg
- for {set i 1} {$i < $_panedw($path,nbpanes)} {incr i} {
- set frame $path.sash$i
- $frame configure -background $bg
- $frame.sep configure -background $bg
- $frame.but configure -background $bg
- $path.f$i configure -background $bg
- $path.f$i.frame configure -background $bg
- }
- }
- return $res
-}
-
-
-# ------------------------------------------------------------------------------
-# Command PanedWindow::cget
-# ------------------------------------------------------------------------------
-proc PanedWindow::cget { path option } {
- return [Widget::cget $path $option]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command PanedWindow::add
-# ------------------------------------------------------------------------------
-proc PanedWindow::add { path args } {
- variable _panedw
-
- set num $_panedw($path,nbpanes)
- Widget::init PanedWindow::Pane $path.f$num $args
- set bg [Widget::getoption $path -background]
-
- set wbut [Widget::getoption $path -width]
- set pad [Widget::getoption $path -pad]
- set width [expr {$wbut+2*$pad}]
- set side [Widget::getoption $path -side]
- if { $num > 0 } {
- set frame [frame $path.sash$num -relief flat -bd 0 -highlightthickness 0 \
- -width $width -height $width -bg $bg]
- set sep [frame $frame.sep -bd 1 -relief raised -highlightthickness 0 -bg $bg]
- set but [frame $frame.but -bd 1 -relief raised -highlightthickness 0 -bg $bg \
- -width $wbut -height $wbut]
- if { ![string compare $side "top"] || ![string compare $side "bottom"] } {
- place $sep -relx 0.5 -y 0 -width 2 -relheight 1.0 -anchor n
- if { ![string compare $side "top"] } {
- place $but -relx 0.5 -y [expr {6+$wbut/2}] -anchor c
- } else {
- place $but -relx 0.5 -rely 1.0 -y [expr {-6-$wbut/2}] -anchor c
- }
- $but configure -cursor sb_h_double_arrow
- grid $frame -column [expr 2*$num-1] -row 0 -sticky ns
- grid columnconfigure $path [expr 2*$num-1] -weight 0
- } else {
- place $sep -x 0 -rely 0.5 -height 2 -relwidth 1.0 -anchor w
- if { ![string compare $side "left"] } {
- place $but -rely 0.5 -x [expr {6+$wbut/2}] -anchor c
- } else {
- place $but -rely 0.5 -relx 1.0 -x [expr {-6-$wbut/2}] -anchor c
- }
- $but configure -cursor sb_v_double_arrow
- grid $frame -row [expr 2*$num-1] -column 0 -sticky ew
- grid rowconfigure $path [expr 2*$num-1] -weight 0
- }
- bind $but <ButtonPress-1> "PanedWindow::_beg_move_sash $path $num %X %Y"
- } else {
- if { ![string compare $side "top"] || ![string compare $side "bottom"] } {
- grid rowconfigure $path 0 -weight 1
- } else {
- grid columnconfigure $path 0 -weight 1
- }
- }
-
- set pane [frame $path.f$num -bd 0 -relief flat -highlightthickness 0 -bg $bg]
- set user [frame $path.f$num.frame -bd 0 -relief flat -highlightthickness 0 -bg $bg]
- if { ![string compare $side "top"] || ![string compare $side "bottom"] } {
- grid $pane -column [expr 2*$num] -row 0 -sticky nsew
- grid columnconfigure $path [expr 2*$num] \
- -weight [Widget::getoption $path.f$num -weight]
- } else {
- grid $pane -row [expr 2*$num] -column 0 -sticky nsew
- grid rowconfigure $path [expr 2*$num] \
- -weight [Widget::getoption $path.f$num -weight]
- }
- pack $user -fill both -expand yes
- incr _panedw($path,nbpanes)
-
- return $user
-}
-
-
-# ------------------------------------------------------------------------------
-# Command PanedWindow::getframe
-# ------------------------------------------------------------------------------
-proc PanedWindow::getframe { path index } {
- if { [winfo exists $path.f$index.frame] } {
- return $path.f$index.frame
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command PanedWindow::_destroy
-# ------------------------------------------------------------------------------
-proc PanedWindow::_destroy { path } {
- variable _panedw
-
- for {set i 0} {$i < $_panedw($path,nbpanes)} {incr i} {
- Widget::destroy $path.f$i
- }
- unset _panedw($path,nbpanes)
- Widget::destroy $path
- rename $path {}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command PanedWindow::_beg_move_sash
-# ------------------------------------------------------------------------------
-proc PanedWindow::_beg_move_sash { path num x y } {
- variable _panedw
-
- set fprev $path.f[expr $num-1]
- set fnext $path.f$num
- set wsash [expr [Widget::getoption $path -width] + 2*[Widget::getoption $path -pad]]
-
- $path.sash$num.but configure -relief sunken
- set top [toplevel $path.sash -borderwidth 1 -relief raised]
-
- set minszg [Widget::getoption $fprev -minsize]
- set minszd [Widget::getoption $fnext -minsize]
- set side [Widget::getoption $path -side]
-
- if { ![string compare $side "top"] || ![string compare $side "bottom"] } {
- $top configure -cursor sb_h_double_arrow
- set h [winfo height $path]
- set yr [winfo rooty $path.sash$num]
- set xmin [expr $wsash/2+[winfo rootx $fprev]+$minszg]
- set xmax [expr -$wsash/2-1+[winfo rootx $fnext]+[winfo width $fnext]-$minszd]
- wm overrideredirect $top 1
- wm geom $top "2x${h}+$x+$yr"
-
- update idletasks
- grab set $top
- bind $top <ButtonRelease-1> "PanedWindow::_end_move_sash $path $top $num $xmin $xmax %X rootx width"
- bind $top <Motion> "PanedWindow::_move_sash $top $xmin $xmax %X +%%d+$yr"
- _move_sash $top $xmin $xmax $x "+%d+$yr"
- } else {
- $top configure -cursor sb_v_double_arrow
- set w [winfo width $path]
- set xr [winfo rootx $path.sash$num]
- set ymin [expr $wsash/2+[winfo rooty $fprev]+$minszg]
- set ymax [expr -$wsash/2-1+[winfo rooty $fnext]+[winfo height $fnext]-$minszd]
- wm overrideredirect $top 1
- wm geom $top "${w}x2+$xr+$y"
-
- update idletasks
- grab set $top
- bind $top <ButtonRelease-1> "PanedWindow::_end_move_sash $path $top $num $ymin $ymax %Y rooty height"
- bind $top <Motion> "PanedWindow::_move_sash $top $ymin $ymax %Y +$xr+%%d"
- _move_sash $top $ymin $ymax $y "+$xr+%d"
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command PanedWindow::_move_sash
-# ------------------------------------------------------------------------------
-proc PanedWindow::_move_sash { top min max v form } {
-
- if { $v < $min } {
- set v $min
- } elseif { $v > $max } {
- set v $max
- }
- wm geom $top [format $form $v]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command PanedWindow::_end_move_sash
-# ------------------------------------------------------------------------------
-proc PanedWindow::_end_move_sash { path top num min max v rootv size } {
- variable _panedw
-
- destroy $top
- if { $v < $min } {
- set v $min
- } elseif { $v > $max } {
- set v $max
- }
- set fprev $path.f[expr $num-1]
- set fnext $path.f$num
-
- $path.sash$num.but configure -relief raised
-
- set wsash [expr [Widget::getoption $path -width] + 2*[Widget::getoption $path -pad]]
- set dv [expr $v-[winfo $rootv $path.sash$num]-$wsash/2]
- set w1 [winfo $size $fprev]
- set w2 [winfo $size $fnext]
-
- for {set i 0} {$i < $_panedw($path,nbpanes)} {incr i} {
- if { $i == $num-1} {
- $fprev configure -$size [expr [winfo $size $fprev]+$dv]
- } elseif { $i == $num } {
- $fnext configure -$size [expr [winfo $size $fnext]-$dv]
- } else {
- $path.f$i configure -$size [winfo $size $path.f$i]
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command PanedWindow::_realize
-# ------------------------------------------------------------------------------
-proc PanedWindow::_realize { path width height } {
- variable _panedw
-
- set x 0
- set y 0
- set hc [winfo reqheight $path]
- set hmax 0
- for {set i 0} {$i < $_panedw($path,nbpanes)} {incr i} {
- $path.f$i configure \
- -width [winfo reqwidth $path.f$i.frame] \
- -height [winfo reqheight $path.f$i.frame]
- place $path.f$i.frame -x 0 -y 0 -relwidth 1 -relheight 1
- }
-
- bind $path <Configure> {}
-}
Copied: grass/trunk/lib/external/bwidget/panedw.tcl (from rev 35192, grass/trunk/lib/external/bwidget/panedw.tcl)
===================================================================
--- grass/trunk/lib/external/bwidget/panedw.tcl (rev 0)
+++ grass/trunk/lib/external/bwidget/panedw.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,303 @@
+# ------------------------------------------------------------------------------
+# panedw.tcl
+# This file is part of Unifix BWidget Toolkit
+# ------------------------------------------------------------------------------
+# Index of commands:
+# - PanedWindow::create
+# - PanedWindow::configure
+# - PanedWindow::cget
+# - PanedWindow::add
+# - PanedWindow::getframe
+# - PanedWindow::_destroy
+# - PanedWindow::_beg_move_sash
+# - PanedWindow::_move_sash
+# - PanedWindow::_end_move_sash
+# - PanedWindow::_realize
+# ------------------------------------------------------------------------------
+
+namespace eval PanedWindow {
+ namespace eval Pane {
+ Widget::declare PanedWindow::Pane {
+ {-minsize Int 0 0 {=0}}
+ {-weight Int 1 0 {=0}}
+ }
+ }
+
+ Widget::declare PanedWindow {
+ {-side Enum top 1 {top left bottom right}}
+ {-width Int 10 1 {=6 ""}}
+ {-pad Int 4 1 {=0 ""}}
+ {-background TkResource "" 0 frame}
+ {-bg Synonym -background}
+ }
+
+ variable _panedw
+
+ proc ::PanedWindow { path args } { return [eval PanedWindow::create $path $args] }
+ proc use {} {}
+}
+
+
+
+# ------------------------------------------------------------------------------
+# Command PanedWindow::create
+# ------------------------------------------------------------------------------
+proc PanedWindow::create { path args } {
+ variable _panedw
+
+ Widget::init PanedWindow $path $args
+
+ frame $path -background [Widget::getoption $path -background]
+ set _panedw($path,nbpanes) 0
+
+ bind $path <Configure> "PanedWindow::_realize $path %w %h"
+ bind $path <Destroy> "PanedWindow::_destroy $path"
+
+ rename $path ::$path:cmd
+ proc ::$path { cmd args } "return \[eval PanedWindow::\$cmd $path \$args\]"
+
+ return $path
+}
+
+
+# ------------------------------------------------------------------------------
+# Command PanedWindow::configure
+# ------------------------------------------------------------------------------
+proc PanedWindow::configure { path args } {
+ variable _panedw
+
+ set res [Widget::configure $path $args]
+
+ if { [Widget::hasChanged $path -background bg] && $_panedw($path,nbpanes) > 0 } {
+ $path:cmd configure -background $bg
+ $path.f0 configure -background $bg
+ for {set i 1} {$i < $_panedw($path,nbpanes)} {incr i} {
+ set frame $path.sash$i
+ $frame configure -background $bg
+ $frame.sep configure -background $bg
+ $frame.but configure -background $bg
+ $path.f$i configure -background $bg
+ $path.f$i.frame configure -background $bg
+ }
+ }
+ return $res
+}
+
+
+# ------------------------------------------------------------------------------
+# Command PanedWindow::cget
+# ------------------------------------------------------------------------------
+proc PanedWindow::cget { path option } {
+ return [Widget::cget $path $option]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command PanedWindow::add
+# ------------------------------------------------------------------------------
+proc PanedWindow::add { path args } {
+ variable _panedw
+
+ set num $_panedw($path,nbpanes)
+ Widget::init PanedWindow::Pane $path.f$num $args
+ set bg [Widget::getoption $path -background]
+
+ set wbut [Widget::getoption $path -width]
+ set pad [Widget::getoption $path -pad]
+ set width [expr {$wbut+2*$pad}]
+ set side [Widget::getoption $path -side]
+ if { $num > 0 } {
+ set frame [frame $path.sash$num -relief flat -bd 0 -highlightthickness 0 \
+ -width $width -height $width -bg $bg]
+ set sep [frame $frame.sep -bd 1 -relief raised -highlightthickness 0 -bg $bg]
+ set but [frame $frame.but -bd 1 -relief raised -highlightthickness 0 -bg $bg \
+ -width $wbut -height $wbut]
+ if { ![string compare $side "top"] || ![string compare $side "bottom"] } {
+ place $sep -relx 0.5 -y 0 -width 2 -relheight 1.0 -anchor n
+ if { ![string compare $side "top"] } {
+ place $but -relx 0.5 -y [expr {6+$wbut/2}] -anchor c
+ } else {
+ place $but -relx 0.5 -rely 1.0 -y [expr {-6-$wbut/2}] -anchor c
+ }
+ $but configure -cursor sb_h_double_arrow
+ grid $frame -column [expr 2*$num-1] -row 0 -sticky ns
+ grid columnconfigure $path [expr 2*$num-1] -weight 0
+ } else {
+ place $sep -x 0 -rely 0.5 -height 2 -relwidth 1.0 -anchor w
+ if { ![string compare $side "left"] } {
+ place $but -rely 0.5 -x [expr {6+$wbut/2}] -anchor c
+ } else {
+ place $but -rely 0.5 -relx 1.0 -x [expr {-6-$wbut/2}] -anchor c
+ }
+ $but configure -cursor sb_v_double_arrow
+ grid $frame -row [expr 2*$num-1] -column 0 -sticky ew
+ grid rowconfigure $path [expr 2*$num-1] -weight 0
+ }
+ bind $but <ButtonPress-1> "PanedWindow::_beg_move_sash $path $num %X %Y"
+ } else {
+ if { ![string compare $side "top"] || ![string compare $side "bottom"] } {
+ grid rowconfigure $path 0 -weight 1
+ } else {
+ grid columnconfigure $path 0 -weight 1
+ }
+ }
+
+ set pane [frame $path.f$num -bd 0 -relief flat -highlightthickness 0 -bg $bg]
+ set user [frame $path.f$num.frame -bd 0 -relief flat -highlightthickness 0 -bg $bg]
+ if { ![string compare $side "top"] || ![string compare $side "bottom"] } {
+ grid $pane -column [expr 2*$num] -row 0 -sticky nsew
+ grid columnconfigure $path [expr 2*$num] \
+ -weight [Widget::getoption $path.f$num -weight]
+ } else {
+ grid $pane -row [expr 2*$num] -column 0 -sticky nsew
+ grid rowconfigure $path [expr 2*$num] \
+ -weight [Widget::getoption $path.f$num -weight]
+ }
+ pack $user -fill both -expand yes
+ incr _panedw($path,nbpanes)
+
+ return $user
+}
+
+
+# ------------------------------------------------------------------------------
+# Command PanedWindow::getframe
+# ------------------------------------------------------------------------------
+proc PanedWindow::getframe { path index } {
+ if { [winfo exists $path.f$index.frame] } {
+ return $path.f$index.frame
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command PanedWindow::_destroy
+# ------------------------------------------------------------------------------
+proc PanedWindow::_destroy { path } {
+ variable _panedw
+
+ for {set i 0} {$i < $_panedw($path,nbpanes)} {incr i} {
+ Widget::destroy $path.f$i
+ }
+ unset _panedw($path,nbpanes)
+ Widget::destroy $path
+ rename $path {}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command PanedWindow::_beg_move_sash
+# ------------------------------------------------------------------------------
+proc PanedWindow::_beg_move_sash { path num x y } {
+ variable _panedw
+
+ set fprev $path.f[expr $num-1]
+ set fnext $path.f$num
+ set wsash [expr [Widget::getoption $path -width] + 2*[Widget::getoption $path -pad]]
+
+ $path.sash$num.but configure -relief sunken
+ set top [toplevel $path.sash -borderwidth 1 -relief raised]
+
+ set minszg [Widget::getoption $fprev -minsize]
+ set minszd [Widget::getoption $fnext -minsize]
+ set side [Widget::getoption $path -side]
+
+ if { ![string compare $side "top"] || ![string compare $side "bottom"] } {
+ $top configure -cursor sb_h_double_arrow
+ set h [winfo height $path]
+ set yr [winfo rooty $path.sash$num]
+ set xmin [expr $wsash/2+[winfo rootx $fprev]+$minszg]
+ set xmax [expr -$wsash/2-1+[winfo rootx $fnext]+[winfo width $fnext]-$minszd]
+ wm overrideredirect $top 1
+ wm geom $top "2x${h}+$x+$yr"
+
+ update idletasks
+ grab set $top
+ bind $top <ButtonRelease-1> "PanedWindow::_end_move_sash $path $top $num $xmin $xmax %X rootx width"
+ bind $top <Motion> "PanedWindow::_move_sash $top $xmin $xmax %X +%%d+$yr"
+ _move_sash $top $xmin $xmax $x "+%d+$yr"
+ } else {
+ $top configure -cursor sb_v_double_arrow
+ set w [winfo width $path]
+ set xr [winfo rootx $path.sash$num]
+ set ymin [expr $wsash/2+[winfo rooty $fprev]+$minszg]
+ set ymax [expr -$wsash/2-1+[winfo rooty $fnext]+[winfo height $fnext]-$minszd]
+ wm overrideredirect $top 1
+ wm geom $top "${w}x2+$xr+$y"
+
+ update idletasks
+ grab set $top
+ bind $top <ButtonRelease-1> "PanedWindow::_end_move_sash $path $top $num $ymin $ymax %Y rooty height"
+ bind $top <Motion> "PanedWindow::_move_sash $top $ymin $ymax %Y +$xr+%%d"
+ _move_sash $top $ymin $ymax $y "+$xr+%d"
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command PanedWindow::_move_sash
+# ------------------------------------------------------------------------------
+proc PanedWindow::_move_sash { top min max v form } {
+
+ if { $v < $min } {
+ set v $min
+ } elseif { $v > $max } {
+ set v $max
+ }
+ wm geom $top [format $form $v]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command PanedWindow::_end_move_sash
+# ------------------------------------------------------------------------------
+proc PanedWindow::_end_move_sash { path top num min max v rootv size } {
+ variable _panedw
+
+ destroy $top
+ if { $v < $min } {
+ set v $min
+ } elseif { $v > $max } {
+ set v $max
+ }
+ set fprev $path.f[expr $num-1]
+ set fnext $path.f$num
+
+ $path.sash$num.but configure -relief raised
+
+ set wsash [expr [Widget::getoption $path -width] + 2*[Widget::getoption $path -pad]]
+ set dv [expr $v-[winfo $rootv $path.sash$num]-$wsash/2]
+ set w1 [winfo $size $fprev]
+ set w2 [winfo $size $fnext]
+
+ for {set i 0} {$i < $_panedw($path,nbpanes)} {incr i} {
+ if { $i == $num-1} {
+ $fprev configure -$size [expr [winfo $size $fprev]+$dv]
+ } elseif { $i == $num } {
+ $fnext configure -$size [expr [winfo $size $fnext]-$dv]
+ } else {
+ $path.f$i configure -$size [winfo $size $path.f$i]
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command PanedWindow::_realize
+# ------------------------------------------------------------------------------
+proc PanedWindow::_realize { path width height } {
+ variable _panedw
+
+ set x 0
+ set y 0
+ set hc [winfo reqheight $path]
+ set hmax 0
+ for {set i 0} {$i < $_panedw($path,nbpanes)} {incr i} {
+ $path.f$i configure \
+ -width [winfo reqwidth $path.f$i.frame] \
+ -height [winfo reqheight $path.f$i.frame]
+ place $path.f$i.frame -x 0 -y 0 -relwidth 1 -relheight 1
+ }
+
+ bind $path <Configure> {}
+}
Deleted: grass/trunk/lib/external/bwidget/passwddlg.tcl
===================================================================
--- grass/trunk/lib/external/bwidget/passwddlg.tcl 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/passwddlg.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,176 +0,0 @@
-# -----------------------------------------------------------------------------
-# passwddlg.tcl
-# This file is part of Unifix BWidget Toolkit
-# by Stephane Lavirotte (Stephane.Lavirotte at sophia.inria.fr)
-# $Id$
-# -----------------------------------------------------------------------------
-# Index of commands:
-# - PasswdDlg::create
-# - PasswdDlg::configure
-# - PasswdDlg::cget
-# - PasswdDlg::_verifonlogin
-# - PasswdDlg::_verifonpasswd
-# - PasswdDlg::_max
-#------------------------------------------------------------------------------
-
-namespace eval PasswdDlg {
- Dialog::use
- LabelEntry::use
-
- Widget::bwinclude PasswdDlg Dialog "" \
- remove {-image -bitmap -side -default -cancel -separator} \
- initialize {-modal local -anchor c}
-
- Widget::bwinclude PasswdDlg LabelEntry .frame.lablog \
- remove {
- -command -editable -justify -name -show -side -state -takefocus
- -width -xscrollcommand -padx -pady
- -dragenabled -dragendcmd -dragevent -draginitcmd -dragtype
- -dropenabled -dropcmd -dropovercmd -droptypes
- } \
- prefix {login -helptext -helpvar -label -text -textvariable -underline} \
- initialize {-relief sunken -borderwidth 2 -labelanchor w -width 15 -loginlabel "Login"}
-
- Widget::bwinclude PasswdDlg LabelEntry .frame.labpass \
- remove {
- -command -width -show -side -takefocus -xscrollcommand
- -dragenabled -dragendcmd -dragevent -draginitcmd -dragtype
- -dropenabled -dropcmd -dropovercmd -droptypes -justify -padx -pady -name
- } \
- prefix {passwd -editable -helptext -helpvar -label -state -text -textvariable -underline} \
- initialize {-relief sunken -borderwidth 2 -labelanchor w -width 15 -passwdlabel "Password"}
-
- Widget::declare PasswdDlg {
- {-type Enum ok 0 {ok okcancel}}
- {-labelwidth TkResource -1 0 {label -width}}
- {-command String "" 0}
- }
-
- Widget::syncoptions PasswdDlg LabelEntry .frame.lablog {
- -logintext -text -loginlabel -label -loginunderline -underline
- }
- Widget::syncoptions PasswdDlg LabelEntry .frame.labpass {
- -passwdtext -text -passwdlabel -label -passwdunderline -underline
- }
-
- proc ::PasswdDlg { path args } { return [eval PasswdDlg::create $path $args] }
- proc use {} {}
-}
-
-
-# -----------------------------------------------------------------------------
-# Command PasswdDlg::create
-# -----------------------------------------------------------------------------
-proc PasswdDlg::create { path args } {
-
- Widget::init PasswdDlg "$path#PasswdDlg" $args
- set type [Widget::getoption "$path#PasswdDlg" -type]
- set loglabel [Widget::getoption "$path#PasswdDlg" -loginlabel]
- set passlabel [Widget::getoption "$path#PasswdDlg" -passwdlabel]
- set labwidth [Widget::getoption "$path#PasswdDlg" -labelwidth]
- set cmd [Widget::getoption "$path#PasswdDlg" -command]
-
- set defb -1
- set canb -1
- switch -- $type {
- ok { set lbut {ok}; set defb 0 }
- okcancel { set lbut {ok cancel} ; set defb 0; set canb 1 }
- }
-
- eval Dialog::create $path [Widget::subcget "$path#PasswdDlg" ""] \
- -image [Bitmap::get passwd] -side bottom -default $defb -cancel $canb
- foreach but $lbut {
- if { $but == "ok" && $cmd != "" } {
- Dialog::add $path -text $but -name $but -command $cmd
- } else {
- Dialog::add $path -text $but -name $but
- }
- }
- set frame [Dialog::getframe $path]
- bind $path <Return> ""
- bind $frame <Destroy> "Widget::destroy $path#PasswdDlg"
-
- set lablog [eval LabelEntry::create $frame.lablog \
- [Widget::subcget "$path#PasswdDlg" .frame.lablog] \
- -label \"$loglabel\" -name login \
- -dragenabled 0 -dropenabled 0 \
- -command \"PasswdDlg::_verifonpasswd $path $frame.labpass\"]
-
- set labpass [eval LabelEntry::create $frame.labpass \
- [Widget::subcget "$path#PasswdDlg" .frame.labpass] \
- -label \"$passlabel\" -name password -show "*" \
- -dragenabled 0 -dropenabled 0 \
- -command \"PasswdDlg::_verifonlogin $path $frame.lablog\"]
-
- if { $labwidth == -1 } {
- # les options -label sont mises a jour selon -name
- set loglabel [$lablog cget -label]
- set passlabel [$labpass cget -label]
- set labwidth [PasswdDlg::_max [string length $loglabel] [string length $passlabel]]
- incr labwidth 1
- $lablog configure -labelwidth $labwidth
- $labpass configure -labelwidth $labwidth
- }
-
- proc ::$path { cmd args } "return \[eval PasswdDlg::\$cmd $path \$args\]"
-
- pack $frame.lablog $frame.labpass -fill x -expand 1
- focus $frame.lablog.e
- set res [Dialog::draw $path]
-
- if { $res == 0 } {
- set res [list [$lablog.e cget -text] [$labpass.e cget -text]]
- } else {
- set res [list]
- }
- Widget::destroy "$path#PasswdDlg"
- destroy $path
-
- return $res
-}
-
-# -----------------------------------------------------------------------------
-# Command PasswdDlg::configure
-# -----------------------------------------------------------------------------
-
-proc PasswdDlg::configure { path args } {
- set res [Widget::configure "$path#PasswdDlg" $args]
-}
-
-# -----------------------------------------------------------------------------
-# Command PasswdDlg::cget
-# -----------------------------------------------------------------------------
-
-proc PasswdDlg::cget { path option } {
- return [Widget::cget "$path#PasswdDlg" $option]
-}
-
-
-# -----------------------------------------------------------------------------
-# Command PasswdDlg::_verifonlogin
-# -----------------------------------------------------------------------------
-proc PasswdDlg::_verifonlogin { path labpass } {
- if { [$labpass.e cget -text] == "" } {
- focus $labpass
- } else {
- Dialog::setfocus $path default
- }
-}
-
-# -----------------------------------------------------------------------------
-# Command PasswdDlg::_verifonpasswd
-# -----------------------------------------------------------------------------
-proc PasswdDlg::_verifonpasswd { path lablog } {
- if { [$lablog.e cget -text] == "" } {
- focus $lablog
- } else {
- Dialog::setfocus $path default
- }
-}
-
-# -----------------------------------------------------------------------------
-# Command PasswdDlg::_max
-# -----------------------------------------------------------------------------
-proc PasswdDlg::_max { val1 val2 } {
- return [expr ($val1 > $val2) ? ($val1) : ($val2)]
-}
Copied: grass/trunk/lib/external/bwidget/passwddlg.tcl (from rev 35192, grass/trunk/lib/external/bwidget/passwddlg.tcl)
===================================================================
--- grass/trunk/lib/external/bwidget/passwddlg.tcl (rev 0)
+++ grass/trunk/lib/external/bwidget/passwddlg.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,176 @@
+# -----------------------------------------------------------------------------
+# passwddlg.tcl
+# This file is part of Unifix BWidget Toolkit
+# by Stephane Lavirotte (Stephane.Lavirotte at sophia.inria.fr)
+# $Id$
+# -----------------------------------------------------------------------------
+# Index of commands:
+# - PasswdDlg::create
+# - PasswdDlg::configure
+# - PasswdDlg::cget
+# - PasswdDlg::_verifonlogin
+# - PasswdDlg::_verifonpasswd
+# - PasswdDlg::_max
+#------------------------------------------------------------------------------
+
+namespace eval PasswdDlg {
+ Dialog::use
+ LabelEntry::use
+
+ Widget::bwinclude PasswdDlg Dialog "" \
+ remove {-image -bitmap -side -default -cancel -separator} \
+ initialize {-modal local -anchor c}
+
+ Widget::bwinclude PasswdDlg LabelEntry .frame.lablog \
+ remove {
+ -command -editable -justify -name -show -side -state -takefocus
+ -width -xscrollcommand -padx -pady
+ -dragenabled -dragendcmd -dragevent -draginitcmd -dragtype
+ -dropenabled -dropcmd -dropovercmd -droptypes
+ } \
+ prefix {login -helptext -helpvar -label -text -textvariable -underline} \
+ initialize {-relief sunken -borderwidth 2 -labelanchor w -width 15 -loginlabel "Login"}
+
+ Widget::bwinclude PasswdDlg LabelEntry .frame.labpass \
+ remove {
+ -command -width -show -side -takefocus -xscrollcommand
+ -dragenabled -dragendcmd -dragevent -draginitcmd -dragtype
+ -dropenabled -dropcmd -dropovercmd -droptypes -justify -padx -pady -name
+ } \
+ prefix {passwd -editable -helptext -helpvar -label -state -text -textvariable -underline} \
+ initialize {-relief sunken -borderwidth 2 -labelanchor w -width 15 -passwdlabel "Password"}
+
+ Widget::declare PasswdDlg {
+ {-type Enum ok 0 {ok okcancel}}
+ {-labelwidth TkResource -1 0 {label -width}}
+ {-command String "" 0}
+ }
+
+ Widget::syncoptions PasswdDlg LabelEntry .frame.lablog {
+ -logintext -text -loginlabel -label -loginunderline -underline
+ }
+ Widget::syncoptions PasswdDlg LabelEntry .frame.labpass {
+ -passwdtext -text -passwdlabel -label -passwdunderline -underline
+ }
+
+ proc ::PasswdDlg { path args } { return [eval PasswdDlg::create $path $args] }
+ proc use {} {}
+}
+
+
+# -----------------------------------------------------------------------------
+# Command PasswdDlg::create
+# -----------------------------------------------------------------------------
+proc PasswdDlg::create { path args } {
+
+ Widget::init PasswdDlg "$path#PasswdDlg" $args
+ set type [Widget::getoption "$path#PasswdDlg" -type]
+ set loglabel [Widget::getoption "$path#PasswdDlg" -loginlabel]
+ set passlabel [Widget::getoption "$path#PasswdDlg" -passwdlabel]
+ set labwidth [Widget::getoption "$path#PasswdDlg" -labelwidth]
+ set cmd [Widget::getoption "$path#PasswdDlg" -command]
+
+ set defb -1
+ set canb -1
+ switch -- $type {
+ ok { set lbut {ok}; set defb 0 }
+ okcancel { set lbut {ok cancel} ; set defb 0; set canb 1 }
+ }
+
+ eval Dialog::create $path [Widget::subcget "$path#PasswdDlg" ""] \
+ -image [Bitmap::get passwd] -side bottom -default $defb -cancel $canb
+ foreach but $lbut {
+ if { $but == "ok" && $cmd != "" } {
+ Dialog::add $path -text $but -name $but -command $cmd
+ } else {
+ Dialog::add $path -text $but -name $but
+ }
+ }
+ set frame [Dialog::getframe $path]
+ bind $path <Return> ""
+ bind $frame <Destroy> "Widget::destroy $path#PasswdDlg"
+
+ set lablog [eval LabelEntry::create $frame.lablog \
+ [Widget::subcget "$path#PasswdDlg" .frame.lablog] \
+ -label \"$loglabel\" -name login \
+ -dragenabled 0 -dropenabled 0 \
+ -command \"PasswdDlg::_verifonpasswd $path $frame.labpass\"]
+
+ set labpass [eval LabelEntry::create $frame.labpass \
+ [Widget::subcget "$path#PasswdDlg" .frame.labpass] \
+ -label \"$passlabel\" -name password -show "*" \
+ -dragenabled 0 -dropenabled 0 \
+ -command \"PasswdDlg::_verifonlogin $path $frame.lablog\"]
+
+ if { $labwidth == -1 } {
+ # les options -label sont mises a jour selon -name
+ set loglabel [$lablog cget -label]
+ set passlabel [$labpass cget -label]
+ set labwidth [PasswdDlg::_max [string length $loglabel] [string length $passlabel]]
+ incr labwidth 1
+ $lablog configure -labelwidth $labwidth
+ $labpass configure -labelwidth $labwidth
+ }
+
+ proc ::$path { cmd args } "return \[eval PasswdDlg::\$cmd $path \$args\]"
+
+ pack $frame.lablog $frame.labpass -fill x -expand 1
+ focus $frame.lablog.e
+ set res [Dialog::draw $path]
+
+ if { $res == 0 } {
+ set res [list [$lablog.e cget -text] [$labpass.e cget -text]]
+ } else {
+ set res [list]
+ }
+ Widget::destroy "$path#PasswdDlg"
+ destroy $path
+
+ return $res
+}
+
+# -----------------------------------------------------------------------------
+# Command PasswdDlg::configure
+# -----------------------------------------------------------------------------
+
+proc PasswdDlg::configure { path args } {
+ set res [Widget::configure "$path#PasswdDlg" $args]
+}
+
+# -----------------------------------------------------------------------------
+# Command PasswdDlg::cget
+# -----------------------------------------------------------------------------
+
+proc PasswdDlg::cget { path option } {
+ return [Widget::cget "$path#PasswdDlg" $option]
+}
+
+
+# -----------------------------------------------------------------------------
+# Command PasswdDlg::_verifonlogin
+# -----------------------------------------------------------------------------
+proc PasswdDlg::_verifonlogin { path labpass } {
+ if { [$labpass.e cget -text] == "" } {
+ focus $labpass
+ } else {
+ Dialog::setfocus $path default
+ }
+}
+
+# -----------------------------------------------------------------------------
+# Command PasswdDlg::_verifonpasswd
+# -----------------------------------------------------------------------------
+proc PasswdDlg::_verifonpasswd { path lablog } {
+ if { [$lablog.e cget -text] == "" } {
+ focus $lablog
+ } else {
+ Dialog::setfocus $path default
+ }
+}
+
+# -----------------------------------------------------------------------------
+# Command PasswdDlg::_max
+# -----------------------------------------------------------------------------
+proc PasswdDlg::_max { val1 val2 } {
+ return [expr ($val1 > $val2) ? ($val1) : ($val2)]
+}
Deleted: grass/trunk/lib/external/bwidget/pkgIndex.tcl
===================================================================
--- grass/trunk/lib/external/bwidget/pkgIndex.tcl 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/pkgIndex.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,43 +0,0 @@
-if {[catch {package require Tcl}]} return
-package ifneeded BWidget 1.2.1 "\
- package require Tk 8.0;\
- [list tclPkgSetup $dir BWidget 1.2.1 {
-{arrow.tcl source {ArrowButton ArrowButton::create ArrowButton::use}}
-{labelframe.tcl source {LabelFrame LabelFrame::create LabelFrame::use}}
-{labelentry.tcl source {LabelEntry LabelEntry::create LabelEntry::use}}
-{bitmap.tcl source {Bitmap::get Bitmap::use}}
-{button.tcl source {Button Button::create Button::use}}
-{buttonbox.tcl source {ButtonBox ButtonBox::create ButtonBox::use}}
-{combobox.tcl source {ComboBox ComboBox::create ComboBox::use}}
-{label.tcl source {Label Label::create Label::use}}
-{entry.tcl source {Entry Entry::create Entry::use}}
-{pagesmgr.tcl source {PagesManager PagesManager::create PagesManager::use}}
-{notebook.tcl source {NoteBook NoteBook::create NoteBook::use}}
-{panedw.tcl source {PanedWindow PanedWindow::create PanedWindow::use}}
-{scrollw.tcl source {ScrolledWindow ScrolledWindow::create ScrolledWindow::use}}
-{scrollview.tcl source {ScrollView ScrollView::create ScrollView::use}}
-{scrollframe.tcl source {ScrollableFrame ScrollableFrame::create ScrollableFrame::use}}
-{progressbar.tcl source {ProgressBar ProgressBar::create ProgressBar::use}}
-{progressdlg.tcl source {ProgressDlg ProgressDlg::create ProgressDlg::use}}
-{passwddlg.tcl source {PasswdDlg PasswdDlg::create PasswdDlg::use}}
-{dragsite.tcl source {DragSite::register DragSite::include DragSite::use}}
-{dropsite.tcl source {DropSite::register DropSite::include DropSite::use}}
-{separator.tcl source {Separator Separator::create Separator::use}}
-{spinbox.tcl source {SpinBox SpinBox::create SpinBox::use}}
-{titleframe.tcl source {TitleFrame TitleFrame::create TitleFrame::use}}
-{mainframe.tcl source {MainFrame MainFrame::create MainFrame::use}}
-{listbox.tcl source {ListBox ListBox::create ListBox::use}}
-{tree.tcl source {Tree Tree::create Tree::use}}
-{color.tcl source {SelectColor SelectColor::create SelectColor::use SelectColor::setcolor}}
-{dynhelp.tcl source {DynamicHelp::configure DynamicHelp::use DynamicHelp::register DynamicHelp::include}}
-{dialog.tcl source {Dialog Dialog::create Dialog::use}}
-{messagedlg.tcl source {MessageDlg MessageDlg::create MessageDlg::use}}
-{font.tcl source {SelectFont SelectFont::create SelectFont::use SelectFont::loadfont}}
-{widgetdoc.tcl source {Widget::generate-doc Widget::generate-widget-doc}}
-{xpm2image.tcl source {xpm-to-image}}
-}]; \
- [list set env(BWIDGET_LIBRARY) $dir]; \
- [list source [file join $dir widget.tcl]]; \
- [list source [file join $dir init.tcl]]; \
- [list source [file join $dir utils.tcl]]; \
-"
Copied: grass/trunk/lib/external/bwidget/pkgIndex.tcl (from rev 35192, grass/trunk/lib/external/bwidget/pkgIndex.tcl)
===================================================================
--- grass/trunk/lib/external/bwidget/pkgIndex.tcl (rev 0)
+++ grass/trunk/lib/external/bwidget/pkgIndex.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,43 @@
+if {[catch {package require Tcl}]} return
+package ifneeded BWidget 1.2.1 "\
+ package require Tk 8.0;\
+ [list tclPkgSetup $dir BWidget 1.2.1 {
+{arrow.tcl source {ArrowButton ArrowButton::create ArrowButton::use}}
+{labelframe.tcl source {LabelFrame LabelFrame::create LabelFrame::use}}
+{labelentry.tcl source {LabelEntry LabelEntry::create LabelEntry::use}}
+{bitmap.tcl source {Bitmap::get Bitmap::use}}
+{button.tcl source {Button Button::create Button::use}}
+{buttonbox.tcl source {ButtonBox ButtonBox::create ButtonBox::use}}
+{combobox.tcl source {ComboBox ComboBox::create ComboBox::use}}
+{label.tcl source {Label Label::create Label::use}}
+{entry.tcl source {Entry Entry::create Entry::use}}
+{pagesmgr.tcl source {PagesManager PagesManager::create PagesManager::use}}
+{notebook.tcl source {NoteBook NoteBook::create NoteBook::use}}
+{panedw.tcl source {PanedWindow PanedWindow::create PanedWindow::use}}
+{scrollw.tcl source {ScrolledWindow ScrolledWindow::create ScrolledWindow::use}}
+{scrollview.tcl source {ScrollView ScrollView::create ScrollView::use}}
+{scrollframe.tcl source {ScrollableFrame ScrollableFrame::create ScrollableFrame::use}}
+{progressbar.tcl source {ProgressBar ProgressBar::create ProgressBar::use}}
+{progressdlg.tcl source {ProgressDlg ProgressDlg::create ProgressDlg::use}}
+{passwddlg.tcl source {PasswdDlg PasswdDlg::create PasswdDlg::use}}
+{dragsite.tcl source {DragSite::register DragSite::include DragSite::use}}
+{dropsite.tcl source {DropSite::register DropSite::include DropSite::use}}
+{separator.tcl source {Separator Separator::create Separator::use}}
+{spinbox.tcl source {SpinBox SpinBox::create SpinBox::use}}
+{titleframe.tcl source {TitleFrame TitleFrame::create TitleFrame::use}}
+{mainframe.tcl source {MainFrame MainFrame::create MainFrame::use}}
+{listbox.tcl source {ListBox ListBox::create ListBox::use}}
+{tree.tcl source {Tree Tree::create Tree::use}}
+{color.tcl source {SelectColor SelectColor::create SelectColor::use SelectColor::setcolor}}
+{dynhelp.tcl source {DynamicHelp::configure DynamicHelp::use DynamicHelp::register DynamicHelp::include}}
+{dialog.tcl source {Dialog Dialog::create Dialog::use}}
+{messagedlg.tcl source {MessageDlg MessageDlg::create MessageDlg::use}}
+{font.tcl source {SelectFont SelectFont::create SelectFont::use SelectFont::loadfont}}
+{widgetdoc.tcl source {Widget::generate-doc Widget::generate-widget-doc}}
+{xpm2image.tcl source {xpm-to-image}}
+}]; \
+ [list set env(BWIDGET_LIBRARY) $dir]; \
+ [list source [file join $dir widget.tcl]]; \
+ [list source [file join $dir init.tcl]]; \
+ [list source [file join $dir utils.tcl]]; \
+"
Deleted: grass/trunk/lib/external/bwidget/progressbar.tcl
===================================================================
--- grass/trunk/lib/external/bwidget/progressbar.tcl 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/progressbar.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,186 +0,0 @@
-# ------------------------------------------------------------------------------
-# progressbar.tcl
-# This file is part of Unifix BWidget Toolkit
-# ------------------------------------------------------------------------------
-# Index of commands:
-# - ProgressBar::create
-# - ProgressBar::configure
-# - ProgressBar::cget
-# - ProgressBar::_destroy
-# - ProgressBar::_modify
-# ------------------------------------------------------------------------------
-
-namespace eval ProgressBar {
- Widget::declare ProgressBar {
- {-type Enum normal 0 {normal incremental infinite}}
- {-maximum Int 100 0 {>0}}
- {-background TkResource "" 0 frame}
- {-foreground TkResource blue 0 label}
- {-borderwidth TkResource 2 0 frame}
- {-troughcolor TkResource "" 0 scrollbar}
- {-relief TkResource sunken 0 label}
- {-orient Enum horizontal 1 {horizontal vertical}}
- {-variable String "" 0}
- {-width TkResource 100 0 frame}
- {-height TkResource 4m 0 frame}
- {-bg Synonym -background}
- {-fg Synonym -foreground}
- {-bd Synonym -borderwidth}
- }
-
- Widget::addmap ProgressBar "" :cmd {-background {} -width {} -height {}}
- Widget::addmap ProgressBar "" .bar {-troughcolor -background -borderwidth {} -relief {}}
-
- variable _widget
-
- proc ::ProgressBar { path args } { return [eval ProgressBar::create $path $args] }
- proc use {} {}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ProgressBar::create
-# ------------------------------------------------------------------------------
-proc ProgressBar::create { path args } {
- variable _widget
-
- Widget::init ProgressBar $path $args
-
- eval frame $path [Widget::subcget $path :cmd]
- set c [eval canvas $path.bar [Widget::subcget $path .bar] -highlightthickness 0]
- set fg [Widget::getoption $path -foreground]
- if { ![string compare [Widget::getoption $path -orient] "horizontal"] } {
- $path.bar create rectangle -1 0 0 0 -fill $fg -outline $fg -tags rect
- } else {
- $path.bar create rectangle 0 1 0 0 -fill $fg -outline $fg -tags rect
- }
-
- set _widget($path,val) 0
- set _widget($path,dir) 1
- if { [set _widget($path,var) [Widget::getoption $path -variable]] != "" } {
- GlobalVar::tracevar variable $_widget($path,var) w "ProgressBar::_modify $path"
- after idle ProgressBar::_modify $path
- }
-
- bind $path.bar <Destroy> "ProgressBar::_destroy $path"
- bind $path.bar <Configure> "ProgressBar::_modify $path"
-
- rename $path ::$path:cmd
- proc ::$path { cmd args } "return \[eval ProgressBar::\$cmd $path \$args\]"
-
- return $path
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ProgressBar::configure
-# ------------------------------------------------------------------------------
-proc ProgressBar::configure { path args } {
- variable _widget
-
- set res [Widget::configure $path $args]
-
- if { [Widget::hasChanged $path -variable newv] } {
- if { $_widget($path,var) != "" } {
- GlobalVar::tracevar vdelete $_widget($path,var) w "ProgressBar::_modify $path"
- }
- if { $newv != "" } {
- set _widget($path,var) $newv
- GlobalVar::tracevar variable $newv w "ProgressBar::_modify $path"
- after idle ProgressBar::_modify $path
- } else {
- set _widget($path,var) ""
- }
- }
-
- if { [Widget::hasChanged $path -borderwidth v] ||
- [Widget::hasChanged $path -orient v] } {
- after idle ProgressBar::_modify $path
- }
- if { [Widget::hasChanged $path -foreground fg] } {
- $path.bar itemconfigure rect -fill $fg -outline $fg
- }
- return $res
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ProgressBar::cget
-# ------------------------------------------------------------------------------
-proc ProgressBar::cget { path option } {
- return [Widget::cget $path $option]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ProgressBar::_destroy
-# ------------------------------------------------------------------------------
-proc ProgressBar::_destroy { path } {
- variable _widget
-
- if { $_widget($path,var) != "" } {
- GlobalVar::tracevar vdelete $_widget($path,var) w "ProgressBar::_modify $path"
- }
- unset _widget($path,var)
- unset _widget($path,dir)
- Widget::destroy $path
- rename $path {}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ProgressBar::_modify
-# ------------------------------------------------------------------------------
-proc ProgressBar::_modify { path args } {
- variable _widget
-
- if { ![GlobalVar::exists $_widget($path,var)] ||
- [set val [GlobalVar::getvar $_widget($path,var)]] < 0 } {
- catch {place forget $path.bar}
- } else {
- place $path.bar -relx 0 -rely 0 -relwidth 1 -relheight 1
- set type [Widget::getoption $path -type]
- if { $val != 0 && [string compare $type "normal"] } {
- set val [expr {$val+$_widget($path,val)}]
- }
- set _widget($path,val) $val
- set max [Widget::getoption $path -maximum]
- set bd [expr {2*[$path.bar cget -bd]}]
- set w [winfo width $path.bar]
- set h [winfo height $path.bar]
- if { ![string compare $type "infinite"] } {
- if { $val > $max } {
- set _widget($path,dir) [expr {-$_widget($path,dir)}]
- set val 0
- set _widget($path,val) 0
- }
- if { $val <= $max/2.0 } {
- set dx0 0.0
- set dx1 [expr {double($val)/$max}]
- } else {
- set dx1 [expr {double($val)/$max}]
- set dx0 [expr {$dx1-0.5}]
- }
- if { $_widget($path,dir) == 1 } {
- set x0 $dx0
- set x1 $dx1
- } else {
- set x0 [expr {1-$dx1}]
- set x1 [expr {1-$dx0}]
- }
- if { ![string compare [Widget::getoption $path -orient] "horizontal"] } {
- $path.bar coords rect [expr {$x0*$w}] 0 [expr {$x1*$w}] $h
- } else {
- $path.bar coords rect 0 [expr {$h-$x0*$h}] $w [expr {$x1*$h}]
- }
- } else {
- if { $val > $max } {set val $max}
- if { ![string compare [Widget::getoption $path -orient] "horizontal"] } {
- $path.bar coords rect -1 0 [expr {$val*$w/$max}] $h
- } else {
- $path.bar coords rect 0 [expr {$h+1}] $w [expr {$h*($max-$val)}]
- }
- }
- }
- update
-}
Copied: grass/trunk/lib/external/bwidget/progressbar.tcl (from rev 35192, grass/trunk/lib/external/bwidget/progressbar.tcl)
===================================================================
--- grass/trunk/lib/external/bwidget/progressbar.tcl (rev 0)
+++ grass/trunk/lib/external/bwidget/progressbar.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,186 @@
+# ------------------------------------------------------------------------------
+# progressbar.tcl
+# This file is part of Unifix BWidget Toolkit
+# ------------------------------------------------------------------------------
+# Index of commands:
+# - ProgressBar::create
+# - ProgressBar::configure
+# - ProgressBar::cget
+# - ProgressBar::_destroy
+# - ProgressBar::_modify
+# ------------------------------------------------------------------------------
+
+namespace eval ProgressBar {
+ Widget::declare ProgressBar {
+ {-type Enum normal 0 {normal incremental infinite}}
+ {-maximum Int 100 0 {>0}}
+ {-background TkResource "" 0 frame}
+ {-foreground TkResource blue 0 label}
+ {-borderwidth TkResource 2 0 frame}
+ {-troughcolor TkResource "" 0 scrollbar}
+ {-relief TkResource sunken 0 label}
+ {-orient Enum horizontal 1 {horizontal vertical}}
+ {-variable String "" 0}
+ {-width TkResource 100 0 frame}
+ {-height TkResource 4m 0 frame}
+ {-bg Synonym -background}
+ {-fg Synonym -foreground}
+ {-bd Synonym -borderwidth}
+ }
+
+ Widget::addmap ProgressBar "" :cmd {-background {} -width {} -height {}}
+ Widget::addmap ProgressBar "" .bar {-troughcolor -background -borderwidth {} -relief {}}
+
+ variable _widget
+
+ proc ::ProgressBar { path args } { return [eval ProgressBar::create $path $args] }
+ proc use {} {}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ProgressBar::create
+# ------------------------------------------------------------------------------
+proc ProgressBar::create { path args } {
+ variable _widget
+
+ Widget::init ProgressBar $path $args
+
+ eval frame $path [Widget::subcget $path :cmd]
+ set c [eval canvas $path.bar [Widget::subcget $path .bar] -highlightthickness 0]
+ set fg [Widget::getoption $path -foreground]
+ if { ![string compare [Widget::getoption $path -orient] "horizontal"] } {
+ $path.bar create rectangle -1 0 0 0 -fill $fg -outline $fg -tags rect
+ } else {
+ $path.bar create rectangle 0 1 0 0 -fill $fg -outline $fg -tags rect
+ }
+
+ set _widget($path,val) 0
+ set _widget($path,dir) 1
+ if { [set _widget($path,var) [Widget::getoption $path -variable]] != "" } {
+ GlobalVar::tracevar variable $_widget($path,var) w "ProgressBar::_modify $path"
+ after idle ProgressBar::_modify $path
+ }
+
+ bind $path.bar <Destroy> "ProgressBar::_destroy $path"
+ bind $path.bar <Configure> "ProgressBar::_modify $path"
+
+ rename $path ::$path:cmd
+ proc ::$path { cmd args } "return \[eval ProgressBar::\$cmd $path \$args\]"
+
+ return $path
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ProgressBar::configure
+# ------------------------------------------------------------------------------
+proc ProgressBar::configure { path args } {
+ variable _widget
+
+ set res [Widget::configure $path $args]
+
+ if { [Widget::hasChanged $path -variable newv] } {
+ if { $_widget($path,var) != "" } {
+ GlobalVar::tracevar vdelete $_widget($path,var) w "ProgressBar::_modify $path"
+ }
+ if { $newv != "" } {
+ set _widget($path,var) $newv
+ GlobalVar::tracevar variable $newv w "ProgressBar::_modify $path"
+ after idle ProgressBar::_modify $path
+ } else {
+ set _widget($path,var) ""
+ }
+ }
+
+ if { [Widget::hasChanged $path -borderwidth v] ||
+ [Widget::hasChanged $path -orient v] } {
+ after idle ProgressBar::_modify $path
+ }
+ if { [Widget::hasChanged $path -foreground fg] } {
+ $path.bar itemconfigure rect -fill $fg -outline $fg
+ }
+ return $res
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ProgressBar::cget
+# ------------------------------------------------------------------------------
+proc ProgressBar::cget { path option } {
+ return [Widget::cget $path $option]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ProgressBar::_destroy
+# ------------------------------------------------------------------------------
+proc ProgressBar::_destroy { path } {
+ variable _widget
+
+ if { $_widget($path,var) != "" } {
+ GlobalVar::tracevar vdelete $_widget($path,var) w "ProgressBar::_modify $path"
+ }
+ unset _widget($path,var)
+ unset _widget($path,dir)
+ Widget::destroy $path
+ rename $path {}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ProgressBar::_modify
+# ------------------------------------------------------------------------------
+proc ProgressBar::_modify { path args } {
+ variable _widget
+
+ if { ![GlobalVar::exists $_widget($path,var)] ||
+ [set val [GlobalVar::getvar $_widget($path,var)]] < 0 } {
+ catch {place forget $path.bar}
+ } else {
+ place $path.bar -relx 0 -rely 0 -relwidth 1 -relheight 1
+ set type [Widget::getoption $path -type]
+ if { $val != 0 && [string compare $type "normal"] } {
+ set val [expr {$val+$_widget($path,val)}]
+ }
+ set _widget($path,val) $val
+ set max [Widget::getoption $path -maximum]
+ set bd [expr {2*[$path.bar cget -bd]}]
+ set w [winfo width $path.bar]
+ set h [winfo height $path.bar]
+ if { ![string compare $type "infinite"] } {
+ if { $val > $max } {
+ set _widget($path,dir) [expr {-$_widget($path,dir)}]
+ set val 0
+ set _widget($path,val) 0
+ }
+ if { $val <= $max/2.0 } {
+ set dx0 0.0
+ set dx1 [expr {double($val)/$max}]
+ } else {
+ set dx1 [expr {double($val)/$max}]
+ set dx0 [expr {$dx1-0.5}]
+ }
+ if { $_widget($path,dir) == 1 } {
+ set x0 $dx0
+ set x1 $dx1
+ } else {
+ set x0 [expr {1-$dx1}]
+ set x1 [expr {1-$dx0}]
+ }
+ if { ![string compare [Widget::getoption $path -orient] "horizontal"] } {
+ $path.bar coords rect [expr {$x0*$w}] 0 [expr {$x1*$w}] $h
+ } else {
+ $path.bar coords rect 0 [expr {$h-$x0*$h}] $w [expr {$x1*$h}]
+ }
+ } else {
+ if { $val > $max } {set val $max}
+ if { ![string compare [Widget::getoption $path -orient] "horizontal"] } {
+ $path.bar coords rect -1 0 [expr {$val*$w/$max}] $h
+ } else {
+ $path.bar coords rect 0 [expr {$h+1}] $w [expr {$h*($max-$val)}]
+ }
+ }
+ }
+ update
+}
Deleted: grass/trunk/lib/external/bwidget/progressdlg.tcl
===================================================================
--- grass/trunk/lib/external/bwidget/progressdlg.tcl 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/progressdlg.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,89 +0,0 @@
-# ------------------------------------------------------------------------------
-# progressdlg.tcl
-# This file is part of Unifix BWidget Toolkit
-# ------------------------------------------------------------------------------
-# Index of commands:
-# - ProgressDlg::create
-# ------------------------------------------------------------------------------
-
-namespace eval ProgressDlg {
- Dialog::use
- ProgressBar::use
-
- Widget::bwinclude ProgressDlg Dialog "" \
- remove {
- -modal -image -bitmap -side -anchor -cancel -default
- -homogeneous -padx -pady -spacing
- }
-
- Widget::bwinclude ProgressDlg ProgressBar .frame.pb \
- remove {-orient -width -height}
-
- Widget::declare ProgressDlg {
- {-width TkResource 25 0 label}
- {-height TkResource 2 0 label}
- {-textvariable TkResource "" 0 label}
- {-font TkResource "" 0 label}
- {-stop String "" 0}
- {-command String "" 0}
- }
-
- Widget::addmap ProgressDlg "" .frame.msg \
- {-width {} -height {} -textvariable {} -font {} -background {}}
-
- proc ::ProgressDlg { path args } { return [eval ProgressDlg::create $path $args] }
- proc use {} {}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ProgressDlg::create
-# ------------------------------------------------------------------------------
-proc ProgressDlg::create { path args } {
- Widget::init ProgressDlg "$path#ProgressDlg" $args
-
- eval Dialog::create $path [Widget::subcget "$path#ProgressDlg" ""] \
- -image [Bitmap::get hourglass] -modal none -side bottom -anchor c
- wm protocol $path WM_DELETE_WINDOW {;}
-
- set frame [Dialog::getframe $path]
- bind $frame <Destroy> "Widget::destroy $path#ProgressDlg"
- $frame configure -cursor watch
-
- eval label $frame.msg [Widget::subcget "$path#ProgressDlg" .frame.msg] \
- -relief flat -borderwidth 0 -highlightthickness 0 -anchor w -justify left
- pack $frame.msg -side top -pady 3m -anchor nw -fill x -expand yes
-
- set var [Widget::cget "$path#ProgressDlg" -variable]
- eval ProgressBar::create $frame.pb [Widget::subcget "$path#ProgressDlg" .frame.pb] \
- -width 100
- pack $frame.pb -side bottom -anchor w -fill x -expand yes
-
- set stop [Widget::cget "$path#ProgressDlg" -stop]
- set cmd [Widget::cget "$path#ProgressDlg" -command]
- if { $stop != "" && $cmd != "" } {
- Dialog::add $path -text $stop -name $stop -command $cmd
- }
- Dialog::draw $path
- BWidget::grab local $path
-
- proc ::$path { cmd args } "return \[eval ProgressDlg::\$cmd $path \$args\]"
-
- return $path
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ProgressDlg::configure
-# ------------------------------------------------------------------------------
-proc ProgressDlg::configure { path args } {
- return [Widget::configure "$path#ProgressDlg" $args]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ProgressDlg::cget
-# ------------------------------------------------------------------------------
-proc ProgressDlg::cget { path option } {
- return [Widget::cget "$path#ProgressDlg" $option]
-}
Copied: grass/trunk/lib/external/bwidget/progressdlg.tcl (from rev 35192, grass/trunk/lib/external/bwidget/progressdlg.tcl)
===================================================================
--- grass/trunk/lib/external/bwidget/progressdlg.tcl (rev 0)
+++ grass/trunk/lib/external/bwidget/progressdlg.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,89 @@
+# ------------------------------------------------------------------------------
+# progressdlg.tcl
+# This file is part of Unifix BWidget Toolkit
+# ------------------------------------------------------------------------------
+# Index of commands:
+# - ProgressDlg::create
+# ------------------------------------------------------------------------------
+
+namespace eval ProgressDlg {
+ Dialog::use
+ ProgressBar::use
+
+ Widget::bwinclude ProgressDlg Dialog "" \
+ remove {
+ -modal -image -bitmap -side -anchor -cancel -default
+ -homogeneous -padx -pady -spacing
+ }
+
+ Widget::bwinclude ProgressDlg ProgressBar .frame.pb \
+ remove {-orient -width -height}
+
+ Widget::declare ProgressDlg {
+ {-width TkResource 25 0 label}
+ {-height TkResource 2 0 label}
+ {-textvariable TkResource "" 0 label}
+ {-font TkResource "" 0 label}
+ {-stop String "" 0}
+ {-command String "" 0}
+ }
+
+ Widget::addmap ProgressDlg "" .frame.msg \
+ {-width {} -height {} -textvariable {} -font {} -background {}}
+
+ proc ::ProgressDlg { path args } { return [eval ProgressDlg::create $path $args] }
+ proc use {} {}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ProgressDlg::create
+# ------------------------------------------------------------------------------
+proc ProgressDlg::create { path args } {
+ Widget::init ProgressDlg "$path#ProgressDlg" $args
+
+ eval Dialog::create $path [Widget::subcget "$path#ProgressDlg" ""] \
+ -image [Bitmap::get hourglass] -modal none -side bottom -anchor c
+ wm protocol $path WM_DELETE_WINDOW {;}
+
+ set frame [Dialog::getframe $path]
+ bind $frame <Destroy> "Widget::destroy $path#ProgressDlg"
+ $frame configure -cursor watch
+
+ eval label $frame.msg [Widget::subcget "$path#ProgressDlg" .frame.msg] \
+ -relief flat -borderwidth 0 -highlightthickness 0 -anchor w -justify left
+ pack $frame.msg -side top -pady 3m -anchor nw -fill x -expand yes
+
+ set var [Widget::cget "$path#ProgressDlg" -variable]
+ eval ProgressBar::create $frame.pb [Widget::subcget "$path#ProgressDlg" .frame.pb] \
+ -width 100
+ pack $frame.pb -side bottom -anchor w -fill x -expand yes
+
+ set stop [Widget::cget "$path#ProgressDlg" -stop]
+ set cmd [Widget::cget "$path#ProgressDlg" -command]
+ if { $stop != "" && $cmd != "" } {
+ Dialog::add $path -text $stop -name $stop -command $cmd
+ }
+ Dialog::draw $path
+ BWidget::grab local $path
+
+ proc ::$path { cmd args } "return \[eval ProgressDlg::\$cmd $path \$args\]"
+
+ return $path
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ProgressDlg::configure
+# ------------------------------------------------------------------------------
+proc ProgressDlg::configure { path args } {
+ return [Widget::configure "$path#ProgressDlg" $args]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ProgressDlg::cget
+# ------------------------------------------------------------------------------
+proc ProgressDlg::cget { path option } {
+ return [Widget::cget "$path#ProgressDlg" $option]
+}
Deleted: grass/trunk/lib/external/bwidget/scrollframe.tcl
===================================================================
--- grass/trunk/lib/external/bwidget/scrollframe.tcl 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/scrollframe.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,210 +0,0 @@
-# ------------------------------------------------------------------------------
-# scrollframe.tcl
-# This file is part of Unifix BWidget Toolkit
-# $Id$
-# ------------------------------------------------------------------------------
-# Index of commands:
-# - ScrollableFrame::create
-# - ScrollableFrame::configure
-# - ScrollableFrame::cget
-# - ScrollableFrame::getframe
-# - ScrollableFrame::see
-# - ScrollableFrame::xview
-# - ScrollableFrame::yview
-# - ScrollableFrame::_resize
-# ------------------------------------------------------------------------------
-
-namespace eval ScrollableFrame {
- Widget::declare ScrollableFrame {
- {-background TkResource "" 0 frame}
- {-width Int 0 0 {}}
- {-height Int 0 0 {}}
- {-areawidth Int 0 0 {}}
- {-areaheight Int 0 0 {}}
- {-constrainedwidth Boolean 0 0}
- {-constrainedheight Boolean 0 0}
- {-xscrollcommand TkResource "" 0 canvas}
- {-yscrollcommand TkResource "" 0 canvas}
- {-xscrollincrement TkResource "" 0 canvas}
- {-yscrollincrement TkResource "" 0 canvas}
- {-bg Synonym -background}
- }
-
- Widget::addmap ScrollableFrame "" :cmd {
- -background {} -width {} -height {}
- -xscrollcommand {} -yscrollcommand {}
- -xscrollincrement {} -yscrollincrement {}
- }
- Widget::addmap ScrollableFrame "" .frame {-background {}}
-
- variable _widget
-
- bind BwScrollableFrame <Configure> {ScrollableFrame::_resize %W}
- bind BwScrollableFrame <Destroy> {Widget::destroy %W; rename %W {}}
-
- proc ::ScrollableFrame { path args } { return [eval ScrollableFrame::create $path $args] }
- proc use {} {}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ScrollableFrame::create
-# ------------------------------------------------------------------------------
-proc ScrollableFrame::create { path args } {
- Widget::init ScrollableFrame $path $args
-
- set canvas [eval canvas $path [Widget::subcget $path :cmd] \
- -highlightthickness 0 -borderwidth 0 -relief flat]
-
- set frame [eval frame $path.frame [Widget::subcget $path .frame] \
- -highlightthickness 0 -borderwidth 0 -relief flat]
-
- $canvas create window 0 0 -anchor nw -window $frame -tags win \
- -width [Widget::cget $path -areawidth] \
- -height [Widget::cget $path -areaheight]
-
- bind $frame <Configure> "$canvas:cmd configure -scrollregion {0 0 %w %h}"
- bindtags $path [list $path BwScrollableFrame [winfo toplevel $path] all]
-
- rename $path ::$path:cmd
- proc ::$path { cmd args } "return \[eval ScrollableFrame::\$cmd $path \$args\]"
-
- return $canvas
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ScrollableFrame::configure
-# ------------------------------------------------------------------------------
-proc ScrollableFrame::configure { path args } {
- set res [Widget::configure $path $args]
- set upd 0
-
- set modcw [Widget::hasChanged $path -constrainedwidth cw]
- set modw [Widget::hasChanged $path -areawidth w]
- if { $modcw || (!$cw && $modw) } {
- if { $cw } {
- set w [winfo width $path]
- }
- set upd 1
- }
-
- set modch [Widget::hasChanged $path -constrainedheight ch]
- set modh [Widget::hasChanged $path -areaheight h]
- if { $modch || (!$ch && $modh) } {
- if { $ch } {
- set h [winfo height $path]
- }
- set upd 1
- }
-
- if { $upd } {
- $path:cmd itemconfigure win -width $w -height $h
- }
- return $res
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ScrollableFrame::cget
-# ------------------------------------------------------------------------------
-proc ScrollableFrame::cget { path option } {
- return [Widget::cget $path $option]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ScrollableFrame::getframe
-# ------------------------------------------------------------------------------
-proc ScrollableFrame::getframe { path } {
- return $path.frame
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ScrollableFrame::see
-# ------------------------------------------------------------------------------
-proc ScrollableFrame::see { path widget {vert top} {horz left}} {
- set x0 [winfo x $widget]
- set y0 [winfo y $widget]
- set x1 [expr {$x0+[winfo width $widget]}]
- set y1 [expr {$y0+[winfo height $widget]}]
- set xb0 [$path:cmd canvasx 0]
- set yb0 [$path:cmd canvasy 0]
- set xb1 [$path:cmd canvasx [winfo width $path]]
- set yb1 [$path:cmd canvasy [winfo height $path]]
- set dx 0
- set dy 0
-
- if { ![string compare $horz "left"] } {
- if { $x1 > $xb1 } {
- set dx [expr {$x1-$xb1}]
- }
- if { $x0 < $xb0+$dx } {
- set dx [expr {$x0-$xb0}]
- }
- } elseif { ![string compare $horz "right"] } {
- if { $x0 < $xb0 } {
- set dx [expr {$x0-$xb0}]
- }
- if { $x1 > $xb1+$dx } {
- set dx [expr {$x1-$xb1}]
- }
- }
-
- if { ![string compare $vert "top"] } {
- if { $y1 > $yb1 } {
- set dy [expr {$y1-$yb1}]
- }
- if { $y0 < $yb0+$dy } {
- set dy [expr {$y0-$yb0}]
- }
- } elseif { ![string compare $vert "bottom"] } {
- if { $y0 < $yb0 } {
- set dy [expr {$y0-$yb0}]
- }
- if { $y1 > $yb1+$dy } {
- set dy [expr {$y1-$yb1}]
- }
- }
-
- if { $dx != 0 } {
- set x [expr {($xb0+$dx)/[winfo width $path.frame]}]
- $path:cmd xview moveto $x
- }
- if { $dy != 0 } {
- set y [expr {($yb0+$dy)/[winfo height $path.frame]}]
- $path:cmd yview moveto $y
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ScrollableFrame::xview
-# ------------------------------------------------------------------------------
-proc ScrollableFrame::xview { path args } {
- return [eval $path:cmd xview $args]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ScrollableFrame::yview
-# ------------------------------------------------------------------------------
-proc ScrollableFrame::yview { path args } {
- return [eval $path:cmd yview $args]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ScrollableFrame::_resize
-# ------------------------------------------------------------------------------
-proc ScrollableFrame::_resize { path } {
- if { [Widget::getoption $path -constrainedwidth] } {
- $path:cmd itemconfigure win -width [winfo width $path]
- }
- if { [Widget::getoption $path -constrainedheight] } {
- $path:cmd itemconfigure win -height [winfo height $path]
- }
-}
-
-
Copied: grass/trunk/lib/external/bwidget/scrollframe.tcl (from rev 35192, grass/trunk/lib/external/bwidget/scrollframe.tcl)
===================================================================
--- grass/trunk/lib/external/bwidget/scrollframe.tcl (rev 0)
+++ grass/trunk/lib/external/bwidget/scrollframe.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,210 @@
+# ------------------------------------------------------------------------------
+# scrollframe.tcl
+# This file is part of Unifix BWidget Toolkit
+# $Id$
+# ------------------------------------------------------------------------------
+# Index of commands:
+# - ScrollableFrame::create
+# - ScrollableFrame::configure
+# - ScrollableFrame::cget
+# - ScrollableFrame::getframe
+# - ScrollableFrame::see
+# - ScrollableFrame::xview
+# - ScrollableFrame::yview
+# - ScrollableFrame::_resize
+# ------------------------------------------------------------------------------
+
+namespace eval ScrollableFrame {
+ Widget::declare ScrollableFrame {
+ {-background TkResource "" 0 frame}
+ {-width Int 0 0 {}}
+ {-height Int 0 0 {}}
+ {-areawidth Int 0 0 {}}
+ {-areaheight Int 0 0 {}}
+ {-constrainedwidth Boolean 0 0}
+ {-constrainedheight Boolean 0 0}
+ {-xscrollcommand TkResource "" 0 canvas}
+ {-yscrollcommand TkResource "" 0 canvas}
+ {-xscrollincrement TkResource "" 0 canvas}
+ {-yscrollincrement TkResource "" 0 canvas}
+ {-bg Synonym -background}
+ }
+
+ Widget::addmap ScrollableFrame "" :cmd {
+ -background {} -width {} -height {}
+ -xscrollcommand {} -yscrollcommand {}
+ -xscrollincrement {} -yscrollincrement {}
+ }
+ Widget::addmap ScrollableFrame "" .frame {-background {}}
+
+ variable _widget
+
+ bind BwScrollableFrame <Configure> {ScrollableFrame::_resize %W}
+ bind BwScrollableFrame <Destroy> {Widget::destroy %W; rename %W {}}
+
+ proc ::ScrollableFrame { path args } { return [eval ScrollableFrame::create $path $args] }
+ proc use {} {}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ScrollableFrame::create
+# ------------------------------------------------------------------------------
+proc ScrollableFrame::create { path args } {
+ Widget::init ScrollableFrame $path $args
+
+ set canvas [eval canvas $path [Widget::subcget $path :cmd] \
+ -highlightthickness 0 -borderwidth 0 -relief flat]
+
+ set frame [eval frame $path.frame [Widget::subcget $path .frame] \
+ -highlightthickness 0 -borderwidth 0 -relief flat]
+
+ $canvas create window 0 0 -anchor nw -window $frame -tags win \
+ -width [Widget::cget $path -areawidth] \
+ -height [Widget::cget $path -areaheight]
+
+ bind $frame <Configure> "$canvas:cmd configure -scrollregion {0 0 %w %h}"
+ bindtags $path [list $path BwScrollableFrame [winfo toplevel $path] all]
+
+ rename $path ::$path:cmd
+ proc ::$path { cmd args } "return \[eval ScrollableFrame::\$cmd $path \$args\]"
+
+ return $canvas
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ScrollableFrame::configure
+# ------------------------------------------------------------------------------
+proc ScrollableFrame::configure { path args } {
+ set res [Widget::configure $path $args]
+ set upd 0
+
+ set modcw [Widget::hasChanged $path -constrainedwidth cw]
+ set modw [Widget::hasChanged $path -areawidth w]
+ if { $modcw || (!$cw && $modw) } {
+ if { $cw } {
+ set w [winfo width $path]
+ }
+ set upd 1
+ }
+
+ set modch [Widget::hasChanged $path -constrainedheight ch]
+ set modh [Widget::hasChanged $path -areaheight h]
+ if { $modch || (!$ch && $modh) } {
+ if { $ch } {
+ set h [winfo height $path]
+ }
+ set upd 1
+ }
+
+ if { $upd } {
+ $path:cmd itemconfigure win -width $w -height $h
+ }
+ return $res
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ScrollableFrame::cget
+# ------------------------------------------------------------------------------
+proc ScrollableFrame::cget { path option } {
+ return [Widget::cget $path $option]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ScrollableFrame::getframe
+# ------------------------------------------------------------------------------
+proc ScrollableFrame::getframe { path } {
+ return $path.frame
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ScrollableFrame::see
+# ------------------------------------------------------------------------------
+proc ScrollableFrame::see { path widget {vert top} {horz left}} {
+ set x0 [winfo x $widget]
+ set y0 [winfo y $widget]
+ set x1 [expr {$x0+[winfo width $widget]}]
+ set y1 [expr {$y0+[winfo height $widget]}]
+ set xb0 [$path:cmd canvasx 0]
+ set yb0 [$path:cmd canvasy 0]
+ set xb1 [$path:cmd canvasx [winfo width $path]]
+ set yb1 [$path:cmd canvasy [winfo height $path]]
+ set dx 0
+ set dy 0
+
+ if { ![string compare $horz "left"] } {
+ if { $x1 > $xb1 } {
+ set dx [expr {$x1-$xb1}]
+ }
+ if { $x0 < $xb0+$dx } {
+ set dx [expr {$x0-$xb0}]
+ }
+ } elseif { ![string compare $horz "right"] } {
+ if { $x0 < $xb0 } {
+ set dx [expr {$x0-$xb0}]
+ }
+ if { $x1 > $xb1+$dx } {
+ set dx [expr {$x1-$xb1}]
+ }
+ }
+
+ if { ![string compare $vert "top"] } {
+ if { $y1 > $yb1 } {
+ set dy [expr {$y1-$yb1}]
+ }
+ if { $y0 < $yb0+$dy } {
+ set dy [expr {$y0-$yb0}]
+ }
+ } elseif { ![string compare $vert "bottom"] } {
+ if { $y0 < $yb0 } {
+ set dy [expr {$y0-$yb0}]
+ }
+ if { $y1 > $yb1+$dy } {
+ set dy [expr {$y1-$yb1}]
+ }
+ }
+
+ if { $dx != 0 } {
+ set x [expr {($xb0+$dx)/[winfo width $path.frame]}]
+ $path:cmd xview moveto $x
+ }
+ if { $dy != 0 } {
+ set y [expr {($yb0+$dy)/[winfo height $path.frame]}]
+ $path:cmd yview moveto $y
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ScrollableFrame::xview
+# ------------------------------------------------------------------------------
+proc ScrollableFrame::xview { path args } {
+ return [eval $path:cmd xview $args]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ScrollableFrame::yview
+# ------------------------------------------------------------------------------
+proc ScrollableFrame::yview { path args } {
+ return [eval $path:cmd yview $args]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ScrollableFrame::_resize
+# ------------------------------------------------------------------------------
+proc ScrollableFrame::_resize { path } {
+ if { [Widget::getoption $path -constrainedwidth] } {
+ $path:cmd itemconfigure win -width [winfo width $path]
+ }
+ if { [Widget::getoption $path -constrainedheight] } {
+ $path:cmd itemconfigure win -height [winfo height $path]
+ }
+}
+
+
Deleted: grass/trunk/lib/external/bwidget/scrollview.tcl
===================================================================
--- grass/trunk/lib/external/bwidget/scrollview.tcl 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/scrollview.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,257 +0,0 @@
-# ------------------------------------------------------------------------------
-# scrollview.tcl
-# This file is part of Unifix BWidget Toolkit
-# $Id$
-# ------------------------------------------------------------------------------
-# Index of commands:
-# - ScrolledWindow::create
-# - ScrolledWindow::configure
-# - ScrolledWindow::cget
-# - ScrolledWindow::_set_hscroll
-# - ScrolledWindow::_set_vscroll
-# - ScrolledWindow::_update_scroll
-# - ScrolledWindow::_set_view
-# - ScrolledWindow::_resize
-# ------------------------------------------------------------------------------
-
-namespace eval ScrollView {
- Widget::declare ScrollView {
- {-width TkResource 30 0 canvas}
- {-height TkResource 30 0 canvas}
- {-background TkResource "" 0 canvas}
- {-foreground String black 0}
- {-fill String "" 0}
- {-relief TkResource flat 0 canvas}
- {-borderwidth TkResource 0 0 canvas}
- {-cursor TkResource crosshair 0 canvas}
- {-window String "" 0}
- {-fg Synonym -foreground}
- {-bg Synonym -background}
- {-bd Synonym -borderwidth}
- }
-
- Widget::addmap ScrollView "" :cmd \
- {-relief {} -borderwidth {} -background {} -width {} -height {} -cursor {}}
-
- bind BwScrollView <ButtonPress-3> {ScrollView::_set_view %W set %x %y}
- bind BwScrollView <ButtonPress-1> {ScrollView::_set_view %W start %x %y}
- bind BwScrollView <B1-Motion> {ScrollView::_set_view %W motion %x %y}
- bind BwScrollView <Configure> {ScrollView::_resize %W}
- bind BwScrollView <Destroy> {ScrollView::_destroy %W}
-
- proc ::ScrollView { path args } { return [eval ScrollView::create $path $args] }
- proc use {} {}
-
- variable _widget
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ScrollView::create
-# ------------------------------------------------------------------------------
-proc ScrollView::create { path args } {
- variable _widget
-
- Widget::init ScrollView $path $args
-
- set w [Widget::getoption $path -window]
- set _widget($path,bd) [Widget::getoption $path -borderwidth]
- set _widget($path,width) [Widget::getoption $path -width]
- set _widget($path,height) [Widget::getoption $path -height]
-
- if { [winfo exists $w] } {
- set _widget($path,oldxscroll) [$w cget -xscrollcommand]
- set _widget($path,oldyscroll) [$w cget -yscrollcommand]
- $w configure \
- -xscrollcommand "ScrollView::_set_hscroll $path" \
- -yscrollcommand "ScrollView::_set_vscroll $path"
- }
- eval canvas $path [Widget::subcget $path :cmd] -highlightthickness 0
- $path create rectangle -2 -2 -2 -2 \
- -fill [Widget::getoption $path -fill] \
- -outline [Widget::getoption $path -foreground] \
- -tags view
-
- bindtags $path [list $path BwScrollView [winfo toplevel $path] all]
-
- rename $path ::$path:cmd
- proc ::$path { cmd args } "return \[eval ScrollView::\$cmd $path \$args\]"
-
- return $path
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ScrollView::configure
-# ------------------------------------------------------------------------------
-proc ScrollView::configure { path args } {
- variable _widget
-
- set oldw [Widget::getoption $path -window]
- set res [Widget::configure $path $args]
-
- if { [Widget::hasChanged $path -window w] } {
- if { [winfo exists $oldw] } {
- $oldw configure \
- -xscrollcommand $_widget($path,oldxscroll) \
- -yscrollcommand $_widget($path,oldyscroll)
- }
- if { [winfo exists $w] } {
- set _widget($path,oldxscroll) [$w cget -xscrollcommand]
- set _widget($path,oldyscroll) [$w cget -yscrollcommand]
- $w configure \
- -xscrollcommand "ScrollView::_set_hscroll $path" \
- -yscrollcommand "ScrollView::_set_vscroll $path"
- } else {
- $path:cmd coords view -2 -2 -2 -2
- set _widget($path,oldxscroll) {}
- set _widget($path,oldyscroll) {}
- }
- }
-
- if { [Widget::hasChanged $path -fill fill] |
- [Widget::hasChanged $path -foreground fg] } {
- $path:cmd itemconfigure view \
- -fill $fill \
- -outline $fg
- }
-
- return $res
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ScrollView::cget
-# ------------------------------------------------------------------------------
-proc ScrollView::cget { path option } {
- return [Widget::cget $path $option]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ScrollView::_destroy
-# ------------------------------------------------------------------------------
-proc ScrollView::_destroy { path } {
- variable _widget
-
- set w [Widget::getoption $path -window]
- if { [winfo exists $w] } {
- $w configure \
- -xscrollcommand $_widget($path,oldxscroll) \
- -yscrollcommand $_widget($path,oldyscroll)
- }
- unset _widget($path,oldxscroll)
- unset _widget($path,oldyscroll)
- unset _widget($path,bd)
- unset _widget($path,width)
- unset _widget($path,height)
- catch {unset _widget($path,dx)}
- catch {unset _widget($path,dy)}
- Widget::destroy $path
- rename $path {}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ScrollView::_set_hscroll
-# ------------------------------------------------------------------------------
-proc ScrollView::_set_hscroll { path vmin vmax } {
- variable _widget
-
- set c [$path:cmd coords view]
- set x0 [expr {$vmin*$_widget($path,width)+$_widget($path,bd)}]
- set x1 [expr {$vmax*$_widget($path,width)+$_widget($path,bd)-1}]
- $path:cmd coords view $x0 [lindex $c 1] $x1 [lindex $c 3]
- if { $_widget($path,oldxscroll) != "" } {
- uplevel \#0 $_widget($path,oldxscroll) $vmin $vmax
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ScrollView::_set_vscroll
-# ------------------------------------------------------------------------------
-proc ScrollView::_set_vscroll { path vmin vmax } {
- variable _widget
-
- set c [$path:cmd coords view]
- set y0 [expr {$vmin*$_widget($path,height)+$_widget($path,bd)}]
- set y1 [expr {$vmax*$_widget($path,height)+$_widget($path,bd)-1}]
- $path:cmd coords view [lindex $c 0] $y0 [lindex $c 2] $y1
- if { $_widget($path,oldyscroll) != "" } {
- uplevel \#0 $_widget($path,oldyscroll) $vmin $vmax
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ScrollView::_update_scroll
-# ------------------------------------------------------------------------------
-proc ScrollView::_update_scroll { path callscroll hminmax vminmax } {
- variable _widget
-
- set c [$path:cmd coords view]
- set hmin [lindex $hminmax 0]
- set hmax [lindex $hminmax 1]
- set vmin [lindex $vminmax 0]
- set vmax [lindex $vminmax 1]
- set x0 [expr {$hmin*$_widget($path,width)+$_widget($path,bd)}]
- set x1 [expr {$hmax*$_widget($path,width)+$_widget($path,bd)-1}]
- set y0 [expr {$vmin*$_widget($path,height)+$_widget($path,bd)}]
- set y1 [expr {$vmax*$_widget($path,height)+$_widget($path,bd)-1}]
- $path:cmd coords view $x0 $y0 $x1 $y1
- if { $callscroll } {
- if { $_widget($path,oldxscroll) != "" } {
- uplevel \#0 $_widget($path,oldxscroll) $hmin $hmax
- }
- if { $_widget($path,oldyscroll) != "" } {
- uplevel \#0 $_widget($path,oldyscroll) $vmin $vmax
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ScrollView::_set_view
-# ------------------------------------------------------------------------------
-proc ScrollView::_set_view { path cmd x y } {
- variable _widget
-
- set w [Widget::getoption $path -window]
- if { [winfo exists $w] } {
- if { ![string compare $cmd "start"] } {
- set c [$path:cmd coords view]
- set x0 [lindex $c 0]
- set y0 [lindex $c 1]
- set _widget($path,dx) [expr {$x-$x0}]
- set _widget($path,dy) [expr {$y-$y0}]
- } else {
- if { ![string compare $cmd "motion"] } {
- set vh [expr {double($x-$_widget($path,dx)-$_widget($path,bd))/$_widget($path,width)}]
- set vv [expr {double($y-$_widget($path,dy)-$_widget($path,bd))/$_widget($path,height)}]
- } else {
- set vh [expr {double($x-$_widget($path,bd))/$_widget($path,width)}]
- set vv [expr {double($y-$_widget($path,bd))/$_widget($path,height)}]
- }
- $w xview moveto $vh
- $w yview moveto $vv
- _update_scroll $path 1 [$w xview] [$w yview]
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ScrollView::_resize
-# ------------------------------------------------------------------------------
-proc ScrollView::_resize { path } {
- variable _widget
-
- set _widget($path,bd) [Widget::getoption $path -borderwidth]
- set _widget($path,width) [expr {[winfo width $path]-2*$_widget($path,bd)}]
- set _widget($path,height) [expr {[winfo height $path]-2*$_widget($path,bd)}]
- set w [Widget::getoption $path -window]
- if { [winfo exists $w] } {
- _update_scroll $path 0 [$w xview] [$w yview]
- }
-}
Copied: grass/trunk/lib/external/bwidget/scrollview.tcl (from rev 35192, grass/trunk/lib/external/bwidget/scrollview.tcl)
===================================================================
--- grass/trunk/lib/external/bwidget/scrollview.tcl (rev 0)
+++ grass/trunk/lib/external/bwidget/scrollview.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,257 @@
+# ------------------------------------------------------------------------------
+# scrollview.tcl
+# This file is part of Unifix BWidget Toolkit
+# $Id$
+# ------------------------------------------------------------------------------
+# Index of commands:
+# - ScrolledWindow::create
+# - ScrolledWindow::configure
+# - ScrolledWindow::cget
+# - ScrolledWindow::_set_hscroll
+# - ScrolledWindow::_set_vscroll
+# - ScrolledWindow::_update_scroll
+# - ScrolledWindow::_set_view
+# - ScrolledWindow::_resize
+# ------------------------------------------------------------------------------
+
+namespace eval ScrollView {
+ Widget::declare ScrollView {
+ {-width TkResource 30 0 canvas}
+ {-height TkResource 30 0 canvas}
+ {-background TkResource "" 0 canvas}
+ {-foreground String black 0}
+ {-fill String "" 0}
+ {-relief TkResource flat 0 canvas}
+ {-borderwidth TkResource 0 0 canvas}
+ {-cursor TkResource crosshair 0 canvas}
+ {-window String "" 0}
+ {-fg Synonym -foreground}
+ {-bg Synonym -background}
+ {-bd Synonym -borderwidth}
+ }
+
+ Widget::addmap ScrollView "" :cmd \
+ {-relief {} -borderwidth {} -background {} -width {} -height {} -cursor {}}
+
+ bind BwScrollView <ButtonPress-3> {ScrollView::_set_view %W set %x %y}
+ bind BwScrollView <ButtonPress-1> {ScrollView::_set_view %W start %x %y}
+ bind BwScrollView <B1-Motion> {ScrollView::_set_view %W motion %x %y}
+ bind BwScrollView <Configure> {ScrollView::_resize %W}
+ bind BwScrollView <Destroy> {ScrollView::_destroy %W}
+
+ proc ::ScrollView { path args } { return [eval ScrollView::create $path $args] }
+ proc use {} {}
+
+ variable _widget
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ScrollView::create
+# ------------------------------------------------------------------------------
+proc ScrollView::create { path args } {
+ variable _widget
+
+ Widget::init ScrollView $path $args
+
+ set w [Widget::getoption $path -window]
+ set _widget($path,bd) [Widget::getoption $path -borderwidth]
+ set _widget($path,width) [Widget::getoption $path -width]
+ set _widget($path,height) [Widget::getoption $path -height]
+
+ if { [winfo exists $w] } {
+ set _widget($path,oldxscroll) [$w cget -xscrollcommand]
+ set _widget($path,oldyscroll) [$w cget -yscrollcommand]
+ $w configure \
+ -xscrollcommand "ScrollView::_set_hscroll $path" \
+ -yscrollcommand "ScrollView::_set_vscroll $path"
+ }
+ eval canvas $path [Widget::subcget $path :cmd] -highlightthickness 0
+ $path create rectangle -2 -2 -2 -2 \
+ -fill [Widget::getoption $path -fill] \
+ -outline [Widget::getoption $path -foreground] \
+ -tags view
+
+ bindtags $path [list $path BwScrollView [winfo toplevel $path] all]
+
+ rename $path ::$path:cmd
+ proc ::$path { cmd args } "return \[eval ScrollView::\$cmd $path \$args\]"
+
+ return $path
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ScrollView::configure
+# ------------------------------------------------------------------------------
+proc ScrollView::configure { path args } {
+ variable _widget
+
+ set oldw [Widget::getoption $path -window]
+ set res [Widget::configure $path $args]
+
+ if { [Widget::hasChanged $path -window w] } {
+ if { [winfo exists $oldw] } {
+ $oldw configure \
+ -xscrollcommand $_widget($path,oldxscroll) \
+ -yscrollcommand $_widget($path,oldyscroll)
+ }
+ if { [winfo exists $w] } {
+ set _widget($path,oldxscroll) [$w cget -xscrollcommand]
+ set _widget($path,oldyscroll) [$w cget -yscrollcommand]
+ $w configure \
+ -xscrollcommand "ScrollView::_set_hscroll $path" \
+ -yscrollcommand "ScrollView::_set_vscroll $path"
+ } else {
+ $path:cmd coords view -2 -2 -2 -2
+ set _widget($path,oldxscroll) {}
+ set _widget($path,oldyscroll) {}
+ }
+ }
+
+ if { [Widget::hasChanged $path -fill fill] |
+ [Widget::hasChanged $path -foreground fg] } {
+ $path:cmd itemconfigure view \
+ -fill $fill \
+ -outline $fg
+ }
+
+ return $res
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ScrollView::cget
+# ------------------------------------------------------------------------------
+proc ScrollView::cget { path option } {
+ return [Widget::cget $path $option]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ScrollView::_destroy
+# ------------------------------------------------------------------------------
+proc ScrollView::_destroy { path } {
+ variable _widget
+
+ set w [Widget::getoption $path -window]
+ if { [winfo exists $w] } {
+ $w configure \
+ -xscrollcommand $_widget($path,oldxscroll) \
+ -yscrollcommand $_widget($path,oldyscroll)
+ }
+ unset _widget($path,oldxscroll)
+ unset _widget($path,oldyscroll)
+ unset _widget($path,bd)
+ unset _widget($path,width)
+ unset _widget($path,height)
+ catch {unset _widget($path,dx)}
+ catch {unset _widget($path,dy)}
+ Widget::destroy $path
+ rename $path {}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ScrollView::_set_hscroll
+# ------------------------------------------------------------------------------
+proc ScrollView::_set_hscroll { path vmin vmax } {
+ variable _widget
+
+ set c [$path:cmd coords view]
+ set x0 [expr {$vmin*$_widget($path,width)+$_widget($path,bd)}]
+ set x1 [expr {$vmax*$_widget($path,width)+$_widget($path,bd)-1}]
+ $path:cmd coords view $x0 [lindex $c 1] $x1 [lindex $c 3]
+ if { $_widget($path,oldxscroll) != "" } {
+ uplevel \#0 $_widget($path,oldxscroll) $vmin $vmax
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ScrollView::_set_vscroll
+# ------------------------------------------------------------------------------
+proc ScrollView::_set_vscroll { path vmin vmax } {
+ variable _widget
+
+ set c [$path:cmd coords view]
+ set y0 [expr {$vmin*$_widget($path,height)+$_widget($path,bd)}]
+ set y1 [expr {$vmax*$_widget($path,height)+$_widget($path,bd)-1}]
+ $path:cmd coords view [lindex $c 0] $y0 [lindex $c 2] $y1
+ if { $_widget($path,oldyscroll) != "" } {
+ uplevel \#0 $_widget($path,oldyscroll) $vmin $vmax
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ScrollView::_update_scroll
+# ------------------------------------------------------------------------------
+proc ScrollView::_update_scroll { path callscroll hminmax vminmax } {
+ variable _widget
+
+ set c [$path:cmd coords view]
+ set hmin [lindex $hminmax 0]
+ set hmax [lindex $hminmax 1]
+ set vmin [lindex $vminmax 0]
+ set vmax [lindex $vminmax 1]
+ set x0 [expr {$hmin*$_widget($path,width)+$_widget($path,bd)}]
+ set x1 [expr {$hmax*$_widget($path,width)+$_widget($path,bd)-1}]
+ set y0 [expr {$vmin*$_widget($path,height)+$_widget($path,bd)}]
+ set y1 [expr {$vmax*$_widget($path,height)+$_widget($path,bd)-1}]
+ $path:cmd coords view $x0 $y0 $x1 $y1
+ if { $callscroll } {
+ if { $_widget($path,oldxscroll) != "" } {
+ uplevel \#0 $_widget($path,oldxscroll) $hmin $hmax
+ }
+ if { $_widget($path,oldyscroll) != "" } {
+ uplevel \#0 $_widget($path,oldyscroll) $vmin $vmax
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ScrollView::_set_view
+# ------------------------------------------------------------------------------
+proc ScrollView::_set_view { path cmd x y } {
+ variable _widget
+
+ set w [Widget::getoption $path -window]
+ if { [winfo exists $w] } {
+ if { ![string compare $cmd "start"] } {
+ set c [$path:cmd coords view]
+ set x0 [lindex $c 0]
+ set y0 [lindex $c 1]
+ set _widget($path,dx) [expr {$x-$x0}]
+ set _widget($path,dy) [expr {$y-$y0}]
+ } else {
+ if { ![string compare $cmd "motion"] } {
+ set vh [expr {double($x-$_widget($path,dx)-$_widget($path,bd))/$_widget($path,width)}]
+ set vv [expr {double($y-$_widget($path,dy)-$_widget($path,bd))/$_widget($path,height)}]
+ } else {
+ set vh [expr {double($x-$_widget($path,bd))/$_widget($path,width)}]
+ set vv [expr {double($y-$_widget($path,bd))/$_widget($path,height)}]
+ }
+ $w xview moveto $vh
+ $w yview moveto $vv
+ _update_scroll $path 1 [$w xview] [$w yview]
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ScrollView::_resize
+# ------------------------------------------------------------------------------
+proc ScrollView::_resize { path } {
+ variable _widget
+
+ set _widget($path,bd) [Widget::getoption $path -borderwidth]
+ set _widget($path,width) [expr {[winfo width $path]-2*$_widget($path,bd)}]
+ set _widget($path,height) [expr {[winfo height $path]-2*$_widget($path,bd)}]
+ set w [Widget::getoption $path -window]
+ if { [winfo exists $w] } {
+ _update_scroll $path 0 [$w xview] [$w yview]
+ }
+}
Deleted: grass/trunk/lib/external/bwidget/scrollw.tcl
===================================================================
--- grass/trunk/lib/external/bwidget/scrollw.tcl 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/scrollw.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,254 +0,0 @@
-# ------------------------------------------------------------------------------
-# scrollw.tcl
-# This file is part of Unifix BWidget Toolkit
-# $Id$
-# ------------------------------------------------------------------------------
-# Index of commands:
-# - ScrolledWindow::create
-# - ScrolledWindow::getframe
-# - ScrolledWindow::setwidget
-# - ScrolledWindow::configure
-# - ScrolledWindow::cget
-# - ScrolledWindow::_set_hscroll
-# - ScrolledWindow::_set_vscroll
-# - ScrolledWindow::_realize
-# ------------------------------------------------------------------------------
-
-namespace eval ScrolledWindow {
- Widget::declare ScrolledWindow {
- {-background TkResource "" 0 button}
- {-scrollbar Enum both 1 {none both vertical horizontal}}
- {-auto Enum both 0 {none both vertical horizontal}}
- {-relief TkResource flat 0 frame}
- {-borderwidth TkResource 0 0 frame}
- {-bg Synonym -background}
- {-bd Synonym -borderwidth}
- }
-
- Widget::addmap ScrolledWindow "" ._grid.f {-relief {} -borderwidth {}}
-
- proc ::ScrolledWindow { path args } { return [eval ScrolledWindow::create $path $args] }
- proc use {} {}
-
- variable _widget
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ScrolledWindow::create
-# ------------------------------------------------------------------------------
-proc ScrolledWindow::create { path args } {
- variable _widget
-
- Widget::init ScrolledWindow $path $args
-
- set bg [Widget::cget $path -background]
- set sw [frame $path -relief flat -bd 0 -bg $bg -highlightthickness 0 -takefocus 0]
- set grid [frame $path._grid -relief flat -bd 0 -bg $bg -highlightthickness 0 -takefocus 0]
-
- set sb [lsearch {none horizontal vertical both} [Widget::cget $path -scrollbar]]
- set auto [lsearch {none horizontal vertical both} [Widget::cget $path -auto]]
- set rspan [expr {1 + !($sb & 1)}]
- set cspan [expr {1 + !($sb & 2)}]
-
- set _widget($path,realized) 0
- set _widget($path,sb) $sb
- set _widget($path,auto) $auto
- set _widget($path,hpack) [expr {$rspan == 1}]
- set _widget($path,vpack) [expr {$cspan == 1}]
-
- # scrollbar horizontale ou les deux
- if { $sb & 1 } {
- scrollbar $grid.hscroll \
- -highlightthickness 0 -takefocus 0 \
- -orient horiz \
- -relief sunken \
- -bg $bg
- $grid.hscroll set 0 1
- grid $grid.hscroll -column 0 -row 1 -sticky we -columnspan $cspan -pady 1
- }
-
- # scrollbar verticale ou les deux
- if { $sb & 2 } {
- scrollbar $grid.vscroll \
- -highlightthickness 0 -takefocus 0 \
- -orient vert \
- -relief sunken \
- -bg $bg
- $grid.vscroll set 0 1
- grid $grid.vscroll -column 1 -row 0 -sticky ns -rowspan $rspan -padx 1
- }
-
- eval frame $grid.f -bg $bg -highlightthickness 0 [Widget::subcget $path ._grid.f]
- grid $grid.f -column 0 -row 0 -sticky nwse -columnspan $cspan -rowspan $rspan
- grid columnconfigure $grid 0 -weight 1
- grid rowconfigure $grid 0 -weight 1
- pack $grid -fill both -expand yes
-
- bind $grid <Configure> "ScrolledWindow::_realize $path"
- bind $grid <Destroy> "ScrolledWindow::_destroy $path"
-
- rename $path ::$path:cmd
- proc ::$path { cmd args } "return \[eval ScrolledWindow::\$cmd $path \$args\]"
-
- return $path
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ScrolledWindow::getframe
-# ------------------------------------------------------------------------------
-proc ScrolledWindow::getframe { path } {
- return $path
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ScrolledWindow::setwidget
-# ------------------------------------------------------------------------------
-proc ScrolledWindow::setwidget { path widget } {
- variable _widget
-
- set grid $path._grid
- set sb $_widget($path,sb)
- set option {}
-
- pack $widget -in $grid.f -fill both -expand yes
-
- # scrollbar horizontale ou les deux
- if { $sb & 1 } {
- $grid.hscroll configure -command "$widget xview"
- lappend option "-xscrollcommand" "ScrolledWindow::_set_hscroll $path"
- }
-
- # scrollbar verticale ou les deux
- if { $sb & 2 } {
- $grid.vscroll configure -command "$widget yview"
- lappend option "-yscrollcommand" "ScrolledWindow::_set_vscroll $path"
- }
- if { [llength $option] } {
- eval $widget configure $option
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ScrolledWindow::configure
-# ------------------------------------------------------------------------------
-proc ScrolledWindow::configure { path args } {
- variable _widget
-
- set grid $path._grid
- set res [Widget::configure $path $args]
- if { [Widget::hasChanged $path -background bg] } {
- $path configure -background $bg
- $grid configure -background $bg
- $grid.f configure -background $bg
- catch {$grid.hscroll configure -background $bg}
- catch {$grid.vscroll configure -background $bg}
- }
- if { [Widget::hasChanged $path -auto auto] } {
- set _widget($path,auto) [lsearch {none horizontal vertical both} $auto]
- if { $_widget($path,sb) & 1 } {
- eval _set_hscroll $path [$grid.hscroll get]
- }
- if { $_widget($path,sb) & 2 } {
- eval _set_vscroll $path [$grid.vscroll get]
- }
- }
- return $res
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ScrolledWindow::cget
-# ------------------------------------------------------------------------------
-proc ScrolledWindow::cget { path option } {
- return [Widget::cget $path $option]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ScrolledWindow::_destroy
-# ------------------------------------------------------------------------------
-proc ScrolledWindow::_destroy { path } {
- variable _widget
-
- unset _widget($path,sb)
- unset _widget($path,auto)
- unset _widget($path,hpack)
- unset _widget($path,vpack)
- Widget::destroy $path
- rename $path {}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ScrolledWindow::_set_hscroll
-# ------------------------------------------------------------------------------
-proc ScrolledWindow::_set_hscroll { path vmin vmax } {
- variable _widget
-
- if { $_widget($path,realized) } {
- set grid $path._grid
- if { $_widget($path,auto) & 1 } {
- if { $_widget($path,hpack) && $vmin == 0 && $vmax == 1 } {
- grid configure $grid.f -rowspan 2
- if { $_widget($path,sb) & 2 } {
- grid configure $grid.vscroll -rowspan 2
- }
- set _widget($path,hpack) 0
- } elseif { !$_widget($path,hpack) && ($vmin != 0 || $vmax != 1) } {
- grid configure $grid.f -rowspan 1
- if { $_widget($path,sb) & 2 } {
- grid configure $grid.vscroll -rowspan 1
- }
- set _widget($path,hpack) 1
- }
- }
- $grid.hscroll set $vmin $vmax
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ScrolledWindow::_set_vscroll
-# ------------------------------------------------------------------------------
-proc ScrolledWindow::_set_vscroll { path vmin vmax } {
- variable _widget
-
- if { $_widget($path,realized) } {
- set grid $path._grid
- if { $_widget($path,auto) & 2 } {
- if { $_widget($path,vpack) && $vmin == 0 && $vmax == 1 } {
- grid configure $grid.f -columnspan 2
- if { $_widget($path,sb) & 1 } {
- grid configure $grid.hscroll -columnspan 2
- }
- set _widget($path,vpack) 0
- } elseif { !$_widget($path,vpack) && ($vmin != 0 || $vmax != 1) } {
- grid configure $grid.f -columnspan 1
- if { $_widget($path,sb) & 1 } {
- grid configure $grid.hscroll -columnspan 1
- }
- set _widget($path,vpack) 1
- }
- }
- $grid.vscroll set $vmin $vmax
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command ScrolledWindow::_realize
-# ------------------------------------------------------------------------------
-proc ScrolledWindow::_realize { path } {
- variable _widget
-
- set grid $path._grid
- bind $grid <Configure> {}
- set _widget($path,realized) 1
- place $grid -anchor nw -x 0 -y 0 -relwidth 1.0 -relheight 1.0
-}
-
-
Copied: grass/trunk/lib/external/bwidget/scrollw.tcl (from rev 35192, grass/trunk/lib/external/bwidget/scrollw.tcl)
===================================================================
--- grass/trunk/lib/external/bwidget/scrollw.tcl (rev 0)
+++ grass/trunk/lib/external/bwidget/scrollw.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,254 @@
+# ------------------------------------------------------------------------------
+# scrollw.tcl
+# This file is part of Unifix BWidget Toolkit
+# $Id$
+# ------------------------------------------------------------------------------
+# Index of commands:
+# - ScrolledWindow::create
+# - ScrolledWindow::getframe
+# - ScrolledWindow::setwidget
+# - ScrolledWindow::configure
+# - ScrolledWindow::cget
+# - ScrolledWindow::_set_hscroll
+# - ScrolledWindow::_set_vscroll
+# - ScrolledWindow::_realize
+# ------------------------------------------------------------------------------
+
+namespace eval ScrolledWindow {
+ Widget::declare ScrolledWindow {
+ {-background TkResource "" 0 button}
+ {-scrollbar Enum both 1 {none both vertical horizontal}}
+ {-auto Enum both 0 {none both vertical horizontal}}
+ {-relief TkResource flat 0 frame}
+ {-borderwidth TkResource 0 0 frame}
+ {-bg Synonym -background}
+ {-bd Synonym -borderwidth}
+ }
+
+ Widget::addmap ScrolledWindow "" ._grid.f {-relief {} -borderwidth {}}
+
+ proc ::ScrolledWindow { path args } { return [eval ScrolledWindow::create $path $args] }
+ proc use {} {}
+
+ variable _widget
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ScrolledWindow::create
+# ------------------------------------------------------------------------------
+proc ScrolledWindow::create { path args } {
+ variable _widget
+
+ Widget::init ScrolledWindow $path $args
+
+ set bg [Widget::cget $path -background]
+ set sw [frame $path -relief flat -bd 0 -bg $bg -highlightthickness 0 -takefocus 0]
+ set grid [frame $path._grid -relief flat -bd 0 -bg $bg -highlightthickness 0 -takefocus 0]
+
+ set sb [lsearch {none horizontal vertical both} [Widget::cget $path -scrollbar]]
+ set auto [lsearch {none horizontal vertical both} [Widget::cget $path -auto]]
+ set rspan [expr {1 + !($sb & 1)}]
+ set cspan [expr {1 + !($sb & 2)}]
+
+ set _widget($path,realized) 0
+ set _widget($path,sb) $sb
+ set _widget($path,auto) $auto
+ set _widget($path,hpack) [expr {$rspan == 1}]
+ set _widget($path,vpack) [expr {$cspan == 1}]
+
+ # scrollbar horizontale ou les deux
+ if { $sb & 1 } {
+ scrollbar $grid.hscroll \
+ -highlightthickness 0 -takefocus 0 \
+ -orient horiz \
+ -relief sunken \
+ -bg $bg
+ $grid.hscroll set 0 1
+ grid $grid.hscroll -column 0 -row 1 -sticky we -columnspan $cspan -pady 1
+ }
+
+ # scrollbar verticale ou les deux
+ if { $sb & 2 } {
+ scrollbar $grid.vscroll \
+ -highlightthickness 0 -takefocus 0 \
+ -orient vert \
+ -relief sunken \
+ -bg $bg
+ $grid.vscroll set 0 1
+ grid $grid.vscroll -column 1 -row 0 -sticky ns -rowspan $rspan -padx 1
+ }
+
+ eval frame $grid.f -bg $bg -highlightthickness 0 [Widget::subcget $path ._grid.f]
+ grid $grid.f -column 0 -row 0 -sticky nwse -columnspan $cspan -rowspan $rspan
+ grid columnconfigure $grid 0 -weight 1
+ grid rowconfigure $grid 0 -weight 1
+ pack $grid -fill both -expand yes
+
+ bind $grid <Configure> "ScrolledWindow::_realize $path"
+ bind $grid <Destroy> "ScrolledWindow::_destroy $path"
+
+ rename $path ::$path:cmd
+ proc ::$path { cmd args } "return \[eval ScrolledWindow::\$cmd $path \$args\]"
+
+ return $path
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ScrolledWindow::getframe
+# ------------------------------------------------------------------------------
+proc ScrolledWindow::getframe { path } {
+ return $path
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ScrolledWindow::setwidget
+# ------------------------------------------------------------------------------
+proc ScrolledWindow::setwidget { path widget } {
+ variable _widget
+
+ set grid $path._grid
+ set sb $_widget($path,sb)
+ set option {}
+
+ pack $widget -in $grid.f -fill both -expand yes
+
+ # scrollbar horizontale ou les deux
+ if { $sb & 1 } {
+ $grid.hscroll configure -command "$widget xview"
+ lappend option "-xscrollcommand" "ScrolledWindow::_set_hscroll $path"
+ }
+
+ # scrollbar verticale ou les deux
+ if { $sb & 2 } {
+ $grid.vscroll configure -command "$widget yview"
+ lappend option "-yscrollcommand" "ScrolledWindow::_set_vscroll $path"
+ }
+ if { [llength $option] } {
+ eval $widget configure $option
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ScrolledWindow::configure
+# ------------------------------------------------------------------------------
+proc ScrolledWindow::configure { path args } {
+ variable _widget
+
+ set grid $path._grid
+ set res [Widget::configure $path $args]
+ if { [Widget::hasChanged $path -background bg] } {
+ $path configure -background $bg
+ $grid configure -background $bg
+ $grid.f configure -background $bg
+ catch {$grid.hscroll configure -background $bg}
+ catch {$grid.vscroll configure -background $bg}
+ }
+ if { [Widget::hasChanged $path -auto auto] } {
+ set _widget($path,auto) [lsearch {none horizontal vertical both} $auto]
+ if { $_widget($path,sb) & 1 } {
+ eval _set_hscroll $path [$grid.hscroll get]
+ }
+ if { $_widget($path,sb) & 2 } {
+ eval _set_vscroll $path [$grid.vscroll get]
+ }
+ }
+ return $res
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ScrolledWindow::cget
+# ------------------------------------------------------------------------------
+proc ScrolledWindow::cget { path option } {
+ return [Widget::cget $path $option]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ScrolledWindow::_destroy
+# ------------------------------------------------------------------------------
+proc ScrolledWindow::_destroy { path } {
+ variable _widget
+
+ unset _widget($path,sb)
+ unset _widget($path,auto)
+ unset _widget($path,hpack)
+ unset _widget($path,vpack)
+ Widget::destroy $path
+ rename $path {}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ScrolledWindow::_set_hscroll
+# ------------------------------------------------------------------------------
+proc ScrolledWindow::_set_hscroll { path vmin vmax } {
+ variable _widget
+
+ if { $_widget($path,realized) } {
+ set grid $path._grid
+ if { $_widget($path,auto) & 1 } {
+ if { $_widget($path,hpack) && $vmin == 0 && $vmax == 1 } {
+ grid configure $grid.f -rowspan 2
+ if { $_widget($path,sb) & 2 } {
+ grid configure $grid.vscroll -rowspan 2
+ }
+ set _widget($path,hpack) 0
+ } elseif { !$_widget($path,hpack) && ($vmin != 0 || $vmax != 1) } {
+ grid configure $grid.f -rowspan 1
+ if { $_widget($path,sb) & 2 } {
+ grid configure $grid.vscroll -rowspan 1
+ }
+ set _widget($path,hpack) 1
+ }
+ }
+ $grid.hscroll set $vmin $vmax
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ScrolledWindow::_set_vscroll
+# ------------------------------------------------------------------------------
+proc ScrolledWindow::_set_vscroll { path vmin vmax } {
+ variable _widget
+
+ if { $_widget($path,realized) } {
+ set grid $path._grid
+ if { $_widget($path,auto) & 2 } {
+ if { $_widget($path,vpack) && $vmin == 0 && $vmax == 1 } {
+ grid configure $grid.f -columnspan 2
+ if { $_widget($path,sb) & 1 } {
+ grid configure $grid.hscroll -columnspan 2
+ }
+ set _widget($path,vpack) 0
+ } elseif { !$_widget($path,vpack) && ($vmin != 0 || $vmax != 1) } {
+ grid configure $grid.f -columnspan 1
+ if { $_widget($path,sb) & 1 } {
+ grid configure $grid.hscroll -columnspan 1
+ }
+ set _widget($path,vpack) 1
+ }
+ }
+ $grid.vscroll set $vmin $vmax
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command ScrolledWindow::_realize
+# ------------------------------------------------------------------------------
+proc ScrolledWindow::_realize { path } {
+ variable _widget
+
+ set grid $path._grid
+ bind $grid <Configure> {}
+ set _widget($path,realized) 1
+ place $grid -anchor nw -x 0 -y 0 -relwidth 1.0 -relheight 1.0
+}
+
+
Deleted: grass/trunk/lib/external/bwidget/separator.tcl
===================================================================
--- grass/trunk/lib/external/bwidget/separator.tcl 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/separator.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,82 +0,0 @@
-# ------------------------------------------------------------------------------
-# separator.tcl
-# This file is part of Unifix BWidget Toolkit
-# ------------------------------------------------------------------------------
-# Index of commands:
-# - Separator::create
-# - Separator::configure
-# - Separator::cget
-# ------------------------------------------------------------------------------
-
-namespace eval Separator {
- Widget::declare Separator {
- {-background TkResource "" 0 frame}
- {-relief Enum groove 0 {ridge groove}}
- {-orient Enum horizontal 1 {horizontal vertical}}
- {-bg Synonym -background}
- }
- Widget::addmap Separator "" :cmd {-background {}}
-
- proc ::Separator { path args } { return [eval Separator::create $path $args] }
- proc use {} {}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Separator::create
-# ------------------------------------------------------------------------------
-proc Separator::create { path args } {
- Widget::init Separator $path $args
-
- if { [Widget::getoption $path -relief] == "groove" } {
- set relief sunken
- } else {
- set relief raised
- }
-
- if { [Widget::getoption $path -orient] == "horizontal" } {
- frame $path \
- -background [Widget::getoption $path -background] \
- -borderwidth 1 \
- -relief $relief \
- -height 2
- } else {
- frame $path \
- -background [Widget::getoption $path -background] \
- -borderwidth 1 \
- -relief $relief \
- -width 2
- }
- bind $path <Destroy> {Widget::destroy %W; rename %W {}}
-
- rename $path ::$path:cmd
- proc ::$path { cmd args } "return \[eval Separator::\$cmd $path \$args\]"
-
- return $path
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Separator::configure
-# ------------------------------------------------------------------------------
-proc Separator::configure { path args } {
- set res [Widget::configure $path $args]
-
- if { [Widget::hasChanged $path -relief relief] } {
- if { $relief == "groove" } {
- $path:cmd configure -relief sunken
- } else {
- $path:cmd configure -relief raised
- }
- }
-
- return $res
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Separator::cget
-# ------------------------------------------------------------------------------
-proc Separator::cget { path option } {
- return [Widget::cget $path $option]
-}
Copied: grass/trunk/lib/external/bwidget/separator.tcl (from rev 35192, grass/trunk/lib/external/bwidget/separator.tcl)
===================================================================
--- grass/trunk/lib/external/bwidget/separator.tcl (rev 0)
+++ grass/trunk/lib/external/bwidget/separator.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,82 @@
+# ------------------------------------------------------------------------------
+# separator.tcl
+# This file is part of Unifix BWidget Toolkit
+# ------------------------------------------------------------------------------
+# Index of commands:
+# - Separator::create
+# - Separator::configure
+# - Separator::cget
+# ------------------------------------------------------------------------------
+
+namespace eval Separator {
+ Widget::declare Separator {
+ {-background TkResource "" 0 frame}
+ {-relief Enum groove 0 {ridge groove}}
+ {-orient Enum horizontal 1 {horizontal vertical}}
+ {-bg Synonym -background}
+ }
+ Widget::addmap Separator "" :cmd {-background {}}
+
+ proc ::Separator { path args } { return [eval Separator::create $path $args] }
+ proc use {} {}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Separator::create
+# ------------------------------------------------------------------------------
+proc Separator::create { path args } {
+ Widget::init Separator $path $args
+
+ if { [Widget::getoption $path -relief] == "groove" } {
+ set relief sunken
+ } else {
+ set relief raised
+ }
+
+ if { [Widget::getoption $path -orient] == "horizontal" } {
+ frame $path \
+ -background [Widget::getoption $path -background] \
+ -borderwidth 1 \
+ -relief $relief \
+ -height 2
+ } else {
+ frame $path \
+ -background [Widget::getoption $path -background] \
+ -borderwidth 1 \
+ -relief $relief \
+ -width 2
+ }
+ bind $path <Destroy> {Widget::destroy %W; rename %W {}}
+
+ rename $path ::$path:cmd
+ proc ::$path { cmd args } "return \[eval Separator::\$cmd $path \$args\]"
+
+ return $path
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Separator::configure
+# ------------------------------------------------------------------------------
+proc Separator::configure { path args } {
+ set res [Widget::configure $path $args]
+
+ if { [Widget::hasChanged $path -relief relief] } {
+ if { $relief == "groove" } {
+ $path:cmd configure -relief sunken
+ } else {
+ $path:cmd configure -relief raised
+ }
+ }
+
+ return $res
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Separator::cget
+# ------------------------------------------------------------------------------
+proc Separator::cget { path option } {
+ return [Widget::cget $path $option]
+}
Deleted: grass/trunk/lib/external/bwidget/spinbox.tcl
===================================================================
--- grass/trunk/lib/external/bwidget/spinbox.tcl 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/spinbox.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,353 +0,0 @@
-# ------------------------------------------------------------------------------
-# spinbox.tcl
-# This file is part of Unifix BWidget Toolkit
-# ------------------------------------------------------------------------------
-# Index of commands:
-# - SpinBox::create
-# - SpinBox::configure
-# - SpinBox::cget
-# - SpinBox::setvalue
-# - SpinBox::_destroy
-# - SpinBox::_modify_value
-# - SpinBox::_test_options
-# ------------------------------------------------------------------------------
-
-namespace eval SpinBox {
- ArrowButton::use
- Entry::use
- LabelFrame::use
-
- Widget::bwinclude SpinBox LabelFrame .labf \
- rename {-text -label} \
- prefix {label -justify -width -anchor -height -font} \
- remove {-focus} \
- initialize {-relief sunken -borderwidth 2}
-
- Widget::bwinclude SpinBox Entry .e \
- remove {-relief -bd -borderwidth -fg -bg} \
- rename {-foreground -entryfg -background -entrybg}
-
- Widget::declare SpinBox {
- {-range String "" 0}
- {-values String "" 0}
- {-modifycmd String "" 0}
- {-repeatdelay Int 400 0 {=0}}
- {-repeatinterval Int 100 0 {=0}}
- }
-
- Widget::addmap SpinBox "" :cmd {-background {}}
- Widget::addmap SpinBox ArrowButton .arrup {
- -foreground {} -background {} -disabledforeground {} -state {}
- -repeatdelay {} -repeatinterval {}
- }
- Widget::addmap SpinBox ArrowButton .arrdn {
- -foreground {} -background {} -disabledforeground {} -state {}
- -repeatdelay {} -repeatinterval {}
- }
-
- Widget::syncoptions SpinBox Entry .e {-text {}}
- Widget::syncoptions SpinBox LabelFrame .labf {-label -text -underline {}}
-
- ::bind BwSpinBox <FocusIn> {focus %W.labf}
- ::bind BwSpinBox <Destroy> {SpinBox::_destroy %W}
-
- proc ::SpinBox { path args } { return [eval SpinBox::create $path $args] }
- proc use {} {}
-
- variable _widget
-}
-
-
-# ------------------------------------------------------------------------------
-# Command SpinBox::create
-# ------------------------------------------------------------------------------
-proc SpinBox::create { path args } {
- variable _widget
-
- Widget::init SpinBox $path $args
-
- _test_options $path
- eval frame $path [Widget::subcget $path :cmd] \
- -highlightthickness 0 -bd 0 -relief flat -takefocus 0
- set labf [eval LabelFrame::create $path.labf [Widget::subcget $path .labf] \
- -borderwidth 2 -relief sunken -focus $path.e]
- set entry [eval Entry::create $path.e [Widget::subcget $path .e] \
- -relief flat -borderwidth 0]
-
- bindtags $path [list $path BwSpinBox [winfo toplevel $path] all]
-
- set farr [frame $path.farr -relief flat -bd 0 -highlightthickness 0]
- set height [expr {[winfo reqheight $path.e]/2-2}]
- set width 11
- set arrup [eval ArrowButton::create $path.arrup -dir top \
- [Widget::subcget $path .arrup] \
- -highlightthickness 0 -borderwidth 1 -takefocus 0 \
- -type button \
- -width $width -height $height \
- -armcommand [list "SpinBox::_modify_value $path next arm"] \
- -disarmcommand [list "SpinBox::_modify_value $path next disarm"]]
- set arrdn [eval ArrowButton::create $path.arrdn -dir bottom \
- [Widget::subcget $path .arrdn] \
- -highlightthickness 0 -borderwidth 1 -takefocus 0 \
- -type button \
- -width $width -height $height \
- -armcommand [list "SpinBox::_modify_value $path previous arm"] \
- -disarmcommand [list "SpinBox::_modify_value $path previous disarm"]]
- set frame [LabelFrame::getframe $path.labf]
-
- # --- update -value ---
- if { [set val [Entry::cget $path.e -text]] != "" } {
- set _widget($path,curval) $val
- } else {
- if { [set var [Widget::getoption $path -textvariable]] != "" } {
- GlobalVar::setvar $var $_widget($path,curval)
- } else {
- Entry::configure $path.e -text $_widget($path,curval)
- }
- }
- Widget::setoption $path -text $_widget($path,curval)
-
- grid $arrup -in $farr -column 0 -row 0 -sticky nsew
- grid $arrdn -in $farr -column 0 -row 2 -sticky nsew
- grid rowconfigure $farr 0 -weight 1
- grid rowconfigure $farr 2 -weight 1
-
- pack $farr -in $frame -side right -fill y
- pack $entry -in $frame -side left -fill both -expand yes
- pack $labf -fill both -expand yes
-
- ::bind $entry <Key-Up> "SpinBox::_modify_value $path next activate"
- ::bind $entry <Key-Down> "SpinBox::_modify_value $path previous activate"
- ::bind $entry <Key-Prior> "SpinBox::_modify_value $path last activate"
- ::bind $entry <Key-Next> "SpinBox::_modify_value $path first activate"
-
- ::bind $farr <Configure> {grid rowconfigure %W 1 -minsize [expr {%h%%2}]}
-
- rename $path ::$path:cmd
- proc ::$path { cmd args } "return \[eval SpinBox::\$cmd $path \$args\]"
-
- return $path
-}
-
-
-# ------------------------------------------------------------------------------
-# Command SpinBox::configure
-# ------------------------------------------------------------------------------
-proc SpinBox::configure { path args } {
- set res [Widget::configure $path $args]
- if { [Widget::hasChanged $path -values val] ||
- [Widget::hasChanged $path -range val] } {
- _test_options $path
- }
- return $res
-}
-
-
-# ------------------------------------------------------------------------------
-# Command SpinBox::cget
-# ------------------------------------------------------------------------------
-proc SpinBox::cget { path option } {
- return [Widget::cget $path $option]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command SpinBox::setvalue
-# ------------------------------------------------------------------------------
-proc SpinBox::setvalue { path index } {
- variable _widget
-
- set values [Widget::getoption $path -values]
- set value [Entry::cget $path.e -text]
-
- if { [llength $values] } {
- # --- -values SpinBox ---
- switch -- $index {
- next {
- if { [set idx [lsearch $values $value]] != -1 } {
- incr idx
- } elseif { [set idx [lsearch $values "$value*"]] == -1 } {
- set idx [lsearch $values $_widget($path,curval)]
- }
- }
- previous {
- if { [set idx [lsearch $values $value]] != -1 } {
- incr idx -1
- } elseif { [set idx [lsearch $values "$value*"]] == -1 } {
- set idx [lsearch $values $_widget($path,curval)]
- }
- }
- first {
- set idx 0
- }
- last {
- set idx [expr {[llength $values]-1}]
- }
- default {
- if { [string index $index 0] == "@" } {
- set idx [string range $index 1 end]
- if { [catch {string compare [expr {int($idx)}] $idx} res] || $res != 0 } {
- return -code error "bad index \"$index\""
- }
- } else {
- return -code error "bad index \"$index\""
- }
- }
- }
- if { $idx >= 0 && $idx < [llength $values] } {
- set newval [lindex $values $idx]
- } else {
- return 0
- }
- } else {
- # --- -range SpinBox ---
- set range [Widget::getoption $path -range]
- set vmin [lindex $range 0]
- set vmax [lindex $range 1]
- set incr [lindex $range 2]
- switch -- $index {
- next {
- if { [catch {expr {double($value-$vmin)/$incr}} idx] } {
- set newval $_widget($path,curval)
- } else {
- set newval [expr {$vmin+(round($idx)+1)*$incr}]
- if { $newval < $vmin } {
- set newval $vmin
- } elseif { $newval > $vmax } {
- set newval $vmax
- }
- }
- }
- previous {
- if { [catch {expr {double($value-$vmin)/$incr}} idx] } {
- set newval $_widget($path,curval)
- } else {
- set newval [expr {$vmin+(round($idx)-1)*$incr}]
- if { $newval < $vmin } {
- set newval $vmin
- } elseif { $newval > $vmax } {
- set newval $vmax
- }
- }
- }
- first {
- set newval $vmin
- }
- last {
- set newval $vmax
- }
- default {
- if { [string index $index 0] == "@" } {
- set idx [string range $index 1 end]
- if { [catch {string compare [expr {int($idx)}] $idx} res] || $res != 0 } {
- return -code error "bad index \"$index\""
- }
- set newval [expr {$vmin+int($idx)*$incr}]
- if { $newval < $vmin || $newval > $vmax } {
- return 0
- }
- } else {
- return -code error "bad index \"$index\""
- }
- }
- }
- }
- set _widget($path,curval) $newval
- Widget::setoption $path -text $newval
- if { [set varname [Entry::cget $path.e -textvariable]] != "" } {
- GlobalVar::setvar $varname $newval
- } else {
- Entry::configure $path.e -text $newval
- }
- return 1
-}
-
-
-# ------------------------------------------------------------------------------
-# Command SpinBox::getvalue
-# ------------------------------------------------------------------------------
-proc SpinBox::getvalue { path } {
- variable _widget
-
- set values [Widget::getoption $path -values]
- set value [Entry::cget $path.e -text]
-
- if { [llength $values] } {
- # --- -values SpinBox ---
- return [lsearch $values $value]
- } else {
- set range [Widget::getoption $path -range]
- set vmin [lindex $range 0]
- set vmax [lindex $range 1]
- set incr [lindex $range 2]
- if { ![catch {expr {double($value-$vmin)/$incr}} idx] &&
- $idx == int($idx) } {
- return [expr {int($idx)}]
- }
- return -1
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command SpinBox::bind
-# ------------------------------------------------------------------------------
-proc SpinBox::bind { path args } {
- return [eval ::bind $path.e $args]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command SpinBox::_destroy
-# ------------------------------------------------------------------------------
-proc SpinBox::_destroy { path } {
- variable _widget
-
- unset _widget($path,curval)
- Widget::destroy $path
- rename $path {}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command SpinBox::_modify_value
-# ------------------------------------------------------------------------------
-proc SpinBox::_modify_value { path direction reason } {
- if { $reason == "arm" || $reason == "activate" } {
- SpinBox::setvalue $path $direction
- }
- if { ($reason == "disarm" || $reason == "activate") &&
- [set cmd [Widget::getoption $path -modifycmd]] != "" } {
- uplevel \#0 $cmd
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command SpinBox::_test_options
-# ------------------------------------------------------------------------------
-proc SpinBox::_test_options { path } {
- variable _widget
-
- set values [Widget::getoption $path -values]
- if { [llength $values] } {
- set _widget($path,curval) [lindex $values 0]
- } else {
- set range [Widget::getoption $path -range]
- set vmin [lindex $range 0]
- set vmax [lindex $range 1]
- set incr [lindex $range 2]
- if { [catch {expr {int($vmin)}}] } {
- set vmin 0
- }
- if { [catch {expr {$vmax<$vmin}} res] || $res } {
- set vmax $vmin
- }
- if { [catch {expr {$incr<0}} res] || $res } {
- set incr 1
- }
- Widget::setoption $path -range [list $vmin $vmax $incr]
- set _widget($path,curval) $vmin
- }
-}
-
Copied: grass/trunk/lib/external/bwidget/spinbox.tcl (from rev 35192, grass/trunk/lib/external/bwidget/spinbox.tcl)
===================================================================
--- grass/trunk/lib/external/bwidget/spinbox.tcl (rev 0)
+++ grass/trunk/lib/external/bwidget/spinbox.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,353 @@
+# ------------------------------------------------------------------------------
+# spinbox.tcl
+# This file is part of Unifix BWidget Toolkit
+# ------------------------------------------------------------------------------
+# Index of commands:
+# - SpinBox::create
+# - SpinBox::configure
+# - SpinBox::cget
+# - SpinBox::setvalue
+# - SpinBox::_destroy
+# - SpinBox::_modify_value
+# - SpinBox::_test_options
+# ------------------------------------------------------------------------------
+
+namespace eval SpinBox {
+ ArrowButton::use
+ Entry::use
+ LabelFrame::use
+
+ Widget::bwinclude SpinBox LabelFrame .labf \
+ rename {-text -label} \
+ prefix {label -justify -width -anchor -height -font} \
+ remove {-focus} \
+ initialize {-relief sunken -borderwidth 2}
+
+ Widget::bwinclude SpinBox Entry .e \
+ remove {-relief -bd -borderwidth -fg -bg} \
+ rename {-foreground -entryfg -background -entrybg}
+
+ Widget::declare SpinBox {
+ {-range String "" 0}
+ {-values String "" 0}
+ {-modifycmd String "" 0}
+ {-repeatdelay Int 400 0 {=0}}
+ {-repeatinterval Int 100 0 {=0}}
+ }
+
+ Widget::addmap SpinBox "" :cmd {-background {}}
+ Widget::addmap SpinBox ArrowButton .arrup {
+ -foreground {} -background {} -disabledforeground {} -state {}
+ -repeatdelay {} -repeatinterval {}
+ }
+ Widget::addmap SpinBox ArrowButton .arrdn {
+ -foreground {} -background {} -disabledforeground {} -state {}
+ -repeatdelay {} -repeatinterval {}
+ }
+
+ Widget::syncoptions SpinBox Entry .e {-text {}}
+ Widget::syncoptions SpinBox LabelFrame .labf {-label -text -underline {}}
+
+ ::bind BwSpinBox <FocusIn> {focus %W.labf}
+ ::bind BwSpinBox <Destroy> {SpinBox::_destroy %W}
+
+ proc ::SpinBox { path args } { return [eval SpinBox::create $path $args] }
+ proc use {} {}
+
+ variable _widget
+}
+
+
+# ------------------------------------------------------------------------------
+# Command SpinBox::create
+# ------------------------------------------------------------------------------
+proc SpinBox::create { path args } {
+ variable _widget
+
+ Widget::init SpinBox $path $args
+
+ _test_options $path
+ eval frame $path [Widget::subcget $path :cmd] \
+ -highlightthickness 0 -bd 0 -relief flat -takefocus 0
+ set labf [eval LabelFrame::create $path.labf [Widget::subcget $path .labf] \
+ -borderwidth 2 -relief sunken -focus $path.e]
+ set entry [eval Entry::create $path.e [Widget::subcget $path .e] \
+ -relief flat -borderwidth 0]
+
+ bindtags $path [list $path BwSpinBox [winfo toplevel $path] all]
+
+ set farr [frame $path.farr -relief flat -bd 0 -highlightthickness 0]
+ set height [expr {[winfo reqheight $path.e]/2-2}]
+ set width 11
+ set arrup [eval ArrowButton::create $path.arrup -dir top \
+ [Widget::subcget $path .arrup] \
+ -highlightthickness 0 -borderwidth 1 -takefocus 0 \
+ -type button \
+ -width $width -height $height \
+ -armcommand [list "SpinBox::_modify_value $path next arm"] \
+ -disarmcommand [list "SpinBox::_modify_value $path next disarm"]]
+ set arrdn [eval ArrowButton::create $path.arrdn -dir bottom \
+ [Widget::subcget $path .arrdn] \
+ -highlightthickness 0 -borderwidth 1 -takefocus 0 \
+ -type button \
+ -width $width -height $height \
+ -armcommand [list "SpinBox::_modify_value $path previous arm"] \
+ -disarmcommand [list "SpinBox::_modify_value $path previous disarm"]]
+ set frame [LabelFrame::getframe $path.labf]
+
+ # --- update -value ---
+ if { [set val [Entry::cget $path.e -text]] != "" } {
+ set _widget($path,curval) $val
+ } else {
+ if { [set var [Widget::getoption $path -textvariable]] != "" } {
+ GlobalVar::setvar $var $_widget($path,curval)
+ } else {
+ Entry::configure $path.e -text $_widget($path,curval)
+ }
+ }
+ Widget::setoption $path -text $_widget($path,curval)
+
+ grid $arrup -in $farr -column 0 -row 0 -sticky nsew
+ grid $arrdn -in $farr -column 0 -row 2 -sticky nsew
+ grid rowconfigure $farr 0 -weight 1
+ grid rowconfigure $farr 2 -weight 1
+
+ pack $farr -in $frame -side right -fill y
+ pack $entry -in $frame -side left -fill both -expand yes
+ pack $labf -fill both -expand yes
+
+ ::bind $entry <Key-Up> "SpinBox::_modify_value $path next activate"
+ ::bind $entry <Key-Down> "SpinBox::_modify_value $path previous activate"
+ ::bind $entry <Key-Prior> "SpinBox::_modify_value $path last activate"
+ ::bind $entry <Key-Next> "SpinBox::_modify_value $path first activate"
+
+ ::bind $farr <Configure> {grid rowconfigure %W 1 -minsize [expr {%h%%2}]}
+
+ rename $path ::$path:cmd
+ proc ::$path { cmd args } "return \[eval SpinBox::\$cmd $path \$args\]"
+
+ return $path
+}
+
+
+# ------------------------------------------------------------------------------
+# Command SpinBox::configure
+# ------------------------------------------------------------------------------
+proc SpinBox::configure { path args } {
+ set res [Widget::configure $path $args]
+ if { [Widget::hasChanged $path -values val] ||
+ [Widget::hasChanged $path -range val] } {
+ _test_options $path
+ }
+ return $res
+}
+
+
+# ------------------------------------------------------------------------------
+# Command SpinBox::cget
+# ------------------------------------------------------------------------------
+proc SpinBox::cget { path option } {
+ return [Widget::cget $path $option]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command SpinBox::setvalue
+# ------------------------------------------------------------------------------
+proc SpinBox::setvalue { path index } {
+ variable _widget
+
+ set values [Widget::getoption $path -values]
+ set value [Entry::cget $path.e -text]
+
+ if { [llength $values] } {
+ # --- -values SpinBox ---
+ switch -- $index {
+ next {
+ if { [set idx [lsearch $values $value]] != -1 } {
+ incr idx
+ } elseif { [set idx [lsearch $values "$value*"]] == -1 } {
+ set idx [lsearch $values $_widget($path,curval)]
+ }
+ }
+ previous {
+ if { [set idx [lsearch $values $value]] != -1 } {
+ incr idx -1
+ } elseif { [set idx [lsearch $values "$value*"]] == -1 } {
+ set idx [lsearch $values $_widget($path,curval)]
+ }
+ }
+ first {
+ set idx 0
+ }
+ last {
+ set idx [expr {[llength $values]-1}]
+ }
+ default {
+ if { [string index $index 0] == "@" } {
+ set idx [string range $index 1 end]
+ if { [catch {string compare [expr {int($idx)}] $idx} res] || $res != 0 } {
+ return -code error "bad index \"$index\""
+ }
+ } else {
+ return -code error "bad index \"$index\""
+ }
+ }
+ }
+ if { $idx >= 0 && $idx < [llength $values] } {
+ set newval [lindex $values $idx]
+ } else {
+ return 0
+ }
+ } else {
+ # --- -range SpinBox ---
+ set range [Widget::getoption $path -range]
+ set vmin [lindex $range 0]
+ set vmax [lindex $range 1]
+ set incr [lindex $range 2]
+ switch -- $index {
+ next {
+ if { [catch {expr {double($value-$vmin)/$incr}} idx] } {
+ set newval $_widget($path,curval)
+ } else {
+ set newval [expr {$vmin+(round($idx)+1)*$incr}]
+ if { $newval < $vmin } {
+ set newval $vmin
+ } elseif { $newval > $vmax } {
+ set newval $vmax
+ }
+ }
+ }
+ previous {
+ if { [catch {expr {double($value-$vmin)/$incr}} idx] } {
+ set newval $_widget($path,curval)
+ } else {
+ set newval [expr {$vmin+(round($idx)-1)*$incr}]
+ if { $newval < $vmin } {
+ set newval $vmin
+ } elseif { $newval > $vmax } {
+ set newval $vmax
+ }
+ }
+ }
+ first {
+ set newval $vmin
+ }
+ last {
+ set newval $vmax
+ }
+ default {
+ if { [string index $index 0] == "@" } {
+ set idx [string range $index 1 end]
+ if { [catch {string compare [expr {int($idx)}] $idx} res] || $res != 0 } {
+ return -code error "bad index \"$index\""
+ }
+ set newval [expr {$vmin+int($idx)*$incr}]
+ if { $newval < $vmin || $newval > $vmax } {
+ return 0
+ }
+ } else {
+ return -code error "bad index \"$index\""
+ }
+ }
+ }
+ }
+ set _widget($path,curval) $newval
+ Widget::setoption $path -text $newval
+ if { [set varname [Entry::cget $path.e -textvariable]] != "" } {
+ GlobalVar::setvar $varname $newval
+ } else {
+ Entry::configure $path.e -text $newval
+ }
+ return 1
+}
+
+
+# ------------------------------------------------------------------------------
+# Command SpinBox::getvalue
+# ------------------------------------------------------------------------------
+proc SpinBox::getvalue { path } {
+ variable _widget
+
+ set values [Widget::getoption $path -values]
+ set value [Entry::cget $path.e -text]
+
+ if { [llength $values] } {
+ # --- -values SpinBox ---
+ return [lsearch $values $value]
+ } else {
+ set range [Widget::getoption $path -range]
+ set vmin [lindex $range 0]
+ set vmax [lindex $range 1]
+ set incr [lindex $range 2]
+ if { ![catch {expr {double($value-$vmin)/$incr}} idx] &&
+ $idx == int($idx) } {
+ return [expr {int($idx)}]
+ }
+ return -1
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command SpinBox::bind
+# ------------------------------------------------------------------------------
+proc SpinBox::bind { path args } {
+ return [eval ::bind $path.e $args]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command SpinBox::_destroy
+# ------------------------------------------------------------------------------
+proc SpinBox::_destroy { path } {
+ variable _widget
+
+ unset _widget($path,curval)
+ Widget::destroy $path
+ rename $path {}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command SpinBox::_modify_value
+# ------------------------------------------------------------------------------
+proc SpinBox::_modify_value { path direction reason } {
+ if { $reason == "arm" || $reason == "activate" } {
+ SpinBox::setvalue $path $direction
+ }
+ if { ($reason == "disarm" || $reason == "activate") &&
+ [set cmd [Widget::getoption $path -modifycmd]] != "" } {
+ uplevel \#0 $cmd
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command SpinBox::_test_options
+# ------------------------------------------------------------------------------
+proc SpinBox::_test_options { path } {
+ variable _widget
+
+ set values [Widget::getoption $path -values]
+ if { [llength $values] } {
+ set _widget($path,curval) [lindex $values 0]
+ } else {
+ set range [Widget::getoption $path -range]
+ set vmin [lindex $range 0]
+ set vmax [lindex $range 1]
+ set incr [lindex $range 2]
+ if { [catch {expr {int($vmin)}}] } {
+ set vmin 0
+ }
+ if { [catch {expr {$vmax<$vmin}} res] || $res } {
+ set vmax $vmin
+ }
+ if { [catch {expr {$incr<0}} res] || $res } {
+ set incr 1
+ }
+ Widget::setoption $path -range [list $vmin $vmax $incr]
+ set _widget($path,curval) $vmin
+ }
+}
+
Deleted: grass/trunk/lib/external/bwidget/titleframe.tcl
===================================================================
--- grass/trunk/lib/external/bwidget/titleframe.tcl 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/titleframe.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,152 +0,0 @@
-# ------------------------------------------------------------------------------
-# titleframe.tcl
-# This file is part of Unifix BWidget Toolkit
-# ------------------------------------------------------------------------------
-# Index of commands:
-# - TitleFrame::create
-# - TitleFrame::configure
-# - TitleFrame::cget
-# - TitleFrame::getframe
-# - TitleFrame::_place
-# ------------------------------------------------------------------------------
-
-namespace eval TitleFrame {
- Widget::declare TitleFrame {
- {-relief TkResource groove 0 frame}
- {-borderwidth TkResource 2 0 frame}
- {-font TkResource "" 0 label}
- {-foreground TkResource "" 0 label}
- {-background TkResource "" 0 frame}
- {-text String "" 0}
- {-ipad Int 4 0 {=0 ""}}
- {-side Enum left 0 {left center right}}
- {-baseline Enum center 0 {top center bottom}}
- {-fg Synonym -foreground}
- {-bg Synonym -background}
- {-bd Synonym -borderwidth}
- }
-
- Widget::addmap TitleFrame "" :cmd {-background {}}
- Widget::addmap TitleFrame "" .l {-background {} -foreground {} -text {} -font {}}
- Widget::addmap TitleFrame "" .p {-background {}}
- Widget::addmap TitleFrame "" .b {-background {} -relief {} -borderwidth {}}
- Widget::addmap TitleFrame "" .b.p {-background {}}
- Widget::addmap TitleFrame "" .f {-background {}}
-
- proc ::TitleFrame { path args } { return [eval TitleFrame::create $path $args] }
- proc use {} {}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command TitleFrame::create
-# ------------------------------------------------------------------------------
-proc TitleFrame::create { path args } {
- Widget::init TitleFrame $path $args
-
- set bg [Widget::getoption $path -background]
- set frame [frame $path -background $bg]
- set padtop [frame $path.p -relief flat -borderwidth 0 -background $bg]
- set border [eval frame $path.b [Widget::subcget $path .b] -highlightthickness 0]
- set label [eval label $path.l [Widget::subcget $path .l] \
- -highlightthickness 0 \
- -relief flat \
- -bd 0 -padx 2 -pady 0]
- set padbot [frame $border.p -relief flat -bd 0 -bg $bg -highlightthickness 0]
- set frame [frame $path.f -relief flat -bd 0 -bg $bg -highlightthickness 0]
- set height [winfo reqheight $label]
-
- switch [Widget::getoption $path -side] {
- left { set relx 0.0; set x 5; set anchor nw }
- center { set relx 0.5; set x 0; set anchor n }
- right { set relx 1.0; set x -5; set anchor ne }
- }
- set bd [Widget::getoption $path -borderwidth]
- switch [Widget::getoption $path -baseline] {
- top { set htop $height; set hbot 1; set y 0 }
- center { set htop [expr {$height/2}]; set hbot [expr {$height/2+$height%2+1}]; set y 0 }
- bottom { set htop 1; set hbot $height; set y [expr {$bd+1}] }
- }
- $padtop configure -height $htop
- $padbot configure -height $hbot
-
- set pad [Widget::getoption $path -ipad]
- pack $padbot -side top -fill x
- pack $frame -in $border -fill both -expand yes -padx $pad -pady $pad
-
- pack $padtop -side top -fill x
- pack $border -fill both -expand yes
-
- place $label -relx $relx -x $x -anchor $anchor -y $y
-
- bind $label <Configure> "TitleFrame::_place $path"
- bind $path <Destroy> {Widget::destroy %W; rename %W {}}
-
- rename $path ::$path:cmd
- proc ::$path { cmd args } "return \[eval TitleFrame::\$cmd $path \$args\]"
-
- return $path
-}
-
-
-# ------------------------------------------------------------------------------
-# Command TitleFrame::configure
-# ------------------------------------------------------------------------------
-proc TitleFrame::configure { path args } {
- set res [Widget::configure $path $args]
-
- if { [Widget::hasChanged $path -ipad pad] } {
- pack configure $path.f -padx $pad -pady $pad
- }
- if { [Widget::hasChanged $path -borderwidth val] |
- [Widget::hasChanged $path -font val] |
- [Widget::hasChanged $path -side val] |
- [Widget::hasChanged $path -baseline val] } {
- _place $path
- }
-
- return $res
-}
-
-
-# ------------------------------------------------------------------------------
-# Command TitleFrame::cget
-# ------------------------------------------------------------------------------
-proc TitleFrame::cget { path option } {
- return [Widget::cget $path $option]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command TitleFrame::getframe
-# ------------------------------------------------------------------------------
-proc TitleFrame::getframe { path } {
- return $path.f
-}
-
-
-# ------------------------------------------------------------------------------
-# Command TitleFrame::_place
-# ------------------------------------------------------------------------------
-proc TitleFrame::_place { path } {
- set height [winfo height $path.l]
- switch [Widget::getoption $path -side] {
- left { set relx 0.0; set x 10; set anchor nw }
- center { set relx 0.5; set x 0; set anchor n }
- right { set relx 1.0; set x -10; set anchor ne }
- }
- set bd [Widget::getoption $path -borderwidth]
- switch [Widget::getoption $path -baseline] {
- top { set htop $height; set hbot 1; set y 0 }
- center { set htop [expr {$height/2}]; set hbot [expr {$height/2+$height%2+1}]; set y 0 }
- bottom { set htop 1; set hbot $height; set y [expr {$bd+1}] }
- }
- $path.p configure -height $htop
- $path.b.p configure -height $hbot
-
- place $path.l -relx $relx -x $x -anchor $anchor -y $y
-}
-
-
-
-
Copied: grass/trunk/lib/external/bwidget/titleframe.tcl (from rev 35192, grass/trunk/lib/external/bwidget/titleframe.tcl)
===================================================================
--- grass/trunk/lib/external/bwidget/titleframe.tcl (rev 0)
+++ grass/trunk/lib/external/bwidget/titleframe.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,152 @@
+# ------------------------------------------------------------------------------
+# titleframe.tcl
+# This file is part of Unifix BWidget Toolkit
+# ------------------------------------------------------------------------------
+# Index of commands:
+# - TitleFrame::create
+# - TitleFrame::configure
+# - TitleFrame::cget
+# - TitleFrame::getframe
+# - TitleFrame::_place
+# ------------------------------------------------------------------------------
+
+namespace eval TitleFrame {
+ Widget::declare TitleFrame {
+ {-relief TkResource groove 0 frame}
+ {-borderwidth TkResource 2 0 frame}
+ {-font TkResource "" 0 label}
+ {-foreground TkResource "" 0 label}
+ {-background TkResource "" 0 frame}
+ {-text String "" 0}
+ {-ipad Int 4 0 {=0 ""}}
+ {-side Enum left 0 {left center right}}
+ {-baseline Enum center 0 {top center bottom}}
+ {-fg Synonym -foreground}
+ {-bg Synonym -background}
+ {-bd Synonym -borderwidth}
+ }
+
+ Widget::addmap TitleFrame "" :cmd {-background {}}
+ Widget::addmap TitleFrame "" .l {-background {} -foreground {} -text {} -font {}}
+ Widget::addmap TitleFrame "" .p {-background {}}
+ Widget::addmap TitleFrame "" .b {-background {} -relief {} -borderwidth {}}
+ Widget::addmap TitleFrame "" .b.p {-background {}}
+ Widget::addmap TitleFrame "" .f {-background {}}
+
+ proc ::TitleFrame { path args } { return [eval TitleFrame::create $path $args] }
+ proc use {} {}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command TitleFrame::create
+# ------------------------------------------------------------------------------
+proc TitleFrame::create { path args } {
+ Widget::init TitleFrame $path $args
+
+ set bg [Widget::getoption $path -background]
+ set frame [frame $path -background $bg]
+ set padtop [frame $path.p -relief flat -borderwidth 0 -background $bg]
+ set border [eval frame $path.b [Widget::subcget $path .b] -highlightthickness 0]
+ set label [eval label $path.l [Widget::subcget $path .l] \
+ -highlightthickness 0 \
+ -relief flat \
+ -bd 0 -padx 2 -pady 0]
+ set padbot [frame $border.p -relief flat -bd 0 -bg $bg -highlightthickness 0]
+ set frame [frame $path.f -relief flat -bd 0 -bg $bg -highlightthickness 0]
+ set height [winfo reqheight $label]
+
+ switch [Widget::getoption $path -side] {
+ left { set relx 0.0; set x 5; set anchor nw }
+ center { set relx 0.5; set x 0; set anchor n }
+ right { set relx 1.0; set x -5; set anchor ne }
+ }
+ set bd [Widget::getoption $path -borderwidth]
+ switch [Widget::getoption $path -baseline] {
+ top { set htop $height; set hbot 1; set y 0 }
+ center { set htop [expr {$height/2}]; set hbot [expr {$height/2+$height%2+1}]; set y 0 }
+ bottom { set htop 1; set hbot $height; set y [expr {$bd+1}] }
+ }
+ $padtop configure -height $htop
+ $padbot configure -height $hbot
+
+ set pad [Widget::getoption $path -ipad]
+ pack $padbot -side top -fill x
+ pack $frame -in $border -fill both -expand yes -padx $pad -pady $pad
+
+ pack $padtop -side top -fill x
+ pack $border -fill both -expand yes
+
+ place $label -relx $relx -x $x -anchor $anchor -y $y
+
+ bind $label <Configure> "TitleFrame::_place $path"
+ bind $path <Destroy> {Widget::destroy %W; rename %W {}}
+
+ rename $path ::$path:cmd
+ proc ::$path { cmd args } "return \[eval TitleFrame::\$cmd $path \$args\]"
+
+ return $path
+}
+
+
+# ------------------------------------------------------------------------------
+# Command TitleFrame::configure
+# ------------------------------------------------------------------------------
+proc TitleFrame::configure { path args } {
+ set res [Widget::configure $path $args]
+
+ if { [Widget::hasChanged $path -ipad pad] } {
+ pack configure $path.f -padx $pad -pady $pad
+ }
+ if { [Widget::hasChanged $path -borderwidth val] |
+ [Widget::hasChanged $path -font val] |
+ [Widget::hasChanged $path -side val] |
+ [Widget::hasChanged $path -baseline val] } {
+ _place $path
+ }
+
+ return $res
+}
+
+
+# ------------------------------------------------------------------------------
+# Command TitleFrame::cget
+# ------------------------------------------------------------------------------
+proc TitleFrame::cget { path option } {
+ return [Widget::cget $path $option]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command TitleFrame::getframe
+# ------------------------------------------------------------------------------
+proc TitleFrame::getframe { path } {
+ return $path.f
+}
+
+
+# ------------------------------------------------------------------------------
+# Command TitleFrame::_place
+# ------------------------------------------------------------------------------
+proc TitleFrame::_place { path } {
+ set height [winfo height $path.l]
+ switch [Widget::getoption $path -side] {
+ left { set relx 0.0; set x 10; set anchor nw }
+ center { set relx 0.5; set x 0; set anchor n }
+ right { set relx 1.0; set x -10; set anchor ne }
+ }
+ set bd [Widget::getoption $path -borderwidth]
+ switch [Widget::getoption $path -baseline] {
+ top { set htop $height; set hbot 1; set y 0 }
+ center { set htop [expr {$height/2}]; set hbot [expr {$height/2+$height%2+1}]; set y 0 }
+ bottom { set htop 1; set hbot $height; set y [expr {$bd+1}] }
+ }
+ $path.p configure -height $htop
+ $path.b.p configure -height $hbot
+
+ place $path.l -relx $relx -x $x -anchor $anchor -y $y
+}
+
+
+
+
Deleted: grass/trunk/lib/external/bwidget/tree.tcl
===================================================================
--- grass/trunk/lib/external/bwidget/tree.tcl 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/tree.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,1389 +0,0 @@
-# ------------------------------------------------------------------------------
-# tree.tcl
-# This file is part of Unifix BWidget Toolkit
-# $Id$
-# ------------------------------------------------------------------------------
-# Index of commands:
-# - Tree::create
-# - Tree::configure
-# - Tree::cget
-# - Tree::insert
-# - Tree::itemconfigure
-# - Tree::itemcget
-# - Tree::bindText
-# - Tree::bindImage
-# - Tree::delete
-# - Tree::move
-# - Tree::reorder
-# - Tree::selection
-# - Tree::exists
-# - Tree::parent
-# - Tree::index
-# - Tree::nodes
-# - Tree::see
-# - Tree::opentree
-# - Tree::closetree
-# - Tree::edit
-# - Tree::xview
-# - Tree::yview
-# - Tree::_update_edit_size
-# - Tree::_destroy
-# - Tree::_see
-# - Tree::_recexpand
-# - Tree::_subdelete
-# - Tree::_update_scrollregion
-# - Tree::_cross_event
-# - Tree::_draw_node
-# - Tree::_draw_subnodes
-# - Tree::_update_nodes
-# - Tree::_draw_tree
-# - Tree::_redraw_tree
-# - Tree::_redraw_selection
-# - Tree::_redraw_idle
-# - Tree::_drag_cmd
-# - Tree::_drop_cmd
-# - Tree::_over_cmd
-# - Tree::_auto_scroll
-# - Tree::_scroll
-# ------------------------------------------------------------------------------
-
-namespace eval Tree {
- namespace eval Node {
- Widget::declare Tree::Node {
- {-text String "" 0}
- {-font TkResource "" 0 listbox}
- {-image TkResource "" 0 label}
- {-window String "" 0}
- {-fill TkResource black 0 {listbox -foreground}}
- {-data String "" 0}
- {-open Boolean 0 0}
- {-drawcross Enum auto 0 {auto allways never}}
- }
- }
-
- Widget::tkinclude Tree canvas :cmd \
- remove {-insertwidth -insertbackground -insertborderwidth -insertofftime \
- -insertontime -selectborderwidth -closeenough -confine -scrollregion \
- -xscrollincrement -yscrollincrement -width -height} \
- initialize {-relief sunken -borderwidth 2 -takefocus 1 \
- -highlightthickness 1 -width 200}
-
- Widget::declare Tree {
- {-deltax Int 10 0 {=0 ""}}
- {-deltay Int 15 0 {=0 ""}}
- {-padx Int 20 0 {=0 ""}}
- {-background TkResource "" 0 listbox}
- {-selectbackground TkResource "" 0 listbox}
- {-selectforeground TkResource "" 0 listbox}
- {-width TkResource "" 0 listbox}
- {-height TkResource "" 0 listbox}
- {-showlines Boolean 1 0}
- {-linesfill TkResource black 0 {frame -background}}
- {-linestipple TkResource "" 0 {label -bitmap}}
- {-redraw Boolean 1 0}
- {-opencmd String "" 0}
- {-closecmd String "" 0}
- {-dropovermode Flag "wpn" 0 "wpn"}
- {-bg Synonym -background}
- }
- DragSite::include Tree "TREE_NODE" 1
- DropSite::include Tree {
- TREE_NODE {copy {} move {}}
- }
-
- Widget::addmap Tree "" :cmd {-deltay -yscrollincrement}
-
- proc ::Tree { path args } { return [eval Tree::create $path $args] }
- proc use {} {}
-
- variable _edit
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::create
-# ------------------------------------------------------------------------------
-proc Tree::create { path args } {
- variable $path
- upvar 0 $path data
-
- Widget::init Tree $path $args
-
- set data(root) {{}}
- set data(selnodes) {}
- set data(upd,level) 0
- set data(upd,nodes) {}
- set data(upd,afterid) ""
- set data(dnd,scroll) ""
- set data(dnd,afterid) ""
- set data(dnd,selnodes) {}
- set data(dnd,node) ""
-
- set path [eval canvas $path [Widget::subcget $path :cmd] \
- -width [expr {[Widget::getoption $path -width]*8}] \
- -height [expr {[Widget::getoption $path -height]*[Widget::getoption $path -deltay]}] \
- -xscrollincrement 8]
-
- $path bind cross <ButtonPress-1> {Tree::_cross_event %W}
- bind $path <Configure> "Tree::_update_scrollregion $path"
- bind $path <Destroy> "Tree::_destroy $path"
-
- DragSite::setdrag $path $path Tree::_init_drag_cmd [Widget::getoption $path -dragendcmd] 1
- DropSite::setdrop $path $path Tree::_over_cmd Tree::_drop_cmd 1
-
- rename $path ::$path:cmd
- proc ::$path { cmd args } "return \[eval Tree::\$cmd $path \$args\]"
-
- return $path
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::configure
-# ------------------------------------------------------------------------------
-proc Tree::configure { path args } {
- variable $path
- upvar 0 $path data
-
- set res [Widget::configure $path $args]
-
- set ch1 [expr {[Widget::hasChanged $path -deltax val] |
- [Widget::hasChanged $path -deltay dy] |
- [Widget::hasChanged $path -padx val] |
- [Widget::hasChanged $path -showlines val]}]
-
- set ch2 [expr {[Widget::hasChanged $path -selectbackground val] |
- [Widget::hasChanged $path -selectforeground val]}]
-
- if { [Widget::hasChanged $path -linesfill fill] |
- [Widget::hasChanged $path -linestipple stipple] } {
- $path:cmd itemconfigure line -fill $fill -stipple $stipple
- $path:cmd itemconfigure cross -foreground $fill
- }
-
- if { $ch1 } {
- _redraw_idle $path 3
- } elseif { $ch2 } {
- _redraw_idle $path 1
- }
-
- if { [Widget::hasChanged $path -height h] } {
- $path:cmd configure -height [expr {$h*$dy}]
- }
- if { [Widget::hasChanged $path -width w] } {
- $path:cmd configure -width [expr {$w*8}]
- }
-
- if { [Widget::hasChanged $path -redraw bool] && $bool } {
- set upd $data(upd,level)
- set data(upd,level) 0
- _redraw_idle $path $upd
- }
-
- set force [Widget::hasChanged $path -dragendcmd dragend]
- DragSite::setdrag $path $path Tree::_init_drag_cmd $dragend $force
- DropSite::setdrop $path $path Tree::_over_cmd Tree::_drop_cmd
-
- return $res
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::cget
-# ------------------------------------------------------------------------------
-proc Tree::cget { path option } {
- return [Widget::cget $path $option]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::insert
-# ------------------------------------------------------------------------------
-proc Tree::insert { path index parent node args } {
- variable $path
- upvar 0 $path data
-
- if { [info exists data($node)] } {
- return -code error "node \"$node\" already exists"
- }
- if { ![info exists data($parent)] } {
- return -code error "node \"$parent\" does not exist"
- }
-
- Widget::init Tree::Node $path.$node $args
- if { ![string compare $index "end"] } {
- lappend data($parent) $node
- } else {
- incr index
- set data($parent) [linsert $data($parent) $index $node]
- }
- set data($node) [list $parent]
-
- if { ![string compare $parent "root"] } {
- _redraw_idle $path 3
- } elseif { [visible $path $parent] } {
- # parent is visible...
- if { [Widget::getoption $path.$parent -open] } {
- # ...and opened -> redraw whole
- _redraw_idle $path 3
- } else {
- # ...and closed -> redraw cross
- lappend data(upd,nodes) $parent 8
- _redraw_idle $path 2
- }
- }
- return $node
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::itemconfigure
-# ------------------------------------------------------------------------------
-proc Tree::itemconfigure { path node args } {
- variable $path
- upvar 0 $path data
-
- if { ![string compare $node "root"] || ![info exists data($node)] } {
- return -code error "node \"$node\" does not exist"
- }
-
- set result [Widget::configure $path.$node $args]
- if { [visible $path $node] } {
- set lopt {}
- set flag 0
- foreach opt {-window -image -drawcross -font -text -fill} {
- set flag [expr {$flag << 1}]
- if { [Widget::hasChanged $path.$node $opt val] } {
- set flag [expr {$flag | 1}]
- }
- }
-
- if { [Widget::hasChanged $path.$node -open val] } {
- _redraw_idle $path 3
- } elseif { $data(upd,level) < 3 && $flag } {
- if { [set idx [lsearch $data(upd,nodes) $node]] == -1 } {
- lappend data(upd,nodes) $node $flag
- } else {
- incr idx
- set flag [expr {[lindex $data(upd,nodes) $idx] | $flag}]
- set data(upd,nodes) [lreplace $data(upd,nodes) $idx $idx $flag]
- }
- _redraw_idle $path 2
- }
- }
- return $result
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::itemcget
-# ------------------------------------------------------------------------------
-proc Tree::itemcget { path node option } {
- variable $path
- upvar 0 $path data
-
- if { ![string compare $node "root"] || ![info exists data($node)] } {
- return -code error "node \"$node\" does not exist"
- }
-
- return [Widget::cget $path.$node $option]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::bindText
-# ------------------------------------------------------------------------------
-proc Tree::bindText { path event script } {
- if { $script != "" } {
- $path:cmd bind "node" $event \
- "$script \[string range \[lindex \[$path:cmd gettags current\] 1\] 2 end\]"
- } else {
- $path:cmd bind "node" $event {}
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::bindImage
-# ------------------------------------------------------------------------------
-proc Tree::bindImage { path event script } {
- if { $script != "" } {
- $path:cmd bind "img" $event \
- "$script \[string range \[lindex \[$path:cmd gettags current\] 1\] 2 end\]"
- } else {
- $path:cmd bind "img" $event {}
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::delete
-# ------------------------------------------------------------------------------
-proc Tree::delete { path args } {
- variable $path
- upvar 0 $path data
-
- foreach lnodes $args {
- foreach node $lnodes {
- if { [string compare $node "root"] && [info exists data($node)] } {
- set parent [lindex $data($node) 0]
- set idx [lsearch $data($parent) $node]
- set data($parent) [lreplace $data($parent) $idx $idx]
- _subdelete $path [list $node]
- }
- }
- }
-
- set sel $data(selnodes)
- set data(selnodes) {}
- eval selection $path set $sel
- _redraw_idle $path 3
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::move
-# ------------------------------------------------------------------------------
-proc Tree::move { path parent node index } {
- variable $path
- upvar 0 $path data
-
- if { ![string compare $node "root"] || ![info exists data($node)] } {
- return -code error "node \"$node\" does not exist"
- }
- if { ![info exists data($parent)] } {
- return -code error "node \"$parent\" does not exist"
- }
- set p $parent
- while { [string compare $p "root"] } {
- if { ![string compare $p $node] } {
- return -code error "node \"$parent\" is a descendant of \"$node\""
- }
- set p [parent $path $p]
- }
-
- set oldp [lindex $data($node) 0]
- set idx [lsearch $data($oldp) $node]
- set data($oldp) [lreplace $data($oldp) $idx $idx]
- set data($node) [concat [list $parent] [lrange $data($node) 1 end]]
- if { ![string compare $index "end"] } {
- lappend data($parent) $node
- } else {
- incr index
- set data($parent) [linsert $data($parent) $index $node]
- }
- if { (![string compare $oldp "root"] ||
- ([visible $path $oldp] && [Widget::getoption $path.$oldp -open])) ||
- (![string compare $parent "root"] ||
- ([visible $path $parent] && [Widget::getoption $path.$parent -open])) } {
- _redraw_idle $path 3
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::reorder
-# ------------------------------------------------------------------------------
-proc Tree::reorder { path node neworder } {
- variable $path
- upvar 0 $path data
-
- if { ![info exists data($node)] } {
- return -code error "node \"$node\" does not exist"
- }
- set children [lrange $data($node) 1 end]
- if { [llength $children] } {
- set children [BWidget::lreorder $children $neworder]
- set data($node) [linsert $children 0 [lindex $data($node) 0]]
- if { [visible $path $node] && [Widget::getoption $path.$node -open] } {
- _redraw_idle $path 3
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::selection
-# ------------------------------------------------------------------------------
-proc Tree::selection { path cmd args } {
- variable $path
- upvar 0 $path data
-
- switch -- $cmd {
- set {
- set data(selnodes) {}
- foreach node $args {
- if { [info exists data($node)] } {
- if { [lsearch $data(selnodes) $node] == -1 } {
- lappend data(selnodes) $node
- }
- }
- }
- }
- add {
- foreach node $args {
- if { [info exists data($node)] } {
- if { [lsearch $data(selnodes) $node] == -1 } {
- lappend data(selnodes) $node
- }
- }
- }
- }
- remove {
- foreach node $args {
- if { [set idx [lsearch $data(selnodes) $node]] != -1 } {
- set data(selnodes) [lreplace $data(selnodes) $idx $idx]
- }
- }
- }
- clear {
- set data(selnodes) {}
- }
- get {
- return $data(selnodes)
- }
- default {
- return
- }
- }
- _redraw_idle $path 1
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::exists
-# ------------------------------------------------------------------------------
-proc Tree::exists { path node } {
- variable $path
- upvar 0 $path data
-
- return [info exists data($node)]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::visible
-# ------------------------------------------------------------------------------
-proc Tree::visible { path node } {
- set idn [$path:cmd find withtag n:$node]
- return [llength $idn]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::parent
-# ------------------------------------------------------------------------------
-proc Tree::parent { path node } {
- variable $path
- upvar 0 $path data
-
- if { ![info exists data($node)] } {
- return -code error "node \"$node\" does not exist"
- }
- return [lindex $data($node) 0]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::index
-# ------------------------------------------------------------------------------
-proc Tree::index { path node } {
- variable $path
- upvar 0 $path data
-
- if { ![string compare $node "root"] || ![info exists data($node)] } {
- return -code error "node \"$node\" does not exist"
- }
- set parent [lindex $data($node) 0]
- return [expr {[lsearch $data($parent) $node] - 1}]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::nodes
-# ------------------------------------------------------------------------------
-proc Tree::nodes { path node {first ""} {last ""} } {
- variable $path
- upvar 0 $path data
-
- if { ![info exists data($node)] } {
- return -code error "node \"$node\" does not exist"
- }
-
- if { ![string length $first] } {
- return [lrange $data($node) 1 end]
- }
-
- if { ![string length $last] } {
- return [lindex [lrange $data($node) 1 end] $first]
- } else {
- return [lrange [lrange $data($node) 1 end] $first $last]
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::see
-# ------------------------------------------------------------------------------
-proc Tree::see { path node } {
- variable $path
- upvar 0 $path data
-
- if { [Widget::getoption $path -redraw] && $data(upd,afterid) != "" } {
- after cancel $data(upd,afterid)
- _redraw_tree $path
- }
- set idn [$path:cmd find withtag n:$node]
- if { $idn != "" } {
- Tree::_see $path $idn right
- Tree::_see $path $idn left
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::opentree
-# ------------------------------------------------------------------------------
-proc Tree::opentree { path node } {
- variable $path
- upvar 0 $path data
-
- if { ![string compare $node "root"] || ![info exists data($node)] } {
- return -code error "node \"$node\" does not exist"
- }
-
- _recexpand $path $node 1 [Widget::getoption $path -opencmd]
- _redraw_idle $path 3
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::closetree
-# ------------------------------------------------------------------------------
-proc Tree::closetree { path node } {
- variable $path
- upvar 0 $path data
-
- if { ![string compare $node "root"] || ![info exists data($node)] } {
- return -code error "node \"$node\" does not exist"
- }
-
- _recexpand $path $node 0 [Widget::getoption $path -closecmd]
- _redraw_idle $path 3
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::edit
-# ------------------------------------------------------------------------------
-proc Tree::edit { path node text {verifycmd ""} {clickres 0} {select 1}} {
- variable _edit
- variable $path
- upvar 0 $path data
-
- if { [Widget::getoption $path -redraw] && $data(upd,afterid) != "" } {
- after cancel $data(upd,afterid)
- _redraw_tree $path
- }
- set idn [$path:cmd find withtag n:$node]
- if { $idn != "" } {
- Tree::_see $path $idn right
- Tree::_see $path $idn left
-
- set oldfg [$path:cmd itemcget $idn -fill]
- set sbg [Widget::getoption $path -selectbackground]
- set coords [$path:cmd coords $idn]
- set x [lindex $coords 0]
- set y [lindex $coords 1]
- set bd [expr {[$path:cmd cget -borderwidth]+[$path:cmd cget -highlightthickness]}]
- set w [expr {[winfo width $path] - 2*$bd}]
- set wmax [expr {[$path:cmd canvasx $w]-$x}]
-
- set _edit(text) $text
- set _edit(wait) 0
-
- $path:cmd itemconfigure $idn -fill [Widget::getoption $path -background]
- $path:cmd itemconfigure s:$node -fill {} -outline {}
-
- set frame [frame $path.edit \
- -relief flat -borderwidth 0 -highlightthickness 0 \
- -background [Widget::getoption $path -background]]
- set ent [entry $frame.edit \
- -width 0 \
- -relief solid \
- -borderwidth 1 \
- -highlightthickness 0 \
- -foreground [Widget::getoption $path.$node -fill] \
- -background [Widget::getoption $path -background] \
- -selectforeground [Widget::getoption $path -selectforeground] \
- -selectbackground $sbg \
- -font [Widget::getoption $path.$node -font] \
- -textvariable Tree::_edit(text)]
- pack $ent -ipadx 8 -anchor w
-
- set idw [$path:cmd create window $x $y -window $frame -anchor w]
- trace variable Tree::_edit(text) w "Tree::_update_edit_size $path $ent $idw $wmax"
- tkwait visibility $ent
- grab $frame
- BWidget::focus set $ent
-
- _update_edit_size $path $ent $idw $wmax
- update
- if { $select } {
- $ent selection range 0 end
- $ent icursor end
- $ent xview end
- }
-
- bind $ent <Escape> {set Tree::_edit(wait) 0}
- bind $ent <Return> {set Tree::_edit(wait) 1}
- if { $clickres == 0 || $clickres == 1 } {
- bind $frame <Button> "set Tree::_edit(wait) $clickres"
- }
-
- set ok 0
- while { !$ok } {
- tkwait variable Tree::_edit(wait)
- if { !$_edit(wait) || $verifycmd == "" ||
- [uplevel \#0 $verifycmd [list $_edit(text)]] } {
- set ok 1
- }
- }
-
- trace vdelete Tree::_edit(text) w "Tree::_update_edit_size $path $ent $idw $wmax"
- grab release $frame
- BWidget::focus release $ent
- destroy $frame
- $path:cmd delete $idw
- $path:cmd itemconfigure $idn -fill $oldfg
- $path:cmd itemconfigure s:$node -fill $sbg -outline $sbg
-
- if { $_edit(wait) } {
- return $_edit(text)
- }
- }
- return ""
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::xview
-# ------------------------------------------------------------------------------
-proc Tree::xview { path args } {
- return [eval $path:cmd xview $args]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::yview
-# ------------------------------------------------------------------------------
-proc Tree::yview { path args } {
- return [eval $path:cmd yview $args]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::_update_edit_size
-# ------------------------------------------------------------------------------
-proc Tree::_update_edit_size { path entry idw wmax args } {
- set entw [winfo reqwidth $entry]
- if { $entw+8 >= $wmax } {
- $path:cmd itemconfigure $idw -width $wmax
- } else {
- $path:cmd itemconfigure $idw -width 0
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::_destroy
-# ------------------------------------------------------------------------------
-proc Tree::_destroy { path } {
- variable $path
- upvar 0 $path data
-
- if { $data(upd,afterid) != "" } {
- after cancel $data(upd,afterid)
- }
- if { $data(dnd,afterid) != "" } {
- after cancel $data(dnd,afterid)
- }
- _subdelete $path [lrange $data(root) 1 end]
- Widget::destroy $path
- unset data
- rename $path {}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::_see
-# ------------------------------------------------------------------------------
-proc Tree::_see { path idn side } {
- set bbox [$path:cmd bbox $idn]
- set scrl [$path:cmd cget -scrollregion]
-
- set ymax [lindex $scrl 3]
- set dy [$path:cmd cget -yscrollincrement]
- set yv [$path yview]
- set yv0 [expr {round([lindex $yv 0]*$ymax/$dy)}]
- set yv1 [expr {round([lindex $yv 1]*$ymax/$dy)}]
- set y [expr {int([lindex [$path:cmd coords $idn] 1]/$dy)}]
- if { $y < $yv0 } {
- $path:cmd yview scroll [expr {$y-$yv0}] units
- } elseif { $y >= $yv1 } {
- $path:cmd yview scroll [expr {$y-$yv1+1}] units
- }
-
- set xmax [lindex $scrl 2]
- set dx [$path:cmd cget -xscrollincrement]
- set xv [$path xview]
- if { ![string compare $side "right"] } {
- set xv1 [expr {round([lindex $xv 1]*$xmax/$dx)}]
- set x1 [expr {int([lindex $bbox 2]/$dx)}]
- if { $x1 >= $xv1 } {
- $path:cmd xview scroll [expr {$x1-$xv1+1}] units
- }
- } else {
- set xv0 [expr {round([lindex $xv 0]*$xmax/$dx)}]
- set x0 [expr {int([lindex $bbox 0]/$dx)}]
- if { $x0 < $xv0 } {
- $path:cmd xview scroll [expr {$x0-$xv0}] units
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::_recexpand
-# ------------------------------------------------------------------------------
-proc Tree::_recexpand { path node expand cmd } {
- variable $path
- upvar 0 $path data
-
- if { [Widget::getoption $path.$node -open] != $expand } {
- Widget::setoption $path.$node -open $expand
- if { $cmd != "" } {
- uplevel \#0 $cmd $node
- }
- }
-
- foreach subnode [lrange $data($node) 1 end] {
- _recexpand $path $subnode $expand $cmd
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::_subdelete
-# ------------------------------------------------------------------------------
-proc Tree::_subdelete { path lnodes } {
- variable $path
- upvar 0 $path data
-
- while { [llength $lnodes] } {
- set lsubnodes [list]
- foreach node $lnodes {
- foreach subnode [lrange $data($node) 1 end] {
- lappend lsubnodes $subnode
- }
- unset data($node)
- if { [set win [Widget::getoption $path.$node -window]] != "" } {
- destroy $win
- }
- Widget::destroy $path.$node
- }
- set lnodes $lsubnodes
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::_update_scrollregion
-# ------------------------------------------------------------------------------
-proc Tree::_update_scrollregion { path } {
- set bd [expr {2*([$path:cmd cget -borderwidth]+[$path:cmd cget -highlightthickness])}]
- set w [expr {[winfo width $path] - $bd}]
- set h [expr {[winfo height $path] - $bd}]
- set xinc [$path:cmd cget -xscrollincrement]
- set yinc [$path:cmd cget -yscrollincrement]
- set bbox [$path:cmd bbox all]
- if { [llength $bbox] } {
- set xs [lindex $bbox 2]
- set ys [lindex $bbox 3]
-
- if { $w < $xs } {
- set w [expr {int($xs)}]
- if { [set r [expr {$w % $xinc}]] } {
- set w [expr {$w+$xinc-$r}]
- }
- }
- if { $h < $ys } {
- set h [expr {int($ys)}]
- if { [set r [expr {$h % $yinc}]] } {
- set h [expr {$h+$yinc-$r}]
- }
- }
- }
-
- $path:cmd configure -scrollregion [list 0 0 $w $h]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::_cross_event
-# ------------------------------------------------------------------------------
-proc Tree::_cross_event { path } {
- variable $path
- upvar 0 $path data
-
- set node [string range [lindex [$path:cmd gettags current] 1] 2 end]
- if { [Widget::getoption $path.$node -open] } {
- if { [set cmd [Widget::getoption $path -closecmd]] != "" } {
- uplevel \#0 $cmd $node
- }
- Widget::setoption $path.$node -open 0
- } else {
- if { [set cmd [Widget::getoption $path -opencmd]] != "" } {
- uplevel \#0 $cmd $node
- }
- Widget::setoption $path.$node -open 1
- }
- _redraw_idle $path 3
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::_draw_node
-# ------------------------------------------------------------------------------
-proc Tree::_draw_node { path node x0 y0 deltax deltay padx showlines } {
- global env
- variable $path
- upvar 0 $path data
-
- set x1 [expr {$x0+$deltax+5}]
- set y1 $y0
- if { $showlines } {
- $path:cmd create line $x0 $y0 $x1 $y0 \
- -fill [Widget::getoption $path -linesfill] \
- -stipple [Widget::getoption $path -linestipple] \
- -tags line
- }
- $path:cmd create text [expr {$x1+$padx}] $y0 \
- -text [Widget::getoption $path.$node -text] \
- -fill [Widget::getoption $path.$node -fill] \
- -font [Widget::getoption $path.$node -font] \
- -anchor w \
- -tags "node n:$node"
- set len [expr {[llength $data($node)] > 1}]
- set dc [Widget::getoption $path.$node -drawcross]
- set exp [Widget::getoption $path.$node -open]
-
- if { $len && $exp } {
- set y1 [_draw_subnodes $path [lrange $data($node) 1 end] \
- [expr {$x0+$deltax}] $y0 $deltax $deltay $padx $showlines]
- }
-
- if { [string compare $dc "never"] && ($len || ![string compare $dc "allways"]) } {
- if { $exp } {
- set bmp [file join $env(BWIDGET_LIBRARY) "images" "minus.xbm"]
- } else {
- set bmp [file join $env(BWIDGET_LIBRARY) "images" "plus.xbm"]
- }
- $path:cmd create bitmap $x0 $y0 \
- -bitmap @$bmp \
- -background [$path:cmd cget -background] \
- -foreground [Widget::getoption $path -linesfill] \
- -tags "cross c:$node" -anchor c
- }
-
- if { [set win [Widget::getoption $path.$node -window]] != "" } {
- $path:cmd create window $x1 $y0 -window $win -anchor w -tags "win i:$node"
- } elseif { [set img [Widget::getoption $path.$node -image]] != "" } {
- $path:cmd create image $x1 $y0 -image $img -anchor w -tags "img i:$node"
- }
- return $y1
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::_draw_subnodes
-# ------------------------------------------------------------------------------
-proc Tree::_draw_subnodes { path nodes x0 y0 deltax deltay padx showlines } {
- set y1 $y0
- foreach node $nodes {
- set yp $y1
- set y1 [_draw_node $path $node $x0 [expr {$y1+$deltay}] $deltax $deltay $padx $showlines]
- }
- if { $showlines && [llength $nodes] } {
- set id [$path:cmd create line $x0 $y0 $x0 [expr {$yp+$deltay}] \
- -fill [Widget::getoption $path -linesfill] \
- -stipple [Widget::getoption $path -linestipple] \
- -tags line]
-
- $path:cmd lower $id
- }
- return $y1
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::_update_nodes
-# ------------------------------------------------------------------------------
-proc Tree::_update_nodes { path } {
- global env
- variable $path
- upvar 0 $path data
-
- set deltax [Widget::getoption $path -deltax]
- set padx [Widget::getoption $path -padx]
- foreach {node flag} $data(upd,nodes) {
- set idn [$path:cmd find withtag "n:$node"]
- if { $idn == "" } {
- continue
- }
- set c [$path:cmd coords $idn]
- set x0 [expr {[lindex $c 0]-$padx}]
- set y0 [lindex $c 1]
- if { $flag & 48 } {
- # -window or -image modified
- set win [Widget::getoption $path.$node -window]
- set img [Widget::getoption $path.$node -image]
- set idi [$path:cmd find withtag i:$node]
- set type [lindex [$path:cmd gettags $idi] 0]
- if { [string length $win] } {
- if { ![string compare $type "win"] } {
- $path:cmd itemconfigure $idi -window $win
- } else {
- $path:cmd delete $idi
- $path:cmd create window $x0 $y0 -window $win -anchor w -tags "win i:$node"
- }
- } elseif { [string length $img] } {
- if { ![string compare $type "img"] } {
- $path:cmd itemconfigure $idi -image $img
- } else {
- $path:cmd delete $idi
- $path:cmd create image $x0 $y0 -image $img -anchor w -tags "img i:$node"
- }
- } else {
- $path:cmd delete $idi
- }
- }
-
- if { $flag & 8 } {
- # -drawcross modified
- set len [expr {[llength $data($node)] > 1}]
- set dc [Widget::getoption $path.$node -drawcross]
- set exp [Widget::getoption $path.$node -open]
- set idc [$path:cmd find withtag c:$node]
-
- if { [string compare $dc "never"] && ($len || ![string compare $dc "allways"]) } {
- if { $exp } {
- set bmp [file join $env(BWIDGET_LIBRARY) "images" "minus.xbm"]
- } else {
- set bmp [file join $env(BWIDGET_LIBRARY) "images" "plus.xbm"]
- }
- if { $idc == "" } {
- $path:cmd create bitmap [expr {$x0-$deltax-5}] $y0 \
- -bitmap @$bmp \
- -background [$path:cmd cget -background] \
- -foreground [Widget::getoption $path -linesfill] \
- -tags "cross c:$node" -anchor c
- } else {
- $path:cmd itemconfigure $idc -bitmap @$bmp
- }
- } else {
- $path:cmd delete $idc
- }
- }
-
- if { $flag & 7 } {
- # -font, -text or -fill modified
- $path:cmd itemconfigure $idn \
- -text [Widget::getoption $path.$node -text] \
- -fill [Widget::getoption $path.$node -fill] \
- -font [Widget::getoption $path.$node -font]
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::_draw_tree
-# ------------------------------------------------------------------------------
-proc Tree::_draw_tree { path } {
- variable $path
- upvar 0 $path data
-
- $path:cmd delete all
- $path:cmd configure -cursor watch
- _draw_subnodes $path [lrange $data(root) 1 end] 8 \
- [expr {-[Widget::getoption $path -deltay]/2}] \
- [Widget::getoption $path -deltax] \
- [Widget::getoption $path -deltay] \
- [Widget::getoption $path -padx] \
- [Widget::getoption $path -showlines]
- $path:cmd configure -cursor [Widget::getoption $path -cursor]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::_redraw_tree
-# ------------------------------------------------------------------------------
-proc Tree::_redraw_tree { path } {
- variable $path
- upvar 0 $path data
-
- if { [Widget::getoption $path -redraw] } {
- if { $data(upd,level) == 2 } {
- _update_nodes $path
- } elseif { $data(upd,level) == 3 } {
- _draw_tree $path
- }
- _redraw_selection $path
- _update_scrollregion $path
- set data(upd,nodes) {}
- set data(upd,level) 0
- set data(upd,afterid) ""
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::_redraw_selection
-# ------------------------------------------------------------------------------
-proc Tree::_redraw_selection { path } {
- variable $path
- upvar 0 $path data
-
- set selbg [Widget::getoption $path -selectbackground]
- set selfg [Widget::getoption $path -selectforeground]
- foreach id [$path:cmd find withtag sel] {
- set node [string range [lindex [$path:cmd gettags $id] 1] 2 end]
- $path:cmd itemconfigure "n:$node" -fill [Widget::getoption $path.$node -fill]
- }
- $path:cmd delete sel
- foreach node $data(selnodes) {
- set bbox [$path:cmd bbox "n:$node"]
- if { [llength $bbox] } {
- set id [eval $path:cmd create rectangle $bbox -fill $selbg -outline $selbg -tags [list "sel s:$node"]]
- $path:cmd itemconfigure "n:$node" -fill $selfg
- $path:cmd lower $id
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::_redraw_idle
-# ------------------------------------------------------------------------------
-proc Tree::_redraw_idle { path level } {
- variable $path
- upvar 0 $path data
-
- if { [Widget::getoption $path -redraw] && $data(upd,afterid) == "" } {
- set data(upd,afterid) [after idle Tree::_redraw_tree $path]
- }
- if { $level > $data(upd,level) } {
- set data(upd,level) $level
- }
- return ""
-}
-
-
-# --------------------------------------------------------------------------------------------
-# Commandes pour le Drag and Drop
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::_init_drag_cmd
-# ------------------------------------------------------------------------------
-proc Tree::_init_drag_cmd { path X Y top } {
- set ltags [$path:cmd gettags current]
- set item [lindex $ltags 0]
- if { ![string compare $item "node"] ||
- ![string compare $item "img"] ||
- ![string compare $item "win"] } {
- set node [string range [lindex $ltags 1] 2 end]
- if { [set cmd [Widget::getoption $path -draginitcmd]] != "" } {
- return [uplevel \#0 $cmd [list $path $node $top]]
- }
- if { [set type [Widget::getoption $path -dragtype]] == "" } {
- set type "TREE_NODE"
- }
- if { [set img [Widget::getoption $path.$node -image]] != "" } {
- pack [label $top.l -image $img -padx 0 -pady 0]
- }
- return [list $type {copy move link} $node]
- }
- return {}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::_drop_cmd
-# ------------------------------------------------------------------------------
-proc Tree::_drop_cmd { path source X Y op type dnddata } {
- variable $path
- upvar 0 $path data
-
- $path:cmd delete drop
- if { [string length $data(dnd,afterid)] } {
- after cancel $data(dnd,afterid)
- set data(dnd,afterid) ""
- }
- set data(dnd,scroll) ""
- if { [llength $data(dnd,node)] } {
- if { [set cmd [Widget::getoption $path -dropcmd]] != "" } {
- return [uplevel \#0 $cmd [list $path $source $data(dnd,node) $op $type $dnddata]]
- }
- }
- return 0
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::_over_cmd
-# ------------------------------------------------------------------------------
-proc Tree::_over_cmd { path source event X Y op type dnddata } {
- variable $path
- upvar 0 $path data
-
- if { ![string compare $event "leave"] } {
- # we leave the window tree
- $path:cmd delete drop
- if { [string length $data(dnd,afterid)] } {
- after cancel $data(dnd,afterid)
- set data(dnd,afterid) ""
- }
- set data(dnd,scroll) ""
- return 0
- }
-
- if { ![string compare $event "enter"] } {
- # we enter the window tree - dnd data initialization
- set mode [Widget::getoption $path -dropovermode]
- set data(dnd,mode) 0
- foreach c {w p n} {
- set data(dnd,mode) [expr {($data(dnd,mode) << 1) | ([string first $c $mode] != -1)}]
- }
- set bbox [$path:cmd bbox all]
- if { [llength $bbox] } {
- set data(dnd,xs) [lindex $bbox 2]
- } else {
- set data(dnd,xs) 0
- }
- set data(dnd,node) {}
- }
-
- set x [expr {$X-[winfo rootx $path]}]
- set y [expr {$Y-[winfo rooty $path]}]
- $path:cmd delete drop
- set data(dnd,node) {}
-
- # test for auto-scroll unless mode is widget only
- if { $data(dnd,mode) != 4 && [_auto_scroll $path $x $y] != "" } {
- return 2
- }
-
- if { $data(dnd,mode) & 4 } {
- # dropovermode includes widget
- set target [list widget]
- set vmode 4
- } else {
- set target [list ""]
- set vmode 0
- }
-
- set xc [$path:cmd canvasx $x]
- set xs $data(dnd,xs)
- if { $xc <= $xs } {
- set yc [$path:cmd canvasy $y]
- set dy [$path:cmd cget -yscrollincrement]
- set line [expr {int($yc/$dy)}]
- set xi 0
- set yi [expr {$line*$dy}]
- set ys [expr {$yi+$dy}]
- foreach id [$path:cmd find overlapping $xi $yi $xs $ys] {
- set ltags [$path:cmd gettags $id]
- set item [lindex $ltags 0]
- if { ![string compare $item "node"] ||
- ![string compare $item "img"] ||
- ![string compare $item "win"] } {
- # item is the label or image/window of the node
- set node [string range [lindex $ltags 1] 2 end]
- set xi [expr {[lindex [$path:cmd coords n:$node] 0]-[Widget::getoption $path -padx]}]
-
- if { $data(dnd,mode) & 1 } {
- # dropovermode includes node
- lappend target $node
- set vmode [expr {$vmode | 1}]
- } else {
- lappend target ""
- }
-
- if { $data(dnd,mode) & 2 } {
- # dropovermode includes position
- if { $yc >= $yi+$dy/2 } {
- # position is after $node
- if { [Widget::getoption $path.$node -open] &&
- [llength $data($node)] > 1 } {
- # $node is open and have subnodes
- # drop position is 0 in children of $node
- set parent $node
- set index 0
- set xli [expr {$xi-5}]
- } else {
- # $node is not open and doesn't have subnodes
- # drop position is after $node in children of parent of $node
- set parent [lindex $data($node) 0]
- set index [lsearch $data($parent) $node]
- set xli [expr {$xi-[Widget::getoption $path -deltax]-5}]
- }
- set yl $ys
- } else {
- # position is before $node
- # drop position is before $node in children of parent of $node
- set parent [lindex $data($node) 0]
- set index [expr {[lsearch $data($parent) $node] - 1}]
- set xli [expr {$xi-[Widget::getoption $path -deltax]-5}]
- set yl $yi
- }
- lappend target [list $parent $index]
- set vmode [expr {$vmode | 2}]
- } else {
- lappend target {}
- }
-
- if { ($vmode & 3) == 3 } {
- # result have both node and position
- # we compute what is the preferred method
- if { $yc-$yi <= 3 || $ys-$yc <= 3 } {
- lappend target "position"
- } else {
- lappend target "node"
- }
- }
- break
- }
- }
- }
-
- if { $vmode && [set cmd [Widget::getoption $path -dropovercmd]] != "" } {
- # user-defined dropover command
- set res [uplevel \#0 $cmd [list $path $source $target $op $type $dnddata]]
- set code [lindex $res 0]
- set newmode 0
- if { $code & 1 } {
- # update vmode
- set mode [lindex $res 1]
- if { ($vmode & 1) && ![string compare $mode "node"] } {
- set newmode 1
- } elseif { ($vmode & 2) && ![string compare $mode "position"] } {
- set newmode 2
- } elseif { ($vmode & 4) && ![string compare $mode "widget"] } {
- set newmode 4
- }
- }
- set vmode $newmode
- } else {
- if { ($vmode & 3) == 3 } {
- # result have both item and position
- # we choose the preferred method
- if { ![string compare [lindex $target 3] "position"] } {
- set vmode [expr {$vmode & ~1}]
- } else {
- set vmode [expr {$vmode & ~2}]
- }
- }
-
- if { $data(dnd,mode) == 4 || $data(dnd,mode) == 0 } {
- # dropovermode is widget or empty - recall is not necessary
- set code 1
- } else {
- set code 3
- }
- }
-
- # draw dnd visual following vmode
- if { $vmode & 1 } {
- set data(dnd,node) [list "node" [lindex $target 1]]
- $path:cmd create rectangle $xi $yi $xs $ys -tags drop
- } elseif { $vmode & 2 } {
- set data(dnd,node) [concat "position" [lindex $target 2]]
- $path:cmd create line $xli [expr {$yl-$dy/2}] $xli $yl $xs $yl -tags drop
- } elseif { $vmode & 4 } {
- set data(dnd,node) [list "widget"]
- } else {
- set code [expr {$code & 2}]
- }
-
- if { $code & 1 } {
- DropSite::setcursor based_arrow_down
- } else {
- DropSite::setcursor dot
- }
- return $code
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::_auto_scroll
-# ------------------------------------------------------------------------------
-proc Tree::_auto_scroll { path x y } {
- variable $path
- upvar 0 $path data
-
- set xmax [winfo width $path]
- set ymax [winfo height $path]
- set scroll {}
- if { $y <= 6 } {
- if { [lindex [$path:cmd yview] 0] > 0 } {
- set scroll [list yview -1]
- DropSite::setcursor sb_up_arrow
- }
- } elseif { $y >= $ymax-6 } {
- if { [lindex [$path:cmd yview] 1] < 1 } {
- set scroll [list yview 1]
- DropSite::setcursor sb_down_arrow
- }
- } elseif { $x <= 6 } {
- if { [lindex [$path:cmd xview] 0] > 0 } {
- set scroll [list xview -1]
- DropSite::setcursor sb_left_arrow
- }
- } elseif { $x >= $xmax-6 } {
- if { [lindex [$path:cmd xview] 1] < 1 } {
- set scroll [list xview 1]
- DropSite::setcursor sb_right_arrow
- }
- }
-
- if { [string length $data(dnd,afterid)] && [string compare $data(dnd,scroll) $scroll] } {
- after cancel $data(dnd,afterid)
- set data(dnd,afterid) ""
- }
-
- set data(dnd,scroll) $scroll
- if { [string length $scroll] && ![string length $data(dnd,afterid)] } {
- set data(dnd,afterid) [after 200 Tree::_scroll $path $scroll]
- }
- return $data(dnd,afterid)
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Tree::_scroll
-# ------------------------------------------------------------------------------
-proc Tree::_scroll { path cmd dir } {
- variable $path
- upvar 0 $path data
-
- if { ($dir == -1 && [lindex [$path:cmd $cmd] 0] > 0) ||
- ($dir == 1 && [lindex [$path:cmd $cmd] 1] < 1) } {
- $path:cmd $cmd scroll $dir units
- set data(dnd,afterid) [after 100 Tree::_scroll $path $cmd $dir]
- } else {
- set data(dnd,afterid) ""
- DropSite::setcursor dot
- }
-}
Copied: grass/trunk/lib/external/bwidget/tree.tcl (from rev 35192, grass/trunk/lib/external/bwidget/tree.tcl)
===================================================================
--- grass/trunk/lib/external/bwidget/tree.tcl (rev 0)
+++ grass/trunk/lib/external/bwidget/tree.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,1389 @@
+# ------------------------------------------------------------------------------
+# tree.tcl
+# This file is part of Unifix BWidget Toolkit
+# $Id$
+# ------------------------------------------------------------------------------
+# Index of commands:
+# - Tree::create
+# - Tree::configure
+# - Tree::cget
+# - Tree::insert
+# - Tree::itemconfigure
+# - Tree::itemcget
+# - Tree::bindText
+# - Tree::bindImage
+# - Tree::delete
+# - Tree::move
+# - Tree::reorder
+# - Tree::selection
+# - Tree::exists
+# - Tree::parent
+# - Tree::index
+# - Tree::nodes
+# - Tree::see
+# - Tree::opentree
+# - Tree::closetree
+# - Tree::edit
+# - Tree::xview
+# - Tree::yview
+# - Tree::_update_edit_size
+# - Tree::_destroy
+# - Tree::_see
+# - Tree::_recexpand
+# - Tree::_subdelete
+# - Tree::_update_scrollregion
+# - Tree::_cross_event
+# - Tree::_draw_node
+# - Tree::_draw_subnodes
+# - Tree::_update_nodes
+# - Tree::_draw_tree
+# - Tree::_redraw_tree
+# - Tree::_redraw_selection
+# - Tree::_redraw_idle
+# - Tree::_drag_cmd
+# - Tree::_drop_cmd
+# - Tree::_over_cmd
+# - Tree::_auto_scroll
+# - Tree::_scroll
+# ------------------------------------------------------------------------------
+
+namespace eval Tree {
+ namespace eval Node {
+ Widget::declare Tree::Node {
+ {-text String "" 0}
+ {-font TkResource "" 0 listbox}
+ {-image TkResource "" 0 label}
+ {-window String "" 0}
+ {-fill TkResource black 0 {listbox -foreground}}
+ {-data String "" 0}
+ {-open Boolean 0 0}
+ {-drawcross Enum auto 0 {auto allways never}}
+ }
+ }
+
+ Widget::tkinclude Tree canvas :cmd \
+ remove {-insertwidth -insertbackground -insertborderwidth -insertofftime \
+ -insertontime -selectborderwidth -closeenough -confine -scrollregion \
+ -xscrollincrement -yscrollincrement -width -height} \
+ initialize {-relief sunken -borderwidth 2 -takefocus 1 \
+ -highlightthickness 1 -width 200}
+
+ Widget::declare Tree {
+ {-deltax Int 10 0 {=0 ""}}
+ {-deltay Int 15 0 {=0 ""}}
+ {-padx Int 20 0 {=0 ""}}
+ {-background TkResource "" 0 listbox}
+ {-selectbackground TkResource "" 0 listbox}
+ {-selectforeground TkResource "" 0 listbox}
+ {-width TkResource "" 0 listbox}
+ {-height TkResource "" 0 listbox}
+ {-showlines Boolean 1 0}
+ {-linesfill TkResource black 0 {frame -background}}
+ {-linestipple TkResource "" 0 {label -bitmap}}
+ {-redraw Boolean 1 0}
+ {-opencmd String "" 0}
+ {-closecmd String "" 0}
+ {-dropovermode Flag "wpn" 0 "wpn"}
+ {-bg Synonym -background}
+ }
+ DragSite::include Tree "TREE_NODE" 1
+ DropSite::include Tree {
+ TREE_NODE {copy {} move {}}
+ }
+
+ Widget::addmap Tree "" :cmd {-deltay -yscrollincrement}
+
+ proc ::Tree { path args } { return [eval Tree::create $path $args] }
+ proc use {} {}
+
+ variable _edit
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::create
+# ------------------------------------------------------------------------------
+proc Tree::create { path args } {
+ variable $path
+ upvar 0 $path data
+
+ Widget::init Tree $path $args
+
+ set data(root) {{}}
+ set data(selnodes) {}
+ set data(upd,level) 0
+ set data(upd,nodes) {}
+ set data(upd,afterid) ""
+ set data(dnd,scroll) ""
+ set data(dnd,afterid) ""
+ set data(dnd,selnodes) {}
+ set data(dnd,node) ""
+
+ set path [eval canvas $path [Widget::subcget $path :cmd] \
+ -width [expr {[Widget::getoption $path -width]*8}] \
+ -height [expr {[Widget::getoption $path -height]*[Widget::getoption $path -deltay]}] \
+ -xscrollincrement 8]
+
+ $path bind cross <ButtonPress-1> {Tree::_cross_event %W}
+ bind $path <Configure> "Tree::_update_scrollregion $path"
+ bind $path <Destroy> "Tree::_destroy $path"
+
+ DragSite::setdrag $path $path Tree::_init_drag_cmd [Widget::getoption $path -dragendcmd] 1
+ DropSite::setdrop $path $path Tree::_over_cmd Tree::_drop_cmd 1
+
+ rename $path ::$path:cmd
+ proc ::$path { cmd args } "return \[eval Tree::\$cmd $path \$args\]"
+
+ return $path
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::configure
+# ------------------------------------------------------------------------------
+proc Tree::configure { path args } {
+ variable $path
+ upvar 0 $path data
+
+ set res [Widget::configure $path $args]
+
+ set ch1 [expr {[Widget::hasChanged $path -deltax val] |
+ [Widget::hasChanged $path -deltay dy] |
+ [Widget::hasChanged $path -padx val] |
+ [Widget::hasChanged $path -showlines val]}]
+
+ set ch2 [expr {[Widget::hasChanged $path -selectbackground val] |
+ [Widget::hasChanged $path -selectforeground val]}]
+
+ if { [Widget::hasChanged $path -linesfill fill] |
+ [Widget::hasChanged $path -linestipple stipple] } {
+ $path:cmd itemconfigure line -fill $fill -stipple $stipple
+ $path:cmd itemconfigure cross -foreground $fill
+ }
+
+ if { $ch1 } {
+ _redraw_idle $path 3
+ } elseif { $ch2 } {
+ _redraw_idle $path 1
+ }
+
+ if { [Widget::hasChanged $path -height h] } {
+ $path:cmd configure -height [expr {$h*$dy}]
+ }
+ if { [Widget::hasChanged $path -width w] } {
+ $path:cmd configure -width [expr {$w*8}]
+ }
+
+ if { [Widget::hasChanged $path -redraw bool] && $bool } {
+ set upd $data(upd,level)
+ set data(upd,level) 0
+ _redraw_idle $path $upd
+ }
+
+ set force [Widget::hasChanged $path -dragendcmd dragend]
+ DragSite::setdrag $path $path Tree::_init_drag_cmd $dragend $force
+ DropSite::setdrop $path $path Tree::_over_cmd Tree::_drop_cmd
+
+ return $res
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::cget
+# ------------------------------------------------------------------------------
+proc Tree::cget { path option } {
+ return [Widget::cget $path $option]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::insert
+# ------------------------------------------------------------------------------
+proc Tree::insert { path index parent node args } {
+ variable $path
+ upvar 0 $path data
+
+ if { [info exists data($node)] } {
+ return -code error "node \"$node\" already exists"
+ }
+ if { ![info exists data($parent)] } {
+ return -code error "node \"$parent\" does not exist"
+ }
+
+ Widget::init Tree::Node $path.$node $args
+ if { ![string compare $index "end"] } {
+ lappend data($parent) $node
+ } else {
+ incr index
+ set data($parent) [linsert $data($parent) $index $node]
+ }
+ set data($node) [list $parent]
+
+ if { ![string compare $parent "root"] } {
+ _redraw_idle $path 3
+ } elseif { [visible $path $parent] } {
+ # parent is visible...
+ if { [Widget::getoption $path.$parent -open] } {
+ # ...and opened -> redraw whole
+ _redraw_idle $path 3
+ } else {
+ # ...and closed -> redraw cross
+ lappend data(upd,nodes) $parent 8
+ _redraw_idle $path 2
+ }
+ }
+ return $node
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::itemconfigure
+# ------------------------------------------------------------------------------
+proc Tree::itemconfigure { path node args } {
+ variable $path
+ upvar 0 $path data
+
+ if { ![string compare $node "root"] || ![info exists data($node)] } {
+ return -code error "node \"$node\" does not exist"
+ }
+
+ set result [Widget::configure $path.$node $args]
+ if { [visible $path $node] } {
+ set lopt {}
+ set flag 0
+ foreach opt {-window -image -drawcross -font -text -fill} {
+ set flag [expr {$flag << 1}]
+ if { [Widget::hasChanged $path.$node $opt val] } {
+ set flag [expr {$flag | 1}]
+ }
+ }
+
+ if { [Widget::hasChanged $path.$node -open val] } {
+ _redraw_idle $path 3
+ } elseif { $data(upd,level) < 3 && $flag } {
+ if { [set idx [lsearch $data(upd,nodes) $node]] == -1 } {
+ lappend data(upd,nodes) $node $flag
+ } else {
+ incr idx
+ set flag [expr {[lindex $data(upd,nodes) $idx] | $flag}]
+ set data(upd,nodes) [lreplace $data(upd,nodes) $idx $idx $flag]
+ }
+ _redraw_idle $path 2
+ }
+ }
+ return $result
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::itemcget
+# ------------------------------------------------------------------------------
+proc Tree::itemcget { path node option } {
+ variable $path
+ upvar 0 $path data
+
+ if { ![string compare $node "root"] || ![info exists data($node)] } {
+ return -code error "node \"$node\" does not exist"
+ }
+
+ return [Widget::cget $path.$node $option]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::bindText
+# ------------------------------------------------------------------------------
+proc Tree::bindText { path event script } {
+ if { $script != "" } {
+ $path:cmd bind "node" $event \
+ "$script \[string range \[lindex \[$path:cmd gettags current\] 1\] 2 end\]"
+ } else {
+ $path:cmd bind "node" $event {}
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::bindImage
+# ------------------------------------------------------------------------------
+proc Tree::bindImage { path event script } {
+ if { $script != "" } {
+ $path:cmd bind "img" $event \
+ "$script \[string range \[lindex \[$path:cmd gettags current\] 1\] 2 end\]"
+ } else {
+ $path:cmd bind "img" $event {}
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::delete
+# ------------------------------------------------------------------------------
+proc Tree::delete { path args } {
+ variable $path
+ upvar 0 $path data
+
+ foreach lnodes $args {
+ foreach node $lnodes {
+ if { [string compare $node "root"] && [info exists data($node)] } {
+ set parent [lindex $data($node) 0]
+ set idx [lsearch $data($parent) $node]
+ set data($parent) [lreplace $data($parent) $idx $idx]
+ _subdelete $path [list $node]
+ }
+ }
+ }
+
+ set sel $data(selnodes)
+ set data(selnodes) {}
+ eval selection $path set $sel
+ _redraw_idle $path 3
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::move
+# ------------------------------------------------------------------------------
+proc Tree::move { path parent node index } {
+ variable $path
+ upvar 0 $path data
+
+ if { ![string compare $node "root"] || ![info exists data($node)] } {
+ return -code error "node \"$node\" does not exist"
+ }
+ if { ![info exists data($parent)] } {
+ return -code error "node \"$parent\" does not exist"
+ }
+ set p $parent
+ while { [string compare $p "root"] } {
+ if { ![string compare $p $node] } {
+ return -code error "node \"$parent\" is a descendant of \"$node\""
+ }
+ set p [parent $path $p]
+ }
+
+ set oldp [lindex $data($node) 0]
+ set idx [lsearch $data($oldp) $node]
+ set data($oldp) [lreplace $data($oldp) $idx $idx]
+ set data($node) [concat [list $parent] [lrange $data($node) 1 end]]
+ if { ![string compare $index "end"] } {
+ lappend data($parent) $node
+ } else {
+ incr index
+ set data($parent) [linsert $data($parent) $index $node]
+ }
+ if { (![string compare $oldp "root"] ||
+ ([visible $path $oldp] && [Widget::getoption $path.$oldp -open])) ||
+ (![string compare $parent "root"] ||
+ ([visible $path $parent] && [Widget::getoption $path.$parent -open])) } {
+ _redraw_idle $path 3
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::reorder
+# ------------------------------------------------------------------------------
+proc Tree::reorder { path node neworder } {
+ variable $path
+ upvar 0 $path data
+
+ if { ![info exists data($node)] } {
+ return -code error "node \"$node\" does not exist"
+ }
+ set children [lrange $data($node) 1 end]
+ if { [llength $children] } {
+ set children [BWidget::lreorder $children $neworder]
+ set data($node) [linsert $children 0 [lindex $data($node) 0]]
+ if { [visible $path $node] && [Widget::getoption $path.$node -open] } {
+ _redraw_idle $path 3
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::selection
+# ------------------------------------------------------------------------------
+proc Tree::selection { path cmd args } {
+ variable $path
+ upvar 0 $path data
+
+ switch -- $cmd {
+ set {
+ set data(selnodes) {}
+ foreach node $args {
+ if { [info exists data($node)] } {
+ if { [lsearch $data(selnodes) $node] == -1 } {
+ lappend data(selnodes) $node
+ }
+ }
+ }
+ }
+ add {
+ foreach node $args {
+ if { [info exists data($node)] } {
+ if { [lsearch $data(selnodes) $node] == -1 } {
+ lappend data(selnodes) $node
+ }
+ }
+ }
+ }
+ remove {
+ foreach node $args {
+ if { [set idx [lsearch $data(selnodes) $node]] != -1 } {
+ set data(selnodes) [lreplace $data(selnodes) $idx $idx]
+ }
+ }
+ }
+ clear {
+ set data(selnodes) {}
+ }
+ get {
+ return $data(selnodes)
+ }
+ default {
+ return
+ }
+ }
+ _redraw_idle $path 1
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::exists
+# ------------------------------------------------------------------------------
+proc Tree::exists { path node } {
+ variable $path
+ upvar 0 $path data
+
+ return [info exists data($node)]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::visible
+# ------------------------------------------------------------------------------
+proc Tree::visible { path node } {
+ set idn [$path:cmd find withtag n:$node]
+ return [llength $idn]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::parent
+# ------------------------------------------------------------------------------
+proc Tree::parent { path node } {
+ variable $path
+ upvar 0 $path data
+
+ if { ![info exists data($node)] } {
+ return -code error "node \"$node\" does not exist"
+ }
+ return [lindex $data($node) 0]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::index
+# ------------------------------------------------------------------------------
+proc Tree::index { path node } {
+ variable $path
+ upvar 0 $path data
+
+ if { ![string compare $node "root"] || ![info exists data($node)] } {
+ return -code error "node \"$node\" does not exist"
+ }
+ set parent [lindex $data($node) 0]
+ return [expr {[lsearch $data($parent) $node] - 1}]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::nodes
+# ------------------------------------------------------------------------------
+proc Tree::nodes { path node {first ""} {last ""} } {
+ variable $path
+ upvar 0 $path data
+
+ if { ![info exists data($node)] } {
+ return -code error "node \"$node\" does not exist"
+ }
+
+ if { ![string length $first] } {
+ return [lrange $data($node) 1 end]
+ }
+
+ if { ![string length $last] } {
+ return [lindex [lrange $data($node) 1 end] $first]
+ } else {
+ return [lrange [lrange $data($node) 1 end] $first $last]
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::see
+# ------------------------------------------------------------------------------
+proc Tree::see { path node } {
+ variable $path
+ upvar 0 $path data
+
+ if { [Widget::getoption $path -redraw] && $data(upd,afterid) != "" } {
+ after cancel $data(upd,afterid)
+ _redraw_tree $path
+ }
+ set idn [$path:cmd find withtag n:$node]
+ if { $idn != "" } {
+ Tree::_see $path $idn right
+ Tree::_see $path $idn left
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::opentree
+# ------------------------------------------------------------------------------
+proc Tree::opentree { path node } {
+ variable $path
+ upvar 0 $path data
+
+ if { ![string compare $node "root"] || ![info exists data($node)] } {
+ return -code error "node \"$node\" does not exist"
+ }
+
+ _recexpand $path $node 1 [Widget::getoption $path -opencmd]
+ _redraw_idle $path 3
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::closetree
+# ------------------------------------------------------------------------------
+proc Tree::closetree { path node } {
+ variable $path
+ upvar 0 $path data
+
+ if { ![string compare $node "root"] || ![info exists data($node)] } {
+ return -code error "node \"$node\" does not exist"
+ }
+
+ _recexpand $path $node 0 [Widget::getoption $path -closecmd]
+ _redraw_idle $path 3
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::edit
+# ------------------------------------------------------------------------------
+proc Tree::edit { path node text {verifycmd ""} {clickres 0} {select 1}} {
+ variable _edit
+ variable $path
+ upvar 0 $path data
+
+ if { [Widget::getoption $path -redraw] && $data(upd,afterid) != "" } {
+ after cancel $data(upd,afterid)
+ _redraw_tree $path
+ }
+ set idn [$path:cmd find withtag n:$node]
+ if { $idn != "" } {
+ Tree::_see $path $idn right
+ Tree::_see $path $idn left
+
+ set oldfg [$path:cmd itemcget $idn -fill]
+ set sbg [Widget::getoption $path -selectbackground]
+ set coords [$path:cmd coords $idn]
+ set x [lindex $coords 0]
+ set y [lindex $coords 1]
+ set bd [expr {[$path:cmd cget -borderwidth]+[$path:cmd cget -highlightthickness]}]
+ set w [expr {[winfo width $path] - 2*$bd}]
+ set wmax [expr {[$path:cmd canvasx $w]-$x}]
+
+ set _edit(text) $text
+ set _edit(wait) 0
+
+ $path:cmd itemconfigure $idn -fill [Widget::getoption $path -background]
+ $path:cmd itemconfigure s:$node -fill {} -outline {}
+
+ set frame [frame $path.edit \
+ -relief flat -borderwidth 0 -highlightthickness 0 \
+ -background [Widget::getoption $path -background]]
+ set ent [entry $frame.edit \
+ -width 0 \
+ -relief solid \
+ -borderwidth 1 \
+ -highlightthickness 0 \
+ -foreground [Widget::getoption $path.$node -fill] \
+ -background [Widget::getoption $path -background] \
+ -selectforeground [Widget::getoption $path -selectforeground] \
+ -selectbackground $sbg \
+ -font [Widget::getoption $path.$node -font] \
+ -textvariable Tree::_edit(text)]
+ pack $ent -ipadx 8 -anchor w
+
+ set idw [$path:cmd create window $x $y -window $frame -anchor w]
+ trace variable Tree::_edit(text) w "Tree::_update_edit_size $path $ent $idw $wmax"
+ tkwait visibility $ent
+ grab $frame
+ BWidget::focus set $ent
+
+ _update_edit_size $path $ent $idw $wmax
+ update
+ if { $select } {
+ $ent selection range 0 end
+ $ent icursor end
+ $ent xview end
+ }
+
+ bind $ent <Escape> {set Tree::_edit(wait) 0}
+ bind $ent <Return> {set Tree::_edit(wait) 1}
+ if { $clickres == 0 || $clickres == 1 } {
+ bind $frame <Button> "set Tree::_edit(wait) $clickres"
+ }
+
+ set ok 0
+ while { !$ok } {
+ tkwait variable Tree::_edit(wait)
+ if { !$_edit(wait) || $verifycmd == "" ||
+ [uplevel \#0 $verifycmd [list $_edit(text)]] } {
+ set ok 1
+ }
+ }
+
+ trace vdelete Tree::_edit(text) w "Tree::_update_edit_size $path $ent $idw $wmax"
+ grab release $frame
+ BWidget::focus release $ent
+ destroy $frame
+ $path:cmd delete $idw
+ $path:cmd itemconfigure $idn -fill $oldfg
+ $path:cmd itemconfigure s:$node -fill $sbg -outline $sbg
+
+ if { $_edit(wait) } {
+ return $_edit(text)
+ }
+ }
+ return ""
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::xview
+# ------------------------------------------------------------------------------
+proc Tree::xview { path args } {
+ return [eval $path:cmd xview $args]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::yview
+# ------------------------------------------------------------------------------
+proc Tree::yview { path args } {
+ return [eval $path:cmd yview $args]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::_update_edit_size
+# ------------------------------------------------------------------------------
+proc Tree::_update_edit_size { path entry idw wmax args } {
+ set entw [winfo reqwidth $entry]
+ if { $entw+8 >= $wmax } {
+ $path:cmd itemconfigure $idw -width $wmax
+ } else {
+ $path:cmd itemconfigure $idw -width 0
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::_destroy
+# ------------------------------------------------------------------------------
+proc Tree::_destroy { path } {
+ variable $path
+ upvar 0 $path data
+
+ if { $data(upd,afterid) != "" } {
+ after cancel $data(upd,afterid)
+ }
+ if { $data(dnd,afterid) != "" } {
+ after cancel $data(dnd,afterid)
+ }
+ _subdelete $path [lrange $data(root) 1 end]
+ Widget::destroy $path
+ unset data
+ rename $path {}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::_see
+# ------------------------------------------------------------------------------
+proc Tree::_see { path idn side } {
+ set bbox [$path:cmd bbox $idn]
+ set scrl [$path:cmd cget -scrollregion]
+
+ set ymax [lindex $scrl 3]
+ set dy [$path:cmd cget -yscrollincrement]
+ set yv [$path yview]
+ set yv0 [expr {round([lindex $yv 0]*$ymax/$dy)}]
+ set yv1 [expr {round([lindex $yv 1]*$ymax/$dy)}]
+ set y [expr {int([lindex [$path:cmd coords $idn] 1]/$dy)}]
+ if { $y < $yv0 } {
+ $path:cmd yview scroll [expr {$y-$yv0}] units
+ } elseif { $y >= $yv1 } {
+ $path:cmd yview scroll [expr {$y-$yv1+1}] units
+ }
+
+ set xmax [lindex $scrl 2]
+ set dx [$path:cmd cget -xscrollincrement]
+ set xv [$path xview]
+ if { ![string compare $side "right"] } {
+ set xv1 [expr {round([lindex $xv 1]*$xmax/$dx)}]
+ set x1 [expr {int([lindex $bbox 2]/$dx)}]
+ if { $x1 >= $xv1 } {
+ $path:cmd xview scroll [expr {$x1-$xv1+1}] units
+ }
+ } else {
+ set xv0 [expr {round([lindex $xv 0]*$xmax/$dx)}]
+ set x0 [expr {int([lindex $bbox 0]/$dx)}]
+ if { $x0 < $xv0 } {
+ $path:cmd xview scroll [expr {$x0-$xv0}] units
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::_recexpand
+# ------------------------------------------------------------------------------
+proc Tree::_recexpand { path node expand cmd } {
+ variable $path
+ upvar 0 $path data
+
+ if { [Widget::getoption $path.$node -open] != $expand } {
+ Widget::setoption $path.$node -open $expand
+ if { $cmd != "" } {
+ uplevel \#0 $cmd $node
+ }
+ }
+
+ foreach subnode [lrange $data($node) 1 end] {
+ _recexpand $path $subnode $expand $cmd
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::_subdelete
+# ------------------------------------------------------------------------------
+proc Tree::_subdelete { path lnodes } {
+ variable $path
+ upvar 0 $path data
+
+ while { [llength $lnodes] } {
+ set lsubnodes [list]
+ foreach node $lnodes {
+ foreach subnode [lrange $data($node) 1 end] {
+ lappend lsubnodes $subnode
+ }
+ unset data($node)
+ if { [set win [Widget::getoption $path.$node -window]] != "" } {
+ destroy $win
+ }
+ Widget::destroy $path.$node
+ }
+ set lnodes $lsubnodes
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::_update_scrollregion
+# ------------------------------------------------------------------------------
+proc Tree::_update_scrollregion { path } {
+ set bd [expr {2*([$path:cmd cget -borderwidth]+[$path:cmd cget -highlightthickness])}]
+ set w [expr {[winfo width $path] - $bd}]
+ set h [expr {[winfo height $path] - $bd}]
+ set xinc [$path:cmd cget -xscrollincrement]
+ set yinc [$path:cmd cget -yscrollincrement]
+ set bbox [$path:cmd bbox all]
+ if { [llength $bbox] } {
+ set xs [lindex $bbox 2]
+ set ys [lindex $bbox 3]
+
+ if { $w < $xs } {
+ set w [expr {int($xs)}]
+ if { [set r [expr {$w % $xinc}]] } {
+ set w [expr {$w+$xinc-$r}]
+ }
+ }
+ if { $h < $ys } {
+ set h [expr {int($ys)}]
+ if { [set r [expr {$h % $yinc}]] } {
+ set h [expr {$h+$yinc-$r}]
+ }
+ }
+ }
+
+ $path:cmd configure -scrollregion [list 0 0 $w $h]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::_cross_event
+# ------------------------------------------------------------------------------
+proc Tree::_cross_event { path } {
+ variable $path
+ upvar 0 $path data
+
+ set node [string range [lindex [$path:cmd gettags current] 1] 2 end]
+ if { [Widget::getoption $path.$node -open] } {
+ if { [set cmd [Widget::getoption $path -closecmd]] != "" } {
+ uplevel \#0 $cmd $node
+ }
+ Widget::setoption $path.$node -open 0
+ } else {
+ if { [set cmd [Widget::getoption $path -opencmd]] != "" } {
+ uplevel \#0 $cmd $node
+ }
+ Widget::setoption $path.$node -open 1
+ }
+ _redraw_idle $path 3
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::_draw_node
+# ------------------------------------------------------------------------------
+proc Tree::_draw_node { path node x0 y0 deltax deltay padx showlines } {
+ global env
+ variable $path
+ upvar 0 $path data
+
+ set x1 [expr {$x0+$deltax+5}]
+ set y1 $y0
+ if { $showlines } {
+ $path:cmd create line $x0 $y0 $x1 $y0 \
+ -fill [Widget::getoption $path -linesfill] \
+ -stipple [Widget::getoption $path -linestipple] \
+ -tags line
+ }
+ $path:cmd create text [expr {$x1+$padx}] $y0 \
+ -text [Widget::getoption $path.$node -text] \
+ -fill [Widget::getoption $path.$node -fill] \
+ -font [Widget::getoption $path.$node -font] \
+ -anchor w \
+ -tags "node n:$node"
+ set len [expr {[llength $data($node)] > 1}]
+ set dc [Widget::getoption $path.$node -drawcross]
+ set exp [Widget::getoption $path.$node -open]
+
+ if { $len && $exp } {
+ set y1 [_draw_subnodes $path [lrange $data($node) 1 end] \
+ [expr {$x0+$deltax}] $y0 $deltax $deltay $padx $showlines]
+ }
+
+ if { [string compare $dc "never"] && ($len || ![string compare $dc "allways"]) } {
+ if { $exp } {
+ set bmp [file join $env(BWIDGET_LIBRARY) "images" "minus.xbm"]
+ } else {
+ set bmp [file join $env(BWIDGET_LIBRARY) "images" "plus.xbm"]
+ }
+ $path:cmd create bitmap $x0 $y0 \
+ -bitmap @$bmp \
+ -background [$path:cmd cget -background] \
+ -foreground [Widget::getoption $path -linesfill] \
+ -tags "cross c:$node" -anchor c
+ }
+
+ if { [set win [Widget::getoption $path.$node -window]] != "" } {
+ $path:cmd create window $x1 $y0 -window $win -anchor w -tags "win i:$node"
+ } elseif { [set img [Widget::getoption $path.$node -image]] != "" } {
+ $path:cmd create image $x1 $y0 -image $img -anchor w -tags "img i:$node"
+ }
+ return $y1
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::_draw_subnodes
+# ------------------------------------------------------------------------------
+proc Tree::_draw_subnodes { path nodes x0 y0 deltax deltay padx showlines } {
+ set y1 $y0
+ foreach node $nodes {
+ set yp $y1
+ set y1 [_draw_node $path $node $x0 [expr {$y1+$deltay}] $deltax $deltay $padx $showlines]
+ }
+ if { $showlines && [llength $nodes] } {
+ set id [$path:cmd create line $x0 $y0 $x0 [expr {$yp+$deltay}] \
+ -fill [Widget::getoption $path -linesfill] \
+ -stipple [Widget::getoption $path -linestipple] \
+ -tags line]
+
+ $path:cmd lower $id
+ }
+ return $y1
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::_update_nodes
+# ------------------------------------------------------------------------------
+proc Tree::_update_nodes { path } {
+ global env
+ variable $path
+ upvar 0 $path data
+
+ set deltax [Widget::getoption $path -deltax]
+ set padx [Widget::getoption $path -padx]
+ foreach {node flag} $data(upd,nodes) {
+ set idn [$path:cmd find withtag "n:$node"]
+ if { $idn == "" } {
+ continue
+ }
+ set c [$path:cmd coords $idn]
+ set x0 [expr {[lindex $c 0]-$padx}]
+ set y0 [lindex $c 1]
+ if { $flag & 48 } {
+ # -window or -image modified
+ set win [Widget::getoption $path.$node -window]
+ set img [Widget::getoption $path.$node -image]
+ set idi [$path:cmd find withtag i:$node]
+ set type [lindex [$path:cmd gettags $idi] 0]
+ if { [string length $win] } {
+ if { ![string compare $type "win"] } {
+ $path:cmd itemconfigure $idi -window $win
+ } else {
+ $path:cmd delete $idi
+ $path:cmd create window $x0 $y0 -window $win -anchor w -tags "win i:$node"
+ }
+ } elseif { [string length $img] } {
+ if { ![string compare $type "img"] } {
+ $path:cmd itemconfigure $idi -image $img
+ } else {
+ $path:cmd delete $idi
+ $path:cmd create image $x0 $y0 -image $img -anchor w -tags "img i:$node"
+ }
+ } else {
+ $path:cmd delete $idi
+ }
+ }
+
+ if { $flag & 8 } {
+ # -drawcross modified
+ set len [expr {[llength $data($node)] > 1}]
+ set dc [Widget::getoption $path.$node -drawcross]
+ set exp [Widget::getoption $path.$node -open]
+ set idc [$path:cmd find withtag c:$node]
+
+ if { [string compare $dc "never"] && ($len || ![string compare $dc "allways"]) } {
+ if { $exp } {
+ set bmp [file join $env(BWIDGET_LIBRARY) "images" "minus.xbm"]
+ } else {
+ set bmp [file join $env(BWIDGET_LIBRARY) "images" "plus.xbm"]
+ }
+ if { $idc == "" } {
+ $path:cmd create bitmap [expr {$x0-$deltax-5}] $y0 \
+ -bitmap @$bmp \
+ -background [$path:cmd cget -background] \
+ -foreground [Widget::getoption $path -linesfill] \
+ -tags "cross c:$node" -anchor c
+ } else {
+ $path:cmd itemconfigure $idc -bitmap @$bmp
+ }
+ } else {
+ $path:cmd delete $idc
+ }
+ }
+
+ if { $flag & 7 } {
+ # -font, -text or -fill modified
+ $path:cmd itemconfigure $idn \
+ -text [Widget::getoption $path.$node -text] \
+ -fill [Widget::getoption $path.$node -fill] \
+ -font [Widget::getoption $path.$node -font]
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::_draw_tree
+# ------------------------------------------------------------------------------
+proc Tree::_draw_tree { path } {
+ variable $path
+ upvar 0 $path data
+
+ $path:cmd delete all
+ $path:cmd configure -cursor watch
+ _draw_subnodes $path [lrange $data(root) 1 end] 8 \
+ [expr {-[Widget::getoption $path -deltay]/2}] \
+ [Widget::getoption $path -deltax] \
+ [Widget::getoption $path -deltay] \
+ [Widget::getoption $path -padx] \
+ [Widget::getoption $path -showlines]
+ $path:cmd configure -cursor [Widget::getoption $path -cursor]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::_redraw_tree
+# ------------------------------------------------------------------------------
+proc Tree::_redraw_tree { path } {
+ variable $path
+ upvar 0 $path data
+
+ if { [Widget::getoption $path -redraw] } {
+ if { $data(upd,level) == 2 } {
+ _update_nodes $path
+ } elseif { $data(upd,level) == 3 } {
+ _draw_tree $path
+ }
+ _redraw_selection $path
+ _update_scrollregion $path
+ set data(upd,nodes) {}
+ set data(upd,level) 0
+ set data(upd,afterid) ""
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::_redraw_selection
+# ------------------------------------------------------------------------------
+proc Tree::_redraw_selection { path } {
+ variable $path
+ upvar 0 $path data
+
+ set selbg [Widget::getoption $path -selectbackground]
+ set selfg [Widget::getoption $path -selectforeground]
+ foreach id [$path:cmd find withtag sel] {
+ set node [string range [lindex [$path:cmd gettags $id] 1] 2 end]
+ $path:cmd itemconfigure "n:$node" -fill [Widget::getoption $path.$node -fill]
+ }
+ $path:cmd delete sel
+ foreach node $data(selnodes) {
+ set bbox [$path:cmd bbox "n:$node"]
+ if { [llength $bbox] } {
+ set id [eval $path:cmd create rectangle $bbox -fill $selbg -outline $selbg -tags [list "sel s:$node"]]
+ $path:cmd itemconfigure "n:$node" -fill $selfg
+ $path:cmd lower $id
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::_redraw_idle
+# ------------------------------------------------------------------------------
+proc Tree::_redraw_idle { path level } {
+ variable $path
+ upvar 0 $path data
+
+ if { [Widget::getoption $path -redraw] && $data(upd,afterid) == "" } {
+ set data(upd,afterid) [after idle Tree::_redraw_tree $path]
+ }
+ if { $level > $data(upd,level) } {
+ set data(upd,level) $level
+ }
+ return ""
+}
+
+
+# --------------------------------------------------------------------------------------------
+# Commandes pour le Drag and Drop
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::_init_drag_cmd
+# ------------------------------------------------------------------------------
+proc Tree::_init_drag_cmd { path X Y top } {
+ set ltags [$path:cmd gettags current]
+ set item [lindex $ltags 0]
+ if { ![string compare $item "node"] ||
+ ![string compare $item "img"] ||
+ ![string compare $item "win"] } {
+ set node [string range [lindex $ltags 1] 2 end]
+ if { [set cmd [Widget::getoption $path -draginitcmd]] != "" } {
+ return [uplevel \#0 $cmd [list $path $node $top]]
+ }
+ if { [set type [Widget::getoption $path -dragtype]] == "" } {
+ set type "TREE_NODE"
+ }
+ if { [set img [Widget::getoption $path.$node -image]] != "" } {
+ pack [label $top.l -image $img -padx 0 -pady 0]
+ }
+ return [list $type {copy move link} $node]
+ }
+ return {}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::_drop_cmd
+# ------------------------------------------------------------------------------
+proc Tree::_drop_cmd { path source X Y op type dnddata } {
+ variable $path
+ upvar 0 $path data
+
+ $path:cmd delete drop
+ if { [string length $data(dnd,afterid)] } {
+ after cancel $data(dnd,afterid)
+ set data(dnd,afterid) ""
+ }
+ set data(dnd,scroll) ""
+ if { [llength $data(dnd,node)] } {
+ if { [set cmd [Widget::getoption $path -dropcmd]] != "" } {
+ return [uplevel \#0 $cmd [list $path $source $data(dnd,node) $op $type $dnddata]]
+ }
+ }
+ return 0
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::_over_cmd
+# ------------------------------------------------------------------------------
+proc Tree::_over_cmd { path source event X Y op type dnddata } {
+ variable $path
+ upvar 0 $path data
+
+ if { ![string compare $event "leave"] } {
+ # we leave the window tree
+ $path:cmd delete drop
+ if { [string length $data(dnd,afterid)] } {
+ after cancel $data(dnd,afterid)
+ set data(dnd,afterid) ""
+ }
+ set data(dnd,scroll) ""
+ return 0
+ }
+
+ if { ![string compare $event "enter"] } {
+ # we enter the window tree - dnd data initialization
+ set mode [Widget::getoption $path -dropovermode]
+ set data(dnd,mode) 0
+ foreach c {w p n} {
+ set data(dnd,mode) [expr {($data(dnd,mode) << 1) | ([string first $c $mode] != -1)}]
+ }
+ set bbox [$path:cmd bbox all]
+ if { [llength $bbox] } {
+ set data(dnd,xs) [lindex $bbox 2]
+ } else {
+ set data(dnd,xs) 0
+ }
+ set data(dnd,node) {}
+ }
+
+ set x [expr {$X-[winfo rootx $path]}]
+ set y [expr {$Y-[winfo rooty $path]}]
+ $path:cmd delete drop
+ set data(dnd,node) {}
+
+ # test for auto-scroll unless mode is widget only
+ if { $data(dnd,mode) != 4 && [_auto_scroll $path $x $y] != "" } {
+ return 2
+ }
+
+ if { $data(dnd,mode) & 4 } {
+ # dropovermode includes widget
+ set target [list widget]
+ set vmode 4
+ } else {
+ set target [list ""]
+ set vmode 0
+ }
+
+ set xc [$path:cmd canvasx $x]
+ set xs $data(dnd,xs)
+ if { $xc <= $xs } {
+ set yc [$path:cmd canvasy $y]
+ set dy [$path:cmd cget -yscrollincrement]
+ set line [expr {int($yc/$dy)}]
+ set xi 0
+ set yi [expr {$line*$dy}]
+ set ys [expr {$yi+$dy}]
+ foreach id [$path:cmd find overlapping $xi $yi $xs $ys] {
+ set ltags [$path:cmd gettags $id]
+ set item [lindex $ltags 0]
+ if { ![string compare $item "node"] ||
+ ![string compare $item "img"] ||
+ ![string compare $item "win"] } {
+ # item is the label or image/window of the node
+ set node [string range [lindex $ltags 1] 2 end]
+ set xi [expr {[lindex [$path:cmd coords n:$node] 0]-[Widget::getoption $path -padx]}]
+
+ if { $data(dnd,mode) & 1 } {
+ # dropovermode includes node
+ lappend target $node
+ set vmode [expr {$vmode | 1}]
+ } else {
+ lappend target ""
+ }
+
+ if { $data(dnd,mode) & 2 } {
+ # dropovermode includes position
+ if { $yc >= $yi+$dy/2 } {
+ # position is after $node
+ if { [Widget::getoption $path.$node -open] &&
+ [llength $data($node)] > 1 } {
+ # $node is open and have subnodes
+ # drop position is 0 in children of $node
+ set parent $node
+ set index 0
+ set xli [expr {$xi-5}]
+ } else {
+ # $node is not open and doesn't have subnodes
+ # drop position is after $node in children of parent of $node
+ set parent [lindex $data($node) 0]
+ set index [lsearch $data($parent) $node]
+ set xli [expr {$xi-[Widget::getoption $path -deltax]-5}]
+ }
+ set yl $ys
+ } else {
+ # position is before $node
+ # drop position is before $node in children of parent of $node
+ set parent [lindex $data($node) 0]
+ set index [expr {[lsearch $data($parent) $node] - 1}]
+ set xli [expr {$xi-[Widget::getoption $path -deltax]-5}]
+ set yl $yi
+ }
+ lappend target [list $parent $index]
+ set vmode [expr {$vmode | 2}]
+ } else {
+ lappend target {}
+ }
+
+ if { ($vmode & 3) == 3 } {
+ # result have both node and position
+ # we compute what is the preferred method
+ if { $yc-$yi <= 3 || $ys-$yc <= 3 } {
+ lappend target "position"
+ } else {
+ lappend target "node"
+ }
+ }
+ break
+ }
+ }
+ }
+
+ if { $vmode && [set cmd [Widget::getoption $path -dropovercmd]] != "" } {
+ # user-defined dropover command
+ set res [uplevel \#0 $cmd [list $path $source $target $op $type $dnddata]]
+ set code [lindex $res 0]
+ set newmode 0
+ if { $code & 1 } {
+ # update vmode
+ set mode [lindex $res 1]
+ if { ($vmode & 1) && ![string compare $mode "node"] } {
+ set newmode 1
+ } elseif { ($vmode & 2) && ![string compare $mode "position"] } {
+ set newmode 2
+ } elseif { ($vmode & 4) && ![string compare $mode "widget"] } {
+ set newmode 4
+ }
+ }
+ set vmode $newmode
+ } else {
+ if { ($vmode & 3) == 3 } {
+ # result have both item and position
+ # we choose the preferred method
+ if { ![string compare [lindex $target 3] "position"] } {
+ set vmode [expr {$vmode & ~1}]
+ } else {
+ set vmode [expr {$vmode & ~2}]
+ }
+ }
+
+ if { $data(dnd,mode) == 4 || $data(dnd,mode) == 0 } {
+ # dropovermode is widget or empty - recall is not necessary
+ set code 1
+ } else {
+ set code 3
+ }
+ }
+
+ # draw dnd visual following vmode
+ if { $vmode & 1 } {
+ set data(dnd,node) [list "node" [lindex $target 1]]
+ $path:cmd create rectangle $xi $yi $xs $ys -tags drop
+ } elseif { $vmode & 2 } {
+ set data(dnd,node) [concat "position" [lindex $target 2]]
+ $path:cmd create line $xli [expr {$yl-$dy/2}] $xli $yl $xs $yl -tags drop
+ } elseif { $vmode & 4 } {
+ set data(dnd,node) [list "widget"]
+ } else {
+ set code [expr {$code & 2}]
+ }
+
+ if { $code & 1 } {
+ DropSite::setcursor based_arrow_down
+ } else {
+ DropSite::setcursor dot
+ }
+ return $code
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::_auto_scroll
+# ------------------------------------------------------------------------------
+proc Tree::_auto_scroll { path x y } {
+ variable $path
+ upvar 0 $path data
+
+ set xmax [winfo width $path]
+ set ymax [winfo height $path]
+ set scroll {}
+ if { $y <= 6 } {
+ if { [lindex [$path:cmd yview] 0] > 0 } {
+ set scroll [list yview -1]
+ DropSite::setcursor sb_up_arrow
+ }
+ } elseif { $y >= $ymax-6 } {
+ if { [lindex [$path:cmd yview] 1] < 1 } {
+ set scroll [list yview 1]
+ DropSite::setcursor sb_down_arrow
+ }
+ } elseif { $x <= 6 } {
+ if { [lindex [$path:cmd xview] 0] > 0 } {
+ set scroll [list xview -1]
+ DropSite::setcursor sb_left_arrow
+ }
+ } elseif { $x >= $xmax-6 } {
+ if { [lindex [$path:cmd xview] 1] < 1 } {
+ set scroll [list xview 1]
+ DropSite::setcursor sb_right_arrow
+ }
+ }
+
+ if { [string length $data(dnd,afterid)] && [string compare $data(dnd,scroll) $scroll] } {
+ after cancel $data(dnd,afterid)
+ set data(dnd,afterid) ""
+ }
+
+ set data(dnd,scroll) $scroll
+ if { [string length $scroll] && ![string length $data(dnd,afterid)] } {
+ set data(dnd,afterid) [after 200 Tree::_scroll $path $scroll]
+ }
+ return $data(dnd,afterid)
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Tree::_scroll
+# ------------------------------------------------------------------------------
+proc Tree::_scroll { path cmd dir } {
+ variable $path
+ upvar 0 $path data
+
+ if { ($dir == -1 && [lindex [$path:cmd $cmd] 0] > 0) ||
+ ($dir == 1 && [lindex [$path:cmd $cmd] 1] < 1) } {
+ $path:cmd $cmd scroll $dir units
+ set data(dnd,afterid) [after 100 Tree::_scroll $path $cmd $dir]
+ } else {
+ set data(dnd,afterid) ""
+ DropSite::setcursor dot
+ }
+}
Deleted: grass/trunk/lib/external/bwidget/utils.tcl
===================================================================
--- grass/trunk/lib/external/bwidget/utils.tcl 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/utils.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,408 +0,0 @@
-# ------------------------------------------------------------------------------
-# utils.tcl
-# This file is part of Unifix BWidget Toolkit
-# $Id$
-# ------------------------------------------------------------------------------
-# Index of commands:
-# - GlobalVar::exists
-# - GlobalVar::setvarvar
-# - GlobalVar::getvarvar
-# - BWidget::assert
-# - BWidget::clonename
-# - BWidget::get3dcolor
-# - BWidget::XLFDfont
-# - BWidget::place
-# - BWidget::grab
-# - BWidget::focus
-# ------------------------------------------------------------------------------
-
-namespace eval GlobalVar {
- proc use {} {}
-}
-
-
-namespace eval BWidget {
- variable _top
- variable _gstack {}
- variable _fstack {}
- proc use {} {}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command GlobalVar::exists
-# ------------------------------------------------------------------------------
-proc GlobalVar::exists { varName } {
- return [uplevel \#0 [list info exists $varName]]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command GlobalVar::setvar
-# ------------------------------------------------------------------------------
-proc GlobalVar::setvar { varName value } {
- return [uplevel \#0 [list set $varName $value]]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command GlobalVar::getvar
-# ------------------------------------------------------------------------------
-proc GlobalVar::getvar { varName } {
- return [uplevel \#0 [list set $varName]]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command GlobalVar::tracevar
-# ------------------------------------------------------------------------------
-proc GlobalVar::tracevar { cmd varName args } {
- return [uplevel \#0 trace $cmd [list $varName] $args]
-}
-
-
-
-# ------------------------------------------------------------------------------
-# Command BWidget::lreorder
-# ------------------------------------------------------------------------------
-proc BWidget::lreorder { list neworder } {
- set pos 0
- set newlist {}
- foreach e $neworder {
- if { [lsearch -exact $list $e] != -1 } {
- lappend newlist $e
- set tabelt($e) 1
- }
- }
- set len [llength $newlist]
- if { !$len } {
- return $list
- }
- if { $len == [llength $list] } {
- return $newlist
- }
- set pos 0
- foreach e $list {
- if { ![info exists tabelt($e)] } {
- set newlist [linsert $newlist $pos $e]
- }
- incr pos
- }
- return $newlist
-}
-
-
-# ------------------------------------------------------------------------------
-# Command BWidget::assert
-# ------------------------------------------------------------------------------
-proc BWidget::assert { exp {msg ""}} {
- set res [uplevel expr $exp]
- if { !$res} {
- if { $msg == "" } {
- return -code error "Assertion failed: {$exp}"
- } else {
- return -code error $msg
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command BWidget::clonename
-# ------------------------------------------------------------------------------
-proc BWidget::clonename { menu } {
- set path ""
- set menupath ""
- set found 0
- foreach widget [lrange [split $menu "."] 1 end] {
- if { $found || [winfo class "$path.$widget"] == "Menu" } {
- set found 1
- append menupath "#" $widget
- append path "." $menupath
- } else {
- append menupath "#" $widget
- append path "." $widget
- }
- }
- return $path
-}
-
-
-# ------------------------------------------------------------------------------
-# Command BWidget::getname
-# ------------------------------------------------------------------------------
-proc BWidget::getname { name } {
- if { [string length $name] } {
- set text [option get . "${name}Name" ""]
- if { [string length $text] } {
- return [parsetext $text]
- }
- }
- return {}
- }
-
-
-# ------------------------------------------------------------------------------
-# Command BWidget::parsetext
-# ------------------------------------------------------------------------------
-proc BWidget::parsetext { text } {
- set result ""
- set index -1
- set start 0
- while { [string length $text] } {
- set idx [string first "&" $text]
- if { $idx == -1 } {
- append result $text
- set text ""
- } else {
- set char [string index $text [expr {$idx+1}]]
- if { $char == "&" } {
- append result [string range $text 0 $idx]
- set text [string range $text [expr {$idx+2}] end]
- set start [expr {$start+$idx+1}]
- } else {
- append result [string range $text 0 [expr {$idx-1}]]
- set text [string range $text [expr {$idx+1}] end]
- incr start $idx
- set index $start
- }
- }
- }
- return [list $result $index]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command BWidget::get3dcolor
-# ------------------------------------------------------------------------------
-proc BWidget::get3dcolor { path bgcolor } {
- foreach val [winfo rgb $path $bgcolor] {
- lappend dark [expr 60*$val/100]
- set tmp1 [expr 14*$val/10]
- if { $tmp1 > 65535 } {
- set tmp1 65535
- }
- set tmp2 [expr (65535+$val)/2]
- lappend light [expr ($tmp1 > $tmp2) ? $tmp1:$tmp2]
- }
- return [list [eval format "#%04x%04x%04x" $dark] [eval format "#%04x%04x%04x" $light]]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command BWidget::XLFDfont
-# ------------------------------------------------------------------------------
-proc BWidget::XLFDfont { cmd args } {
- switch -- $cmd {
- create {
- set font "-*-*-*-*-*-*-*-*-*-*-*-*-*-*"
- }
- configure {
- set font [lindex $args 0]
- set args [lrange $args 1 end]
- }
- default {
- return -code error "XLFDfont: commande incorrecte: $cmd"
- }
- }
- set lfont [split $font "-"]
- if { [llength $lfont] != 15 } {
- return -code error "XLFDfont: description XLFD incorrecte: $font"
- }
-
- foreach {option value} $args {
- switch -- $option {
- -foundry { set index 1 }
- -family { set index 2 }
- -weight { set index 3 }
- -slant { set index 4 }
- -size { set index 7 }
- default { return -code error "XLFDfont: option incorrecte: $option" }
- }
- set lfont [lreplace $lfont $index $index $value]
- }
- return [join $lfont "-"]
-}
-
-
-
-# ------------------------------------------------------------------------------
-# Command BWidget::place
-# ------------------------------------------------------------------------------
-proc BWidget::place { path w h args } {
- variable _top
-
- update idletasks
- set reqw [winfo reqwidth $path]
- set reqh [winfo reqheight $path]
- if { $w == 0 } {set w $reqw}
- if { $h == 0 } {set h $reqh}
-
- set arglen [llength $args]
- if { $arglen > 3 } {
- return -code error "BWidget::place: bad number of argument"
- }
-
- if { $arglen > 0 } {
- set where [lindex $args 0]
- set idx [lsearch {"at" "center" "left" "right" "above" "below"} $where]
- if { $idx == -1 } {
- return -code error "BWidget::place: incorrect position \"$where\""
- }
- if { $idx == 0 } {
- set err [catch {
- set x [expr {int([lindex $args 1])}]
- set y [expr {int([lindex $args 2])}]
- }]
- if { $err } {
- return -code error "BWidget::place: incorrect position"
- }
- if { $x >= 0 } {
- set x "+$x"
- }
- if { $y >= 0 } {
- set y "+$y"
- }
- } else {
- if { $arglen == 2 } {
- set widget [lindex $args 1]
- if { ![winfo exists $widget] } {
- return -code error "BWidget::place: \"$widget\" does not exist"
- }
- }
- set sw [winfo screenwidth $path]
- set sh [winfo screenheight $path]
- if { $idx == 1 } {
- if { $arglen == 2 } {
- # center to widget
- set x0 [expr [winfo rootx $widget] + ([winfo width $widget] - $w)/2]
- set y0 [expr [winfo rooty $widget] + ([winfo height $widget] - $h)/2]
- } else {
- # center to screen
- set x0 [expr ([winfo screenwidth $path] - $w)/2 - [winfo vrootx $path]]
- set y0 [expr ([winfo screenheight $path] - $h)/2 - [winfo vrooty $path]]
- }
- set x "+$x0"
- set y "+$y0"
- if { $x0+$w > $sw } {set x "-0"; set x0 [expr {$sw-$w}]}
- if { $x0 < 0 } {set x "+0"}
- if { $y0+$h > $sh } {set y "-0"; set y0 [expr {$sh-$h}]}
- if { $y0 < 0 } {set y "+0"}
- } else {
- set x0 [winfo rootx $widget]
- set y0 [winfo rooty $widget]
- set x1 [expr {$x0 + [winfo width $widget]}]
- set y1 [expr {$y0 + [winfo height $widget]}]
- if { $idx == 2 || $idx == 3 } {
- set y "+$y0"
- if { $y0+$h > $sh } {set y "-0"; set y0 [expr {$sh-$h}]}
- if { $y0 < 0 } {set y "+0"}
- if { $idx == 2 } {
- # try left, then right if out, then 0 if out
- if { $x0 >= $w } {
- set x [expr {$x0-$sw}]
- } elseif { $x1+$w <= $sw } {
- set x "+$x1"
- } else {
- set x "+0"
- }
- } else {
- # try right, then left if out, then 0 if out
- if { $x1+$w <= $sw } {
- set x "+$x1"
- } elseif { $x0 >= $w } {
- set x [expr {$x0-$sw}]
- } else {
- set x "-0"
- }
- }
- } else {
- set x "+$x0"
- if { $x0+$w > $sw } {set x "-0"; set x0 [expr {$sw-$w}]}
- if { $x0 < 0 } {set x "+0"}
- if { $idx == 4 } {
- # try top, then bottom, then 0
- if { $h <= $y0 } {
- set y [expr {$y0-$sh}]
- } elseif { $y1+$h <= $sh } {
- set y "+$y1"
- } else {
- set y "+0"
- }
- } else {
- # try bottom, then top, then 0
- if { $y1+$h <= $sh } {
- set y "+$y1"
- } elseif { $h <= $y0 } {
- set y [expr {$y0-$sh}]
- } else {
- set y "-0"
- }
- }
- }
- }
- }
- wm geometry $path "${w}x${h}${x}${y}"
- } else {
- wm geometry $path "${w}x${h}"
- }
- update idletasks
-}
-
-
-# ------------------------------------------------------------------------------
-# Command BWidget::grab
-# ------------------------------------------------------------------------------
-proc BWidget::grab { option path } {
- variable _gstack
-
- if { $option == "release" } {
- catch {::grab release $path}
- while { [llength $_gstack] } {
- set grinfo [lindex $_gstack end]
- set _gstack [lreplace $_gstack end end]
- foreach {oldg mode} $grinfo {
- if { [string compare $oldg $path] && [winfo exists $oldg] } {
- if { $mode == "global" } {
- catch {::grab -global $oldg}
- } else {
- catch {::grab $oldg}
- }
- return
- }
- }
- }
- } else {
- set oldg [::grab current]
- if { $oldg != "" } {
- lappend _gstack [list $oldg [::grab status $oldg]]
- }
- if { $option == "global" } {
- ::grab -global $path
- } else {
- ::grab $path
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command BWidget::focus
-# ------------------------------------------------------------------------------
-proc BWidget::focus { option path } {
- variable _fstack
-
- if { $option == "release" } {
- while { [llength $_fstack] } {
- set oldf [lindex $_fstack end]
- set _fstack [lreplace $_fstack end end]
- if { [string compare $oldf $path] && [winfo exists $oldf] } {
- catch {::focus -force $oldf}
- return
- }
- }
- } elseif { $option == "set" } {
- lappend _fstack [::focus]
- ::focus -force $path
- }
-}
Copied: grass/trunk/lib/external/bwidget/utils.tcl (from rev 35192, grass/trunk/lib/external/bwidget/utils.tcl)
===================================================================
--- grass/trunk/lib/external/bwidget/utils.tcl (rev 0)
+++ grass/trunk/lib/external/bwidget/utils.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,408 @@
+# ------------------------------------------------------------------------------
+# utils.tcl
+# This file is part of Unifix BWidget Toolkit
+# $Id$
+# ------------------------------------------------------------------------------
+# Index of commands:
+# - GlobalVar::exists
+# - GlobalVar::setvarvar
+# - GlobalVar::getvarvar
+# - BWidget::assert
+# - BWidget::clonename
+# - BWidget::get3dcolor
+# - BWidget::XLFDfont
+# - BWidget::place
+# - BWidget::grab
+# - BWidget::focus
+# ------------------------------------------------------------------------------
+
+namespace eval GlobalVar {
+ proc use {} {}
+}
+
+
+namespace eval BWidget {
+ variable _top
+ variable _gstack {}
+ variable _fstack {}
+ proc use {} {}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command GlobalVar::exists
+# ------------------------------------------------------------------------------
+proc GlobalVar::exists { varName } {
+ return [uplevel \#0 [list info exists $varName]]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command GlobalVar::setvar
+# ------------------------------------------------------------------------------
+proc GlobalVar::setvar { varName value } {
+ return [uplevel \#0 [list set $varName $value]]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command GlobalVar::getvar
+# ------------------------------------------------------------------------------
+proc GlobalVar::getvar { varName } {
+ return [uplevel \#0 [list set $varName]]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command GlobalVar::tracevar
+# ------------------------------------------------------------------------------
+proc GlobalVar::tracevar { cmd varName args } {
+ return [uplevel \#0 trace $cmd [list $varName] $args]
+}
+
+
+
+# ------------------------------------------------------------------------------
+# Command BWidget::lreorder
+# ------------------------------------------------------------------------------
+proc BWidget::lreorder { list neworder } {
+ set pos 0
+ set newlist {}
+ foreach e $neworder {
+ if { [lsearch -exact $list $e] != -1 } {
+ lappend newlist $e
+ set tabelt($e) 1
+ }
+ }
+ set len [llength $newlist]
+ if { !$len } {
+ return $list
+ }
+ if { $len == [llength $list] } {
+ return $newlist
+ }
+ set pos 0
+ foreach e $list {
+ if { ![info exists tabelt($e)] } {
+ set newlist [linsert $newlist $pos $e]
+ }
+ incr pos
+ }
+ return $newlist
+}
+
+
+# ------------------------------------------------------------------------------
+# Command BWidget::assert
+# ------------------------------------------------------------------------------
+proc BWidget::assert { exp {msg ""}} {
+ set res [uplevel expr $exp]
+ if { !$res} {
+ if { $msg == "" } {
+ return -code error "Assertion failed: {$exp}"
+ } else {
+ return -code error $msg
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command BWidget::clonename
+# ------------------------------------------------------------------------------
+proc BWidget::clonename { menu } {
+ set path ""
+ set menupath ""
+ set found 0
+ foreach widget [lrange [split $menu "."] 1 end] {
+ if { $found || [winfo class "$path.$widget"] == "Menu" } {
+ set found 1
+ append menupath "#" $widget
+ append path "." $menupath
+ } else {
+ append menupath "#" $widget
+ append path "." $widget
+ }
+ }
+ return $path
+}
+
+
+# ------------------------------------------------------------------------------
+# Command BWidget::getname
+# ------------------------------------------------------------------------------
+proc BWidget::getname { name } {
+ if { [string length $name] } {
+ set text [option get . "${name}Name" ""]
+ if { [string length $text] } {
+ return [parsetext $text]
+ }
+ }
+ return {}
+ }
+
+
+# ------------------------------------------------------------------------------
+# Command BWidget::parsetext
+# ------------------------------------------------------------------------------
+proc BWidget::parsetext { text } {
+ set result ""
+ set index -1
+ set start 0
+ while { [string length $text] } {
+ set idx [string first "&" $text]
+ if { $idx == -1 } {
+ append result $text
+ set text ""
+ } else {
+ set char [string index $text [expr {$idx+1}]]
+ if { $char == "&" } {
+ append result [string range $text 0 $idx]
+ set text [string range $text [expr {$idx+2}] end]
+ set start [expr {$start+$idx+1}]
+ } else {
+ append result [string range $text 0 [expr {$idx-1}]]
+ set text [string range $text [expr {$idx+1}] end]
+ incr start $idx
+ set index $start
+ }
+ }
+ }
+ return [list $result $index]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command BWidget::get3dcolor
+# ------------------------------------------------------------------------------
+proc BWidget::get3dcolor { path bgcolor } {
+ foreach val [winfo rgb $path $bgcolor] {
+ lappend dark [expr 60*$val/100]
+ set tmp1 [expr 14*$val/10]
+ if { $tmp1 > 65535 } {
+ set tmp1 65535
+ }
+ set tmp2 [expr (65535+$val)/2]
+ lappend light [expr ($tmp1 > $tmp2) ? $tmp1:$tmp2]
+ }
+ return [list [eval format "#%04x%04x%04x" $dark] [eval format "#%04x%04x%04x" $light]]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command BWidget::XLFDfont
+# ------------------------------------------------------------------------------
+proc BWidget::XLFDfont { cmd args } {
+ switch -- $cmd {
+ create {
+ set font "-*-*-*-*-*-*-*-*-*-*-*-*-*-*"
+ }
+ configure {
+ set font [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ default {
+ return -code error "XLFDfont: commande incorrecte: $cmd"
+ }
+ }
+ set lfont [split $font "-"]
+ if { [llength $lfont] != 15 } {
+ return -code error "XLFDfont: description XLFD incorrecte: $font"
+ }
+
+ foreach {option value} $args {
+ switch -- $option {
+ -foundry { set index 1 }
+ -family { set index 2 }
+ -weight { set index 3 }
+ -slant { set index 4 }
+ -size { set index 7 }
+ default { return -code error "XLFDfont: option incorrecte: $option" }
+ }
+ set lfont [lreplace $lfont $index $index $value]
+ }
+ return [join $lfont "-"]
+}
+
+
+
+# ------------------------------------------------------------------------------
+# Command BWidget::place
+# ------------------------------------------------------------------------------
+proc BWidget::place { path w h args } {
+ variable _top
+
+ update idletasks
+ set reqw [winfo reqwidth $path]
+ set reqh [winfo reqheight $path]
+ if { $w == 0 } {set w $reqw}
+ if { $h == 0 } {set h $reqh}
+
+ set arglen [llength $args]
+ if { $arglen > 3 } {
+ return -code error "BWidget::place: bad number of argument"
+ }
+
+ if { $arglen > 0 } {
+ set where [lindex $args 0]
+ set idx [lsearch {"at" "center" "left" "right" "above" "below"} $where]
+ if { $idx == -1 } {
+ return -code error "BWidget::place: incorrect position \"$where\""
+ }
+ if { $idx == 0 } {
+ set err [catch {
+ set x [expr {int([lindex $args 1])}]
+ set y [expr {int([lindex $args 2])}]
+ }]
+ if { $err } {
+ return -code error "BWidget::place: incorrect position"
+ }
+ if { $x >= 0 } {
+ set x "+$x"
+ }
+ if { $y >= 0 } {
+ set y "+$y"
+ }
+ } else {
+ if { $arglen == 2 } {
+ set widget [lindex $args 1]
+ if { ![winfo exists $widget] } {
+ return -code error "BWidget::place: \"$widget\" does not exist"
+ }
+ }
+ set sw [winfo screenwidth $path]
+ set sh [winfo screenheight $path]
+ if { $idx == 1 } {
+ if { $arglen == 2 } {
+ # center to widget
+ set x0 [expr [winfo rootx $widget] + ([winfo width $widget] - $w)/2]
+ set y0 [expr [winfo rooty $widget] + ([winfo height $widget] - $h)/2]
+ } else {
+ # center to screen
+ set x0 [expr ([winfo screenwidth $path] - $w)/2 - [winfo vrootx $path]]
+ set y0 [expr ([winfo screenheight $path] - $h)/2 - [winfo vrooty $path]]
+ }
+ set x "+$x0"
+ set y "+$y0"
+ if { $x0+$w > $sw } {set x "-0"; set x0 [expr {$sw-$w}]}
+ if { $x0 < 0 } {set x "+0"}
+ if { $y0+$h > $sh } {set y "-0"; set y0 [expr {$sh-$h}]}
+ if { $y0 < 0 } {set y "+0"}
+ } else {
+ set x0 [winfo rootx $widget]
+ set y0 [winfo rooty $widget]
+ set x1 [expr {$x0 + [winfo width $widget]}]
+ set y1 [expr {$y0 + [winfo height $widget]}]
+ if { $idx == 2 || $idx == 3 } {
+ set y "+$y0"
+ if { $y0+$h > $sh } {set y "-0"; set y0 [expr {$sh-$h}]}
+ if { $y0 < 0 } {set y "+0"}
+ if { $idx == 2 } {
+ # try left, then right if out, then 0 if out
+ if { $x0 >= $w } {
+ set x [expr {$x0-$sw}]
+ } elseif { $x1+$w <= $sw } {
+ set x "+$x1"
+ } else {
+ set x "+0"
+ }
+ } else {
+ # try right, then left if out, then 0 if out
+ if { $x1+$w <= $sw } {
+ set x "+$x1"
+ } elseif { $x0 >= $w } {
+ set x [expr {$x0-$sw}]
+ } else {
+ set x "-0"
+ }
+ }
+ } else {
+ set x "+$x0"
+ if { $x0+$w > $sw } {set x "-0"; set x0 [expr {$sw-$w}]}
+ if { $x0 < 0 } {set x "+0"}
+ if { $idx == 4 } {
+ # try top, then bottom, then 0
+ if { $h <= $y0 } {
+ set y [expr {$y0-$sh}]
+ } elseif { $y1+$h <= $sh } {
+ set y "+$y1"
+ } else {
+ set y "+0"
+ }
+ } else {
+ # try bottom, then top, then 0
+ if { $y1+$h <= $sh } {
+ set y "+$y1"
+ } elseif { $h <= $y0 } {
+ set y [expr {$y0-$sh}]
+ } else {
+ set y "-0"
+ }
+ }
+ }
+ }
+ }
+ wm geometry $path "${w}x${h}${x}${y}"
+ } else {
+ wm geometry $path "${w}x${h}"
+ }
+ update idletasks
+}
+
+
+# ------------------------------------------------------------------------------
+# Command BWidget::grab
+# ------------------------------------------------------------------------------
+proc BWidget::grab { option path } {
+ variable _gstack
+
+ if { $option == "release" } {
+ catch {::grab release $path}
+ while { [llength $_gstack] } {
+ set grinfo [lindex $_gstack end]
+ set _gstack [lreplace $_gstack end end]
+ foreach {oldg mode} $grinfo {
+ if { [string compare $oldg $path] && [winfo exists $oldg] } {
+ if { $mode == "global" } {
+ catch {::grab -global $oldg}
+ } else {
+ catch {::grab $oldg}
+ }
+ return
+ }
+ }
+ }
+ } else {
+ set oldg [::grab current]
+ if { $oldg != "" } {
+ lappend _gstack [list $oldg [::grab status $oldg]]
+ }
+ if { $option == "global" } {
+ ::grab -global $path
+ } else {
+ ::grab $path
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command BWidget::focus
+# ------------------------------------------------------------------------------
+proc BWidget::focus { option path } {
+ variable _fstack
+
+ if { $option == "release" } {
+ while { [llength $_fstack] } {
+ set oldf [lindex $_fstack end]
+ set _fstack [lreplace $_fstack end end]
+ if { [string compare $oldf $path] && [winfo exists $oldf] } {
+ catch {::focus -force $oldf}
+ return
+ }
+ }
+ } elseif { $option == "set" } {
+ lappend _fstack [::focus]
+ ::focus -force $path
+ }
+}
Deleted: grass/trunk/lib/external/bwidget/widget.tcl
===================================================================
--- grass/trunk/lib/external/bwidget/widget.tcl 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/widget.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,972 +0,0 @@
-# ------------------------------------------------------------------------------
-# widget.tcl
-# This file is part of Unifix BWidget Toolkit
-# $Id$
-# ------------------------------------------------------------------------------
-# Index of commands:
-# - Widget::tkinclude
-# - Widget::bwinclude
-# - Widget::declare
-# - Widget::addmap
-# - Widget::init
-# - Widget::destroy
-# - Widget::setoption
-# - Widget::configure
-# - Widget::cget
-# - Widget::subcget
-# - Widget::hasChanged
-# - Widget::_get_tkwidget_options
-# - Widget::_test_tkresource
-# - Widget::_test_bwresource
-# - Widget::_test_synonym
-# - Widget::_test_string
-# - Widget::_test_flag
-# - Widget::_test_enum
-# - Widget::_test_int
-# - Widget::_test_boolean
-# ------------------------------------------------------------------------------
-
-namespace eval Widget {
- variable _optiontype
- variable _class
- variable _tk_widget
-
- array set _optiontype {
- TkResource Widget::_test_tkresource
- BwResource Widget::_test_bwresource
- Enum Widget::_test_enum
- Int Widget::_test_int
- Boolean Widget::_test_boolean
- String Widget::_test_string
- Flag Widget::_test_flag
- Synonym Widget::_test_synonym
- }
-
- proc use {} {}
-}
-
-
-
-# ------------------------------------------------------------------------------
-# Command Widget::tkinclude
-# Includes tk widget resources to BWidget widget.
-# class class name of the BWidget
-# tkwidget tk widget to include
-# subpath subpath to configure
-# args additionnal args for included options
-# ------------------------------------------------------------------------------
-proc Widget::tkinclude { class tkwidget subpath args } {
- foreach {cmd lopt} $args {
- # cmd can be
- # include options to include lopt = {opt ...}
- # remove options to remove lopt = {opt ...}
- # rename options to rename lopt = {opt newopt ...}
- # prefix options to prefix lopt = {prefix opt opt ...}
- # initialize set default value for options lopt = {opt value ...}
- # readonly set readonly flag for options lopt = {opt flag ...}
- switch -- $cmd {
- remove {
- foreach option $lopt {
- set remove($option) 1
- }
- }
- include {
- foreach option $lopt {
- set include($option) 1
- }
- }
- prefix {
- set prefix [lindex $lopt 0]
- foreach option [lrange $lopt 1 end] {
- set rename($option) "-$prefix[string range $option 1 end]"
- }
- }
- rename -
- readonly -
- initialize {
- array set $cmd $lopt
- }
- default {
- return -code error "invalid argument \"$cmd\""
- }
- }
- }
-
- namespace eval $class {}
- upvar 0 ${class}::opt classopt
- upvar 0 ${class}::map classmap
-
- # create resources informations from tk widget resources
- foreach optdesc [_get_tkwidget_options $tkwidget] {
- set option [lindex $optdesc 0]
- if { (![info exists include] || [info exists include($option)]) &&
- ![info exists remove($option)] } {
- if { [llength $optdesc] == 3 } {
- # option is a synonym
- set syn [lindex $optdesc 1]
- if { ![info exists remove($syn)] } {
- # original option is not removed
- if { [info exists rename($syn)] } {
- set classopt($option) [list Synonym $rename($syn)]
- } else {
- set classopt($option) [list Synonym $syn]
- }
- }
- } else {
- if { [info exists rename($option)] } {
- set realopt $option
- set option $rename($option)
- } else {
- set realopt $option
- }
- if { [info exists initialize($option)] } {
- set value $initialize($option)
- } else {
- set value [lindex $optdesc 1]
- }
- if { [info exists readonly($option)] } {
- set ro $readonly($option)
- } else {
- set ro 0
- }
- set classopt($option) [list TkResource $value $ro [list $tkwidget $realopt]]
- lappend classmap($option) $subpath "" $realopt
- }
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Widget::bwinclude
-# Includes BWidget resources to BWidget widget.
-# class class name of the BWidget
-# subclass BWidget class to include
-# subpath subpath to configure
-# args additionnal args for included options
-# ------------------------------------------------------------------------------
-proc Widget::bwinclude { class subclass subpath args } {
- foreach {cmd lopt} $args {
- # cmd can be
- # include options to include lopt = {opt ...}
- # remove options to remove lopt = {opt ...}
- # rename options to rename lopt = {opt newopt ...}
- # prefix options to prefix lopt = {prefix opt opt ...}
- # initialize set default value for options lopt = {opt value ...}
- # readonly set readonly flag for options lopt = {opt flag ...}
- switch -- $cmd {
- remove {
- foreach option $lopt {
- set remove($option) 1
- }
- }
- include {
- foreach option $lopt {
- set include($option) 1
- }
- }
- prefix {
- set prefix [lindex $lopt 0]
- foreach option [lrange $lopt 1 end] {
- set rename($option) "-$prefix[string range $option 1 end]"
- }
- }
- rename -
- readonly -
- initialize {
- array set $cmd $lopt
- }
- default {
- return -code error "invalid argument \"$cmd\""
- }
- }
- }
-
- namespace eval $class {}
- upvar 0 ${class}::opt classopt
- upvar 0 ${class}::map classmap
- upvar 0 ${subclass}::opt subclassopt
-
- # create resources informations from BWidget resources
- foreach {option optdesc} [array get subclassopt] {
- if { (![info exists include] || [info exists include($option)]) &&
- ![info exists remove($option)] } {
- set type [lindex $optdesc 0]
- if { ![string compare $type "Synonym"] } {
- # option is a synonym
- set syn [lindex $optdesc 1]
- if { ![info exists remove($syn)] } {
- if { [info exists rename($syn)] } {
- set classopt($option) [list Synonym $rename($syn)]
- } else {
- set classopt($option) [list Synonym $syn]
- }
- }
- } else {
- if { [info exists rename($option)] } {
- set realopt $option
- set option $rename($option)
- } else {
- set realopt $option
- }
- if { [info exists initialize($option)] } {
- set value $initialize($option)
- } else {
- set value [lindex $optdesc 1]
- }
- if { [info exists readonly($option)] } {
- set ro $readonly($option)
- } else {
- set ro [lindex $optdesc 2]
- }
- set classopt($option) [list $type $value $ro [lindex $optdesc 3]]
- lappend classmap($option) $subpath $subclass $realopt
- }
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Widget::declare
-# Declares new options to BWidget class.
-# ------------------------------------------------------------------------------
-proc Widget::declare { class optlist } {
- variable _optiontype
-
- namespace eval $class {}
- upvar 0 ${class}::opt classopt
-
- foreach optdesc $optlist {
- set option [lindex $optdesc 0]
- set optdesc [lrange $optdesc 1 end]
- set type [lindex $optdesc 0]
-
- if { ![info exists _optiontype($type)] } {
- # invalid resource type
- return -code error "invalid option type \"$type\""
- }
-
- if { ![string compare $type "Synonym"] } {
- # test existence of synonym option
- set syn [lindex $optdesc 1]
- if { ![info exists classopt($syn)] } {
- return -code error "unknow option \"$syn\" for Synonym \"$option\""
- }
- set classopt($option) [list Synonym $syn]
- continue
- }
-
- # all other resource may have default value, readonly flag and
- # optional arg depending on type
- set value [lindex $optdesc 1]
- set ro [lindex $optdesc 2]
- set arg [lindex $optdesc 3]
-
- if { ![string compare $type "BwResource"] } {
- # We don't keep BwResource. We simplify to type of sub BWidget
- set subclass [lindex $arg 0]
- set realopt [lindex $arg 1]
- if { ![string length $realopt] } {
- set realopt $option
- }
-
- upvar 0 ${subclass}::opt subclassopt
- if { ![info exists subclassopt($realopt)] } {
- return -code error "unknow option \"$realopt\""
- }
- set suboptdesc $subclassopt($realopt)
- if { $value == "" } {
- # We initialize default value
- set value [lindex $suboptdesc 1]
- }
- set type [lindex $suboptdesc 0]
- set ro [lindex $suboptdesc 2]
- set arg [lindex $suboptdesc 3]
- set classopt($option) [list $type $value $ro $arg]
- continue
- }
-
- # retreive default value for TkResource
- if { ![string compare $type "TkResource"] } {
- set tkwidget [lindex $arg 0]
- set realopt [lindex $arg 1]
- if { ![string length $realopt] } {
- set realopt $option
- }
- set tkoptions [_get_tkwidget_options $tkwidget]
- if { ![string length $value] } {
- # We initialize default value
- set value [lindex [lindex $tkoptions [lsearch $tkoptions [list $realopt *]]] end]
- }
- set classopt($option) [list TkResource $value $ro [list $tkwidget $realopt]]
- continue
- }
-
- # for any other resource type, we keep original optdesc
- set classopt($option) [list $type $value $ro $arg]
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Widget::addmap
-# ------------------------------------------------------------------------------
-proc Widget::addmap { class subclass subpath options } {
- upvar 0 ${class}::map classmap
-
- foreach {option realopt} $options {
- if { ![string length $realopt] } {
- set realopt $option
- }
- lappend classmap($option) $subpath $subclass $realopt
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Widget::syncoptions
-# ------------------------------------------------------------------------------
-proc Widget::syncoptions { class subclass subpath options } {
- upvar 0 ${class}::sync classync
-
- foreach {option realopt} $options {
- if { ![string length $realopt] } {
- set realopt $option
- }
- set classync($option) [list $subpath $subclass $realopt]
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Widget::init
-# ------------------------------------------------------------------------------
-proc Widget::init { class path options } {
- variable _class
- variable _optiontype
-
- upvar 0 ${class}::opt classopt
- upvar 0 ${class}::map classmap
- upvar 0 ${class}::$path:opt pathopt
- upvar 0 ${class}::$path:mod pathmod
-
- catch {unset pathopt}
- catch {unset pathmod}
- set fpath ".#BWidgetClass#$class"
- regsub -all "::" $class "" rdbclass
- if { ![winfo exists $fpath] } {
- frame $fpath -class $rdbclass
- }
- foreach {option optdesc} [array get classopt] {
- set type [lindex $optdesc 0]
- if { ![string compare $type "Synonym"] } {
- set option [lindex $optdesc 1]
- set optdesc $classopt($option)
- set type [lindex $optdesc 0]
- }
- if { ![string compare $type "TkResource"] } {
- set alt [lindex [lindex $optdesc 3] 1]
- } else {
- set alt ""
- }
- set optdb [lindex [_configure_option $option $alt] 0]
- set def [option get $fpath $optdb $rdbclass]
- if { [string length $def] } {
- set pathopt($option) $def
- } else {
- set pathopt($option) [lindex $optdesc 1]
- }
- set pathmod($option) 0
- }
-
- set _class($path) $class
- foreach {option value} $options {
- if { ![info exists classopt($option)] } {
- unset pathopt
- unset pathmod
- return -code error "unknown option \"$option\""
- }
- set optdesc $classopt($option)
- set type [lindex $optdesc 0]
- if { ![string compare $type "Synonym"] } {
- set option [lindex $optdesc 1]
- set optdesc $classopt($option)
- set type [lindex $optdesc 0]
- }
- set pathopt($option) [$_optiontype($type) $option $value [lindex $optdesc 3]]
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Widget::destroy
-# ------------------------------------------------------------------------------
-proc Widget::destroy { path } {
- variable _class
-
- set class $_class($path)
- upvar 0 ${class}::$path:opt pathopt
- upvar 0 ${class}::$path:mod pathmod
-
- catch {unset pathopt}
- catch {unset pathmod}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Widget::configure
-# ------------------------------------------------------------------------------
-proc Widget::configure { path options } {
- set len [llength $options]
- if { $len <= 1 } {
- return [_get_configure $path $options]
- } elseif { $len % 2 == 1 } {
- return -code error "incorrect number of arguments"
- }
-
- variable _class
- variable _optiontype
-
- set class $_class($path)
- upvar 0 ${class}::opt classopt
- upvar 0 ${class}::map classmap
- upvar 0 ${class}::$path:opt pathopt
- upvar 0 ${class}::$path:mod pathmod
-
- set window [_get_window $class $path]
- foreach {option value} $options {
- if { ![info exists classopt($option)] } {
- return -code error "unknown option \"$option\""
- }
- set optdesc $classopt($option)
- set type [lindex $optdesc 0]
- if { ![string compare $type "Synonym"] } {
- set option [lindex $optdesc 1]
- set optdesc $classopt($option)
- set type [lindex $optdesc 0]
- }
- if { ![lindex $optdesc 2] } {
- set curval $pathopt($option)
- set newval [$_optiontype($type) $option $value [lindex $optdesc 3]]
- if { [info exists classmap($option)] } {
- foreach {subpath subclass realopt} $classmap($option) {
- if { [string length $subclass] } {
- ${subclass}::configure $window$subpath $realopt $newval
- } else {
- $window$subpath configure $realopt $newval
- }
- }
- }
- set pathopt($option) $newval
- set pathmod($option) [expr {[string compare $newval $curval] != 0}]
- }
- }
-
- return {}
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Widget::cget
-# ------------------------------------------------------------------------------
-proc Widget::cget { path option } {
- variable _class
-
- if { ![info exists _class($path)] } {
- return -code error "unknown widget $path"
- }
-
- set class $_class($path)
- upvar 0 ${class}::opt classopt
- upvar 0 ${class}::sync classync
- upvar 0 ${class}::$path:opt pathopt
-
- if { ![info exists classopt($option)] } {
- return -code error "unknown option \"$option\""
- }
- set optdesc $classopt($option)
- set type [lindex $optdesc 0]
- if { ![string compare $type "Synonym"] } {
- set option [lindex $optdesc 1]
- }
-
- if { [info exists classync($option)] } {
- set window [_get_window $class $path]
- foreach {subpath subclass realopt} $classync($option) {
- if { [string length $subclass] } {
- set pathopt($option) [${subclass}::cget $window$subpath $realopt]
- } else {
- set pathopt($option) [$window$subpath cget $realopt]
- }
- }
- }
-
- return $pathopt($option)
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Widget::subcget
-# ------------------------------------------------------------------------------
-proc Widget::subcget { path subwidget } {
- variable _class
-
- set class $_class($path)
- upvar 0 ${class}::map classmap
- upvar 0 ${class}::$path:opt pathopt
-
- set result {}
- foreach {option map} [array get classmap] {
- foreach {subpath subclass realopt} $map {
- if { ![string compare $subpath $subwidget] } {
- lappend result $realopt $pathopt($option)
- }
- }
- }
- return $result
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Widget::hasChanged
-# ------------------------------------------------------------------------------
-proc Widget::hasChanged { path option pvalue } {
- upvar $pvalue value
- variable _class
-
- set class $_class($path)
- upvar 0 ${class}::$path:opt pathopt
- upvar 0 ${class}::$path:mod pathmod
-
- set value $pathopt($option)
- set result $pathmod($option)
- set pathmod($option) 0
-
- return $result
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Widget::setoption
-# ------------------------------------------------------------------------------
-proc Widget::setoption { path option value } {
- variable _class
-
- set class $_class($path)
- upvar 0 ${class}::$path:opt pathopt
-
- set pathopt($option) $value
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Widget::getoption
-# ------------------------------------------------------------------------------
-proc Widget::getoption { path option } {
- variable _class
-
- set class $_class($path)
- upvar 0 ${class}::$path:opt pathopt
-
- return $pathopt($option)
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Widget::_get_window
-# returns the window corresponding to widget path
-# ------------------------------------------------------------------------------
-proc Widget::_get_window { class path } {
- set idx [string last "#" $path]
- if { $idx != -1 && ![string compare [string range $path [expr {$idx+1}] end] $class] } {
- return [string range $path 0 [expr {$idx-1}]]
- } else {
- return $path
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Widget::_get_configure
-# returns the configuration list of options
-# (as tk widget do - [$w configure ?option?])
-# ------------------------------------------------------------------------------
-proc Widget::_get_configure { path options } {
- variable _class
-
- set class $_class($path)
- upvar 0 ${class}::opt classopt
- upvar 0 ${class}::map classmap
- upvar 0 ${class}::$path:opt pathopt
- upvar 0 ${class}::$path:mod pathmod
-
- set len [llength $options]
- if { !$len } {
- set result {}
- foreach option [lsort [array names classopt]] {
- set optdesc $classopt($option)
- set type [lindex $optdesc 0]
- if { ![string compare $type "Synonym"] } {
- set syn $option
- set option [lindex $optdesc 1]
- set optdesc $classopt($option)
- set type [lindex $optdesc 0]
- } else {
- set syn ""
- }
- if { ![string compare $type "TkResource"] } {
- set alt [lindex [lindex $optdesc 3] 1]
- } else {
- set alt ""
- }
- set res [_configure_option $option $alt]
- if { $syn == "" } {
- lappend result [concat $option $res [list [lindex $optdesc 1]] [list [cget $path $option]]]
- } else {
- lappend result [list $syn [lindex $res 0]]
- }
- }
- return $result
- } elseif { $len == 1 } {
- set option [lindex $options 0]
- if { ![info exists classopt($option)] } {
- return -code error "unknown option \"$option\""
- }
- set optdesc $classopt($option)
- set type [lindex $optdesc 0]
- if { ![string compare $type "Synonym"] } {
- set option [lindex $optdesc 1]
- set optdesc $classopt($option)
- set type [lindex $optdesc 0]
- }
- if { ![string compare $type "TkResource"] } {
- set alt [lindex [lindex $optdesc 3] 1]
- } else {
- set alt ""
- }
- set res [_configure_option $option $alt]
- return [concat $option $res [list [lindex $optdesc 1]] [list [cget $path $option]]]
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Widget::_configure_option
-# ------------------------------------------------------------------------------
-proc Widget::_configure_option { option altopt } {
- variable _optiondb
- variable _optionclass
-
- if { [info exists _optiondb($option)] } {
- set optdb $_optiondb($option)
- } else {
- set optdb [string range $option 1 end]
- }
- if { [info exists _optionclass($option)] } {
- set optclass $_optionclass($option)
- } elseif { [string length $altopt] } {
- if { [info exists _optionclass($altopt)] } {
- set optclass $_optionclass($altopt)
- } else {
- set optclass [string range $altopt 1 end]
- }
- } else {
- set optclass [string range $option 1 end]
- }
- return [list $optdb $optclass]
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Widget::_get_tkwidget_options
-# ------------------------------------------------------------------------------
-proc Widget::_get_tkwidget_options { tkwidget } {
- variable _tk_widget
- variable _optiondb
- variable _optionclass
-
- if { ![info exists _tk_widget($tkwidget)] } {
- set widget [$tkwidget ".#BWidget#$tkwidget"]
- set config [$widget configure]
- foreach optlist $config {
- set opt [lindex $optlist 0]
- if { [llength $optlist] == 2 } {
- set refsyn [lindex $optlist 1]
- # search for class
- set idx [lsearch $config [list * $refsyn *]]
- if { $idx == -1 } {
- if { [string index $refsyn 0] == "-" } {
- # search for option (tk8.1b1 bug)
- set idx [lsearch $config [list $refsyn * *]]
- } else {
- # last resort
- set idx [lsearch $config [list -[string tolower $refsyn] * *]]
- }
- if { $idx == -1 } {
- # fed up with "can't read classopt()"
- return -code error "can't find option of synonym $opt"
- }
- }
- set syn [lindex [lindex $config $idx] 0]
- set def [lindex [lindex $config $idx] 3]
- lappend _tk_widget($tkwidget) [list $opt $syn $def]
- } else {
- set def [lindex $optlist 3]
- lappend _tk_widget($tkwidget) [list $opt $def]
- set _optiondb($opt) [lindex $optlist 1]
- set _optionclass($opt) [lindex $optlist 2]
- }
- }
- }
- return $_tk_widget($tkwidget)
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Widget::_test_tkresource
-# ------------------------------------------------------------------------------
-proc Widget::_test_tkresource { option value arg } {
- set tkwidget [lindex $arg 0]
- set realopt [lindex $arg 1]
- set path ".#BWidget#$tkwidget"
- set old [$path cget $realopt]
- $path configure $realopt $value
- set res [$path cget $realopt]
- $path configure $realopt $old
-
- return $res
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Widget::_test_bwresource
-# ------------------------------------------------------------------------------
-proc Widget::_test_bwresource { option value arg } {
- return -code error "bad option type BwResource in widget"
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Widget::_test_synonym
-# ------------------------------------------------------------------------------
-proc Widget::_test_synonym { option value arg } {
- return -code error "bad option type Synonym in widget"
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Widget::_test_string
-# ------------------------------------------------------------------------------
-proc Widget::_test_string { option value arg } {
- return $value
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Widget::_test_flag
-# ------------------------------------------------------------------------------
-proc Widget::_test_flag { option value arg } {
- set len [string length $value]
- set res ""
- for {set i 0} {$i < $len} {incr i} {
- set c [string index $value $i]
- if { [string first $c $arg] == -1 } {
- return -code error "bad [string range $option 1 end] value \"$value\": characters must be in \"$arg\""
- }
- if { [string first $c $res] == -1 } {
- append res $c
- }
- }
- return $res
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Widget::_test_enum
-# ------------------------------------------------------------------------------
-proc Widget::_test_enum { option value arg } {
- if { [lsearch $arg $value] == -1 } {
- set last [lindex $arg end]
- set sub [lreplace $arg end end]
- if { [llength $sub] } {
- set str "[join $sub ", "] or $last"
- } else {
- set str $last
- }
- return -code error "bad [string range $option 1 end] value \"$value\": must be $str"
- }
- return $value
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Widget::_test_int
-# ------------------------------------------------------------------------------
-proc Widget::_test_int { option value arg } {
- set binf [lindex $arg 0]
- set bsup [lindex $arg 1]
- if { $binf != "" } {set binf ">$binf"}
- if { $bsup != "" } {set bsup "<$bsup"}
- if { [catch {expr $value}] || $value != int($value) ||
- !($binf == "" || [expr $value$binf]) ||
- !($bsup == "" || [expr $value$bsup]) } {
- return -code error "bad [string range $option 1 end] value \"$value\": must be integer $binf $bsup"
- }
- return $value
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Widget::_test_boolean
-# ------------------------------------------------------------------------------
-proc Widget::_test_boolean { option value arg } {
- if { $value == 1 ||
- ![string compare $value "true"] ||
- ![string compare $value "yes"] } {
- set value 1
- } elseif { $value == 0 ||
- ![string compare $value "false"] ||
- ![string compare $value "no"] } {
- set value 0
- } else {
- return -code error "bad [string range $option 1 end] value \"$value\": must be boolean"
- }
- return $value
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Widget::focusNext
-# Same as tk_focusNext, but call Widget::focusOK
-# ------------------------------------------------------------------------------
-proc Widget::focusNext { w } {
- set cur $w
- while 1 {
-
- # Descend to just before the first child of the current widget.
-
- set parent $cur
- set children [winfo children $cur]
- set i -1
-
- # Look for the next sibling that isn't a top-level.
-
- while 1 {
- incr i
- if {$i < [llength $children]} {
- set cur [lindex $children $i]
- if {[winfo toplevel $cur] == $cur} {
- continue
- } else {
- break
- }
- }
-
- # No more siblings, so go to the current widget's parent.
- # If it's a top-level, break out of the loop, otherwise
- # look for its next sibling.
-
- set cur $parent
- if {[winfo toplevel $cur] == $cur} {
- break
- }
- set parent [winfo parent $parent]
- set children [winfo children $parent]
- set i [lsearch -exact $children $cur]
- }
- if {($cur == $w) || [focusOK $cur]} {
- return $cur
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Widget::focusPrev
-# Same as tk_focusPrev, but call Widget::focusOK
-# ------------------------------------------------------------------------------
-proc Widget::focusPrev { w } {
- set cur $w
- while 1 {
-
- # Collect information about the current window's position
- # among its siblings. Also, if the window is a top-level,
- # then reposition to just after the last child of the window.
-
- if {[winfo toplevel $cur] == $cur} {
- set parent $cur
- set children [winfo children $cur]
- set i [llength $children]
- } else {
- set parent [winfo parent $cur]
- set children [winfo children $parent]
- set i [lsearch -exact $children $cur]
- }
-
- # Go to the previous sibling, then descend to its last descendant
- # (highest in stacking order. While doing this, ignore top-levels
- # and their descendants. When we run out of descendants, go up
- # one level to the parent.
-
- while {$i > 0} {
- incr i -1
- set cur [lindex $children $i]
- if {[winfo toplevel $cur] == $cur} {
- continue
- }
- set parent $cur
- set children [winfo children $parent]
- set i [llength $children]
- }
- set cur $parent
- if {($cur == $w) || [focusOK $cur]} {
- return $cur
- }
- }
-}
-
-
-# ------------------------------------------------------------------------------
-# Command Widget::focusOK
-# Same as tk_focusOK, but handles -editable option and whole tags list.
-# ------------------------------------------------------------------------------
-proc Widget::focusOK { w } {
- set code [catch {$w cget -takefocus} value]
- if { $code == 1 } {
- return 0
- }
- if {($code == 0) && ($value != "")} {
- if {$value == 0} {
- return 0
- } elseif {$value == 1} {
- return [winfo viewable $w]
- } else {
- set value [uplevel \#0 $value $w]
- if {$value != ""} {
- return $value
- }
- }
- }
- if {![winfo viewable $w]} {
- return 0
- }
- set code [catch {$w cget -state} value]
- if {($code == 0) && ($value == "disabled")} {
- return 0
- }
- set code [catch {$w cget -editable} value]
- if {($code == 0) && !$value} {
- return 0
- }
-
- set top [winfo toplevel $w]
- foreach tags [bindtags $w] {
- if { [string compare $tags $top] &&
- [string compare $tags "all"] &&
- [regexp Key [bind $tags]] } {
- return 1
- }
- }
- return 0
-}
Copied: grass/trunk/lib/external/bwidget/widget.tcl (from rev 35192, grass/trunk/lib/external/bwidget/widget.tcl)
===================================================================
--- grass/trunk/lib/external/bwidget/widget.tcl (rev 0)
+++ grass/trunk/lib/external/bwidget/widget.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,972 @@
+# ------------------------------------------------------------------------------
+# widget.tcl
+# This file is part of Unifix BWidget Toolkit
+# $Id$
+# ------------------------------------------------------------------------------
+# Index of commands:
+# - Widget::tkinclude
+# - Widget::bwinclude
+# - Widget::declare
+# - Widget::addmap
+# - Widget::init
+# - Widget::destroy
+# - Widget::setoption
+# - Widget::configure
+# - Widget::cget
+# - Widget::subcget
+# - Widget::hasChanged
+# - Widget::_get_tkwidget_options
+# - Widget::_test_tkresource
+# - Widget::_test_bwresource
+# - Widget::_test_synonym
+# - Widget::_test_string
+# - Widget::_test_flag
+# - Widget::_test_enum
+# - Widget::_test_int
+# - Widget::_test_boolean
+# ------------------------------------------------------------------------------
+
+namespace eval Widget {
+ variable _optiontype
+ variable _class
+ variable _tk_widget
+
+ array set _optiontype {
+ TkResource Widget::_test_tkresource
+ BwResource Widget::_test_bwresource
+ Enum Widget::_test_enum
+ Int Widget::_test_int
+ Boolean Widget::_test_boolean
+ String Widget::_test_string
+ Flag Widget::_test_flag
+ Synonym Widget::_test_synonym
+ }
+
+ proc use {} {}
+}
+
+
+
+# ------------------------------------------------------------------------------
+# Command Widget::tkinclude
+# Includes tk widget resources to BWidget widget.
+# class class name of the BWidget
+# tkwidget tk widget to include
+# subpath subpath to configure
+# args additionnal args for included options
+# ------------------------------------------------------------------------------
+proc Widget::tkinclude { class tkwidget subpath args } {
+ foreach {cmd lopt} $args {
+ # cmd can be
+ # include options to include lopt = {opt ...}
+ # remove options to remove lopt = {opt ...}
+ # rename options to rename lopt = {opt newopt ...}
+ # prefix options to prefix lopt = {prefix opt opt ...}
+ # initialize set default value for options lopt = {opt value ...}
+ # readonly set readonly flag for options lopt = {opt flag ...}
+ switch -- $cmd {
+ remove {
+ foreach option $lopt {
+ set remove($option) 1
+ }
+ }
+ include {
+ foreach option $lopt {
+ set include($option) 1
+ }
+ }
+ prefix {
+ set prefix [lindex $lopt 0]
+ foreach option [lrange $lopt 1 end] {
+ set rename($option) "-$prefix[string range $option 1 end]"
+ }
+ }
+ rename -
+ readonly -
+ initialize {
+ array set $cmd $lopt
+ }
+ default {
+ return -code error "invalid argument \"$cmd\""
+ }
+ }
+ }
+
+ namespace eval $class {}
+ upvar 0 ${class}::opt classopt
+ upvar 0 ${class}::map classmap
+
+ # create resources informations from tk widget resources
+ foreach optdesc [_get_tkwidget_options $tkwidget] {
+ set option [lindex $optdesc 0]
+ if { (![info exists include] || [info exists include($option)]) &&
+ ![info exists remove($option)] } {
+ if { [llength $optdesc] == 3 } {
+ # option is a synonym
+ set syn [lindex $optdesc 1]
+ if { ![info exists remove($syn)] } {
+ # original option is not removed
+ if { [info exists rename($syn)] } {
+ set classopt($option) [list Synonym $rename($syn)]
+ } else {
+ set classopt($option) [list Synonym $syn]
+ }
+ }
+ } else {
+ if { [info exists rename($option)] } {
+ set realopt $option
+ set option $rename($option)
+ } else {
+ set realopt $option
+ }
+ if { [info exists initialize($option)] } {
+ set value $initialize($option)
+ } else {
+ set value [lindex $optdesc 1]
+ }
+ if { [info exists readonly($option)] } {
+ set ro $readonly($option)
+ } else {
+ set ro 0
+ }
+ set classopt($option) [list TkResource $value $ro [list $tkwidget $realopt]]
+ lappend classmap($option) $subpath "" $realopt
+ }
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Widget::bwinclude
+# Includes BWidget resources to BWidget widget.
+# class class name of the BWidget
+# subclass BWidget class to include
+# subpath subpath to configure
+# args additionnal args for included options
+# ------------------------------------------------------------------------------
+proc Widget::bwinclude { class subclass subpath args } {
+ foreach {cmd lopt} $args {
+ # cmd can be
+ # include options to include lopt = {opt ...}
+ # remove options to remove lopt = {opt ...}
+ # rename options to rename lopt = {opt newopt ...}
+ # prefix options to prefix lopt = {prefix opt opt ...}
+ # initialize set default value for options lopt = {opt value ...}
+ # readonly set readonly flag for options lopt = {opt flag ...}
+ switch -- $cmd {
+ remove {
+ foreach option $lopt {
+ set remove($option) 1
+ }
+ }
+ include {
+ foreach option $lopt {
+ set include($option) 1
+ }
+ }
+ prefix {
+ set prefix [lindex $lopt 0]
+ foreach option [lrange $lopt 1 end] {
+ set rename($option) "-$prefix[string range $option 1 end]"
+ }
+ }
+ rename -
+ readonly -
+ initialize {
+ array set $cmd $lopt
+ }
+ default {
+ return -code error "invalid argument \"$cmd\""
+ }
+ }
+ }
+
+ namespace eval $class {}
+ upvar 0 ${class}::opt classopt
+ upvar 0 ${class}::map classmap
+ upvar 0 ${subclass}::opt subclassopt
+
+ # create resources informations from BWidget resources
+ foreach {option optdesc} [array get subclassopt] {
+ if { (![info exists include] || [info exists include($option)]) &&
+ ![info exists remove($option)] } {
+ set type [lindex $optdesc 0]
+ if { ![string compare $type "Synonym"] } {
+ # option is a synonym
+ set syn [lindex $optdesc 1]
+ if { ![info exists remove($syn)] } {
+ if { [info exists rename($syn)] } {
+ set classopt($option) [list Synonym $rename($syn)]
+ } else {
+ set classopt($option) [list Synonym $syn]
+ }
+ }
+ } else {
+ if { [info exists rename($option)] } {
+ set realopt $option
+ set option $rename($option)
+ } else {
+ set realopt $option
+ }
+ if { [info exists initialize($option)] } {
+ set value $initialize($option)
+ } else {
+ set value [lindex $optdesc 1]
+ }
+ if { [info exists readonly($option)] } {
+ set ro $readonly($option)
+ } else {
+ set ro [lindex $optdesc 2]
+ }
+ set classopt($option) [list $type $value $ro [lindex $optdesc 3]]
+ lappend classmap($option) $subpath $subclass $realopt
+ }
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Widget::declare
+# Declares new options to BWidget class.
+# ------------------------------------------------------------------------------
+proc Widget::declare { class optlist } {
+ variable _optiontype
+
+ namespace eval $class {}
+ upvar 0 ${class}::opt classopt
+
+ foreach optdesc $optlist {
+ set option [lindex $optdesc 0]
+ set optdesc [lrange $optdesc 1 end]
+ set type [lindex $optdesc 0]
+
+ if { ![info exists _optiontype($type)] } {
+ # invalid resource type
+ return -code error "invalid option type \"$type\""
+ }
+
+ if { ![string compare $type "Synonym"] } {
+ # test existence of synonym option
+ set syn [lindex $optdesc 1]
+ if { ![info exists classopt($syn)] } {
+ return -code error "unknow option \"$syn\" for Synonym \"$option\""
+ }
+ set classopt($option) [list Synonym $syn]
+ continue
+ }
+
+ # all other resource may have default value, readonly flag and
+ # optional arg depending on type
+ set value [lindex $optdesc 1]
+ set ro [lindex $optdesc 2]
+ set arg [lindex $optdesc 3]
+
+ if { ![string compare $type "BwResource"] } {
+ # We don't keep BwResource. We simplify to type of sub BWidget
+ set subclass [lindex $arg 0]
+ set realopt [lindex $arg 1]
+ if { ![string length $realopt] } {
+ set realopt $option
+ }
+
+ upvar 0 ${subclass}::opt subclassopt
+ if { ![info exists subclassopt($realopt)] } {
+ return -code error "unknow option \"$realopt\""
+ }
+ set suboptdesc $subclassopt($realopt)
+ if { $value == "" } {
+ # We initialize default value
+ set value [lindex $suboptdesc 1]
+ }
+ set type [lindex $suboptdesc 0]
+ set ro [lindex $suboptdesc 2]
+ set arg [lindex $suboptdesc 3]
+ set classopt($option) [list $type $value $ro $arg]
+ continue
+ }
+
+ # retreive default value for TkResource
+ if { ![string compare $type "TkResource"] } {
+ set tkwidget [lindex $arg 0]
+ set realopt [lindex $arg 1]
+ if { ![string length $realopt] } {
+ set realopt $option
+ }
+ set tkoptions [_get_tkwidget_options $tkwidget]
+ if { ![string length $value] } {
+ # We initialize default value
+ set value [lindex [lindex $tkoptions [lsearch $tkoptions [list $realopt *]]] end]
+ }
+ set classopt($option) [list TkResource $value $ro [list $tkwidget $realopt]]
+ continue
+ }
+
+ # for any other resource type, we keep original optdesc
+ set classopt($option) [list $type $value $ro $arg]
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Widget::addmap
+# ------------------------------------------------------------------------------
+proc Widget::addmap { class subclass subpath options } {
+ upvar 0 ${class}::map classmap
+
+ foreach {option realopt} $options {
+ if { ![string length $realopt] } {
+ set realopt $option
+ }
+ lappend classmap($option) $subpath $subclass $realopt
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Widget::syncoptions
+# ------------------------------------------------------------------------------
+proc Widget::syncoptions { class subclass subpath options } {
+ upvar 0 ${class}::sync classync
+
+ foreach {option realopt} $options {
+ if { ![string length $realopt] } {
+ set realopt $option
+ }
+ set classync($option) [list $subpath $subclass $realopt]
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Widget::init
+# ------------------------------------------------------------------------------
+proc Widget::init { class path options } {
+ variable _class
+ variable _optiontype
+
+ upvar 0 ${class}::opt classopt
+ upvar 0 ${class}::map classmap
+ upvar 0 ${class}::$path:opt pathopt
+ upvar 0 ${class}::$path:mod pathmod
+
+ catch {unset pathopt}
+ catch {unset pathmod}
+ set fpath ".#BWidgetClass#$class"
+ regsub -all "::" $class "" rdbclass
+ if { ![winfo exists $fpath] } {
+ frame $fpath -class $rdbclass
+ }
+ foreach {option optdesc} [array get classopt] {
+ set type [lindex $optdesc 0]
+ if { ![string compare $type "Synonym"] } {
+ set option [lindex $optdesc 1]
+ set optdesc $classopt($option)
+ set type [lindex $optdesc 0]
+ }
+ if { ![string compare $type "TkResource"] } {
+ set alt [lindex [lindex $optdesc 3] 1]
+ } else {
+ set alt ""
+ }
+ set optdb [lindex [_configure_option $option $alt] 0]
+ set def [option get $fpath $optdb $rdbclass]
+ if { [string length $def] } {
+ set pathopt($option) $def
+ } else {
+ set pathopt($option) [lindex $optdesc 1]
+ }
+ set pathmod($option) 0
+ }
+
+ set _class($path) $class
+ foreach {option value} $options {
+ if { ![info exists classopt($option)] } {
+ unset pathopt
+ unset pathmod
+ return -code error "unknown option \"$option\""
+ }
+ set optdesc $classopt($option)
+ set type [lindex $optdesc 0]
+ if { ![string compare $type "Synonym"] } {
+ set option [lindex $optdesc 1]
+ set optdesc $classopt($option)
+ set type [lindex $optdesc 0]
+ }
+ set pathopt($option) [$_optiontype($type) $option $value [lindex $optdesc 3]]
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Widget::destroy
+# ------------------------------------------------------------------------------
+proc Widget::destroy { path } {
+ variable _class
+
+ set class $_class($path)
+ upvar 0 ${class}::$path:opt pathopt
+ upvar 0 ${class}::$path:mod pathmod
+
+ catch {unset pathopt}
+ catch {unset pathmod}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Widget::configure
+# ------------------------------------------------------------------------------
+proc Widget::configure { path options } {
+ set len [llength $options]
+ if { $len <= 1 } {
+ return [_get_configure $path $options]
+ } elseif { $len % 2 == 1 } {
+ return -code error "incorrect number of arguments"
+ }
+
+ variable _class
+ variable _optiontype
+
+ set class $_class($path)
+ upvar 0 ${class}::opt classopt
+ upvar 0 ${class}::map classmap
+ upvar 0 ${class}::$path:opt pathopt
+ upvar 0 ${class}::$path:mod pathmod
+
+ set window [_get_window $class $path]
+ foreach {option value} $options {
+ if { ![info exists classopt($option)] } {
+ return -code error "unknown option \"$option\""
+ }
+ set optdesc $classopt($option)
+ set type [lindex $optdesc 0]
+ if { ![string compare $type "Synonym"] } {
+ set option [lindex $optdesc 1]
+ set optdesc $classopt($option)
+ set type [lindex $optdesc 0]
+ }
+ if { ![lindex $optdesc 2] } {
+ set curval $pathopt($option)
+ set newval [$_optiontype($type) $option $value [lindex $optdesc 3]]
+ if { [info exists classmap($option)] } {
+ foreach {subpath subclass realopt} $classmap($option) {
+ if { [string length $subclass] } {
+ ${subclass}::configure $window$subpath $realopt $newval
+ } else {
+ $window$subpath configure $realopt $newval
+ }
+ }
+ }
+ set pathopt($option) $newval
+ set pathmod($option) [expr {[string compare $newval $curval] != 0}]
+ }
+ }
+
+ return {}
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Widget::cget
+# ------------------------------------------------------------------------------
+proc Widget::cget { path option } {
+ variable _class
+
+ if { ![info exists _class($path)] } {
+ return -code error "unknown widget $path"
+ }
+
+ set class $_class($path)
+ upvar 0 ${class}::opt classopt
+ upvar 0 ${class}::sync classync
+ upvar 0 ${class}::$path:opt pathopt
+
+ if { ![info exists classopt($option)] } {
+ return -code error "unknown option \"$option\""
+ }
+ set optdesc $classopt($option)
+ set type [lindex $optdesc 0]
+ if { ![string compare $type "Synonym"] } {
+ set option [lindex $optdesc 1]
+ }
+
+ if { [info exists classync($option)] } {
+ set window [_get_window $class $path]
+ foreach {subpath subclass realopt} $classync($option) {
+ if { [string length $subclass] } {
+ set pathopt($option) [${subclass}::cget $window$subpath $realopt]
+ } else {
+ set pathopt($option) [$window$subpath cget $realopt]
+ }
+ }
+ }
+
+ return $pathopt($option)
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Widget::subcget
+# ------------------------------------------------------------------------------
+proc Widget::subcget { path subwidget } {
+ variable _class
+
+ set class $_class($path)
+ upvar 0 ${class}::map classmap
+ upvar 0 ${class}::$path:opt pathopt
+
+ set result {}
+ foreach {option map} [array get classmap] {
+ foreach {subpath subclass realopt} $map {
+ if { ![string compare $subpath $subwidget] } {
+ lappend result $realopt $pathopt($option)
+ }
+ }
+ }
+ return $result
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Widget::hasChanged
+# ------------------------------------------------------------------------------
+proc Widget::hasChanged { path option pvalue } {
+ upvar $pvalue value
+ variable _class
+
+ set class $_class($path)
+ upvar 0 ${class}::$path:opt pathopt
+ upvar 0 ${class}::$path:mod pathmod
+
+ set value $pathopt($option)
+ set result $pathmod($option)
+ set pathmod($option) 0
+
+ return $result
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Widget::setoption
+# ------------------------------------------------------------------------------
+proc Widget::setoption { path option value } {
+ variable _class
+
+ set class $_class($path)
+ upvar 0 ${class}::$path:opt pathopt
+
+ set pathopt($option) $value
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Widget::getoption
+# ------------------------------------------------------------------------------
+proc Widget::getoption { path option } {
+ variable _class
+
+ set class $_class($path)
+ upvar 0 ${class}::$path:opt pathopt
+
+ return $pathopt($option)
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Widget::_get_window
+# returns the window corresponding to widget path
+# ------------------------------------------------------------------------------
+proc Widget::_get_window { class path } {
+ set idx [string last "#" $path]
+ if { $idx != -1 && ![string compare [string range $path [expr {$idx+1}] end] $class] } {
+ return [string range $path 0 [expr {$idx-1}]]
+ } else {
+ return $path
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Widget::_get_configure
+# returns the configuration list of options
+# (as tk widget do - [$w configure ?option?])
+# ------------------------------------------------------------------------------
+proc Widget::_get_configure { path options } {
+ variable _class
+
+ set class $_class($path)
+ upvar 0 ${class}::opt classopt
+ upvar 0 ${class}::map classmap
+ upvar 0 ${class}::$path:opt pathopt
+ upvar 0 ${class}::$path:mod pathmod
+
+ set len [llength $options]
+ if { !$len } {
+ set result {}
+ foreach option [lsort [array names classopt]] {
+ set optdesc $classopt($option)
+ set type [lindex $optdesc 0]
+ if { ![string compare $type "Synonym"] } {
+ set syn $option
+ set option [lindex $optdesc 1]
+ set optdesc $classopt($option)
+ set type [lindex $optdesc 0]
+ } else {
+ set syn ""
+ }
+ if { ![string compare $type "TkResource"] } {
+ set alt [lindex [lindex $optdesc 3] 1]
+ } else {
+ set alt ""
+ }
+ set res [_configure_option $option $alt]
+ if { $syn == "" } {
+ lappend result [concat $option $res [list [lindex $optdesc 1]] [list [cget $path $option]]]
+ } else {
+ lappend result [list $syn [lindex $res 0]]
+ }
+ }
+ return $result
+ } elseif { $len == 1 } {
+ set option [lindex $options 0]
+ if { ![info exists classopt($option)] } {
+ return -code error "unknown option \"$option\""
+ }
+ set optdesc $classopt($option)
+ set type [lindex $optdesc 0]
+ if { ![string compare $type "Synonym"] } {
+ set option [lindex $optdesc 1]
+ set optdesc $classopt($option)
+ set type [lindex $optdesc 0]
+ }
+ if { ![string compare $type "TkResource"] } {
+ set alt [lindex [lindex $optdesc 3] 1]
+ } else {
+ set alt ""
+ }
+ set res [_configure_option $option $alt]
+ return [concat $option $res [list [lindex $optdesc 1]] [list [cget $path $option]]]
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Widget::_configure_option
+# ------------------------------------------------------------------------------
+proc Widget::_configure_option { option altopt } {
+ variable _optiondb
+ variable _optionclass
+
+ if { [info exists _optiondb($option)] } {
+ set optdb $_optiondb($option)
+ } else {
+ set optdb [string range $option 1 end]
+ }
+ if { [info exists _optionclass($option)] } {
+ set optclass $_optionclass($option)
+ } elseif { [string length $altopt] } {
+ if { [info exists _optionclass($altopt)] } {
+ set optclass $_optionclass($altopt)
+ } else {
+ set optclass [string range $altopt 1 end]
+ }
+ } else {
+ set optclass [string range $option 1 end]
+ }
+ return [list $optdb $optclass]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Widget::_get_tkwidget_options
+# ------------------------------------------------------------------------------
+proc Widget::_get_tkwidget_options { tkwidget } {
+ variable _tk_widget
+ variable _optiondb
+ variable _optionclass
+
+ if { ![info exists _tk_widget($tkwidget)] } {
+ set widget [$tkwidget ".#BWidget#$tkwidget"]
+ set config [$widget configure]
+ foreach optlist $config {
+ set opt [lindex $optlist 0]
+ if { [llength $optlist] == 2 } {
+ set refsyn [lindex $optlist 1]
+ # search for class
+ set idx [lsearch $config [list * $refsyn *]]
+ if { $idx == -1 } {
+ if { [string index $refsyn 0] == "-" } {
+ # search for option (tk8.1b1 bug)
+ set idx [lsearch $config [list $refsyn * *]]
+ } else {
+ # last resort
+ set idx [lsearch $config [list -[string tolower $refsyn] * *]]
+ }
+ if { $idx == -1 } {
+ # fed up with "can't read classopt()"
+ return -code error "can't find option of synonym $opt"
+ }
+ }
+ set syn [lindex [lindex $config $idx] 0]
+ set def [lindex [lindex $config $idx] 3]
+ lappend _tk_widget($tkwidget) [list $opt $syn $def]
+ } else {
+ set def [lindex $optlist 3]
+ lappend _tk_widget($tkwidget) [list $opt $def]
+ set _optiondb($opt) [lindex $optlist 1]
+ set _optionclass($opt) [lindex $optlist 2]
+ }
+ }
+ }
+ return $_tk_widget($tkwidget)
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Widget::_test_tkresource
+# ------------------------------------------------------------------------------
+proc Widget::_test_tkresource { option value arg } {
+ set tkwidget [lindex $arg 0]
+ set realopt [lindex $arg 1]
+ set path ".#BWidget#$tkwidget"
+ set old [$path cget $realopt]
+ $path configure $realopt $value
+ set res [$path cget $realopt]
+ $path configure $realopt $old
+
+ return $res
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Widget::_test_bwresource
+# ------------------------------------------------------------------------------
+proc Widget::_test_bwresource { option value arg } {
+ return -code error "bad option type BwResource in widget"
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Widget::_test_synonym
+# ------------------------------------------------------------------------------
+proc Widget::_test_synonym { option value arg } {
+ return -code error "bad option type Synonym in widget"
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Widget::_test_string
+# ------------------------------------------------------------------------------
+proc Widget::_test_string { option value arg } {
+ return $value
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Widget::_test_flag
+# ------------------------------------------------------------------------------
+proc Widget::_test_flag { option value arg } {
+ set len [string length $value]
+ set res ""
+ for {set i 0} {$i < $len} {incr i} {
+ set c [string index $value $i]
+ if { [string first $c $arg] == -1 } {
+ return -code error "bad [string range $option 1 end] value \"$value\": characters must be in \"$arg\""
+ }
+ if { [string first $c $res] == -1 } {
+ append res $c
+ }
+ }
+ return $res
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Widget::_test_enum
+# ------------------------------------------------------------------------------
+proc Widget::_test_enum { option value arg } {
+ if { [lsearch $arg $value] == -1 } {
+ set last [lindex $arg end]
+ set sub [lreplace $arg end end]
+ if { [llength $sub] } {
+ set str "[join $sub ", "] or $last"
+ } else {
+ set str $last
+ }
+ return -code error "bad [string range $option 1 end] value \"$value\": must be $str"
+ }
+ return $value
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Widget::_test_int
+# ------------------------------------------------------------------------------
+proc Widget::_test_int { option value arg } {
+ set binf [lindex $arg 0]
+ set bsup [lindex $arg 1]
+ if { $binf != "" } {set binf ">$binf"}
+ if { $bsup != "" } {set bsup "<$bsup"}
+ if { [catch {expr $value}] || $value != int($value) ||
+ !($binf == "" || [expr $value$binf]) ||
+ !($bsup == "" || [expr $value$bsup]) } {
+ return -code error "bad [string range $option 1 end] value \"$value\": must be integer $binf $bsup"
+ }
+ return $value
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Widget::_test_boolean
+# ------------------------------------------------------------------------------
+proc Widget::_test_boolean { option value arg } {
+ if { $value == 1 ||
+ ![string compare $value "true"] ||
+ ![string compare $value "yes"] } {
+ set value 1
+ } elseif { $value == 0 ||
+ ![string compare $value "false"] ||
+ ![string compare $value "no"] } {
+ set value 0
+ } else {
+ return -code error "bad [string range $option 1 end] value \"$value\": must be boolean"
+ }
+ return $value
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Widget::focusNext
+# Same as tk_focusNext, but call Widget::focusOK
+# ------------------------------------------------------------------------------
+proc Widget::focusNext { w } {
+ set cur $w
+ while 1 {
+
+ # Descend to just before the first child of the current widget.
+
+ set parent $cur
+ set children [winfo children $cur]
+ set i -1
+
+ # Look for the next sibling that isn't a top-level.
+
+ while 1 {
+ incr i
+ if {$i < [llength $children]} {
+ set cur [lindex $children $i]
+ if {[winfo toplevel $cur] == $cur} {
+ continue
+ } else {
+ break
+ }
+ }
+
+ # No more siblings, so go to the current widget's parent.
+ # If it's a top-level, break out of the loop, otherwise
+ # look for its next sibling.
+
+ set cur $parent
+ if {[winfo toplevel $cur] == $cur} {
+ break
+ }
+ set parent [winfo parent $parent]
+ set children [winfo children $parent]
+ set i [lsearch -exact $children $cur]
+ }
+ if {($cur == $w) || [focusOK $cur]} {
+ return $cur
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Widget::focusPrev
+# Same as tk_focusPrev, but call Widget::focusOK
+# ------------------------------------------------------------------------------
+proc Widget::focusPrev { w } {
+ set cur $w
+ while 1 {
+
+ # Collect information about the current window's position
+ # among its siblings. Also, if the window is a top-level,
+ # then reposition to just after the last child of the window.
+
+ if {[winfo toplevel $cur] == $cur} {
+ set parent $cur
+ set children [winfo children $cur]
+ set i [llength $children]
+ } else {
+ set parent [winfo parent $cur]
+ set children [winfo children $parent]
+ set i [lsearch -exact $children $cur]
+ }
+
+ # Go to the previous sibling, then descend to its last descendant
+ # (highest in stacking order. While doing this, ignore top-levels
+ # and their descendants. When we run out of descendants, go up
+ # one level to the parent.
+
+ while {$i > 0} {
+ incr i -1
+ set cur [lindex $children $i]
+ if {[winfo toplevel $cur] == $cur} {
+ continue
+ }
+ set parent $cur
+ set children [winfo children $parent]
+ set i [llength $children]
+ }
+ set cur $parent
+ if {($cur == $w) || [focusOK $cur]} {
+ return $cur
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Widget::focusOK
+# Same as tk_focusOK, but handles -editable option and whole tags list.
+# ------------------------------------------------------------------------------
+proc Widget::focusOK { w } {
+ set code [catch {$w cget -takefocus} value]
+ if { $code == 1 } {
+ return 0
+ }
+ if {($code == 0) && ($value != "")} {
+ if {$value == 0} {
+ return 0
+ } elseif {$value == 1} {
+ return [winfo viewable $w]
+ } else {
+ set value [uplevel \#0 $value $w]
+ if {$value != ""} {
+ return $value
+ }
+ }
+ }
+ if {![winfo viewable $w]} {
+ return 0
+ }
+ set code [catch {$w cget -state} value]
+ if {($code == 0) && ($value == "disabled")} {
+ return 0
+ }
+ set code [catch {$w cget -editable} value]
+ if {($code == 0) && !$value} {
+ return 0
+ }
+
+ set top [winfo toplevel $w]
+ foreach tags [bindtags $w] {
+ if { [string compare $tags $top] &&
+ [string compare $tags "all"] &&
+ [regexp Key [bind $tags]] } {
+ return 1
+ }
+ }
+ return 0
+}
Deleted: grass/trunk/lib/external/bwidget/xpm2image.tcl
===================================================================
--- grass/trunk/lib/external/bwidget/xpm2image.tcl 2009-01-04 14:35:05 UTC (rev 35192)
+++ grass/trunk/lib/external/bwidget/xpm2image.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,115 +0,0 @@
-# ------------------------------------------------------------------------------
-# xpm2image.tcl
-# Slightly modified xpm-to-image command
-# $Id$
-# ------------------------------------------------------------------------------
-#
-# Copyright 1996 by Roger E. Critchlow Jr., San Francisco, California
-# All rights reserved, fair use permitted, caveat emptor.
-# rec at elf.org
-#
-# ------------------------------------------------------------------------------
-
-proc xpm-to-image { file } {
- set f [open $file]
- set string [read $f]
- close $f
-
- #
- # parse the strings in the xpm data
- #
- set xpm {}
- foreach line [split $string "\n"] {
- if {[regexp {^"([^\"]*)"} $line all meat]} {
- if {[string first XPMEXT $meat] == 0} {
- break
- }
- lappend xpm $meat
- }
- }
- #
- # extract the sizes in the xpm data
- #
- set sizes [lindex $xpm 0]
- set nsizes [llength $sizes]
- if { $nsizes == 4 || $nsizes == 6 || $nsizes == 7 } {
- set data(width) [lindex $sizes 0]
- set data(height) [lindex $sizes 1]
- set data(ncolors) [lindex $sizes 2]
- set data(chars_per_pixel) [lindex $sizes 3]
- set data(x_hotspot) 0
- set data(y_hotspot) 0
- if {[llength $sizes] >= 6} {
- set data(x_hotspot) [lindex $sizes 4]
- set data(y_hotspot) [lindex $sizes 5]
- }
- } else {
- error "size line {$sizes} in $file did not compute"
- }
-
- #
- # extract the color definitions in the xpm data
- #
- foreach line [lrange $xpm 1 $data(ncolors)] {
- set colors [split $line \t]
- set cname [lindex $colors 0]
- lappend data(cnames) $cname
- if { [string length $cname] != $data(chars_per_pixel) } {
- error "color definition {$line} in file $file has a bad size color name"
- }
- foreach record [lrange $colors 1 end] {
- set key [lindex $record 0]
- set color [string tolower [join [lrange $record 1 end] { }]]
- set data(color-$key-$cname) $color
- if { ![string compare $color "none"] } {
- set data(transparent) $cname
- }
- }
- foreach key {c g g4 m} {
- if {[info exists data(color-$key-$cname)]} {
- set color $data(color-$key-$cname)
- set data(color-$cname) $color
- set data(cname-$color) $cname
- lappend data(colors) $color
- break
- }
- }
- if { ![info exists data(color-$cname)] } {
- error "color definition {$line} in $file failed to define a color"
- }
- }
-
- #
- # extract the image data in the xpm data
- #
- set image [image create photo -width $data(width) -height $data(height)]
- set y 0
- foreach line [lrange $xpm [expr 1+$data(ncolors)] [expr 1+$data(ncolors)+$data(height)]] {
- set x 0
- set pixels {}
- while { [string length $line] > 0 } {
- set pixel [string range $line 0 [expr {$data(chars_per_pixel)-1}]]
- set c $data(color-$pixel)
- if { ![string compare $c none] } {
- if { [string length $pixels] } {
- $image put [list $pixels] -to [expr {$x-[llength $pixels]}] $y
- set pixels {}
- }
- } else {
- lappend pixels $c
- }
- set line [string range $line $data(chars_per_pixel) end]
- incr x
- }
- if { [llength $pixels] } {
- $image put [list $pixels] -to [expr {$x-[llength $pixels]}] $y
- }
- incr y
- }
-
- #
- # return the image
- #
- return $image
-}
-
Copied: grass/trunk/lib/external/bwidget/xpm2image.tcl (from rev 35192, grass/trunk/lib/external/bwidget/xpm2image.tcl)
===================================================================
--- grass/trunk/lib/external/bwidget/xpm2image.tcl (rev 0)
+++ grass/trunk/lib/external/bwidget/xpm2image.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,115 @@
+# ------------------------------------------------------------------------------
+# xpm2image.tcl
+# Slightly modified xpm-to-image command
+# $Id$
+# ------------------------------------------------------------------------------
+#
+# Copyright 1996 by Roger E. Critchlow Jr., San Francisco, California
+# All rights reserved, fair use permitted, caveat emptor.
+# rec at elf.org
+#
+# ------------------------------------------------------------------------------
+
+proc xpm-to-image { file } {
+ set f [open $file]
+ set string [read $f]
+ close $f
+
+ #
+ # parse the strings in the xpm data
+ #
+ set xpm {}
+ foreach line [split $string "\n"] {
+ if {[regexp {^"([^\"]*)"} $line all meat]} {
+ if {[string first XPMEXT $meat] == 0} {
+ break
+ }
+ lappend xpm $meat
+ }
+ }
+ #
+ # extract the sizes in the xpm data
+ #
+ set sizes [lindex $xpm 0]
+ set nsizes [llength $sizes]
+ if { $nsizes == 4 || $nsizes == 6 || $nsizes == 7 } {
+ set data(width) [lindex $sizes 0]
+ set data(height) [lindex $sizes 1]
+ set data(ncolors) [lindex $sizes 2]
+ set data(chars_per_pixel) [lindex $sizes 3]
+ set data(x_hotspot) 0
+ set data(y_hotspot) 0
+ if {[llength $sizes] >= 6} {
+ set data(x_hotspot) [lindex $sizes 4]
+ set data(y_hotspot) [lindex $sizes 5]
+ }
+ } else {
+ error "size line {$sizes} in $file did not compute"
+ }
+
+ #
+ # extract the color definitions in the xpm data
+ #
+ foreach line [lrange $xpm 1 $data(ncolors)] {
+ set colors [split $line \t]
+ set cname [lindex $colors 0]
+ lappend data(cnames) $cname
+ if { [string length $cname] != $data(chars_per_pixel) } {
+ error "color definition {$line} in file $file has a bad size color name"
+ }
+ foreach record [lrange $colors 1 end] {
+ set key [lindex $record 0]
+ set color [string tolower [join [lrange $record 1 end] { }]]
+ set data(color-$key-$cname) $color
+ if { ![string compare $color "none"] } {
+ set data(transparent) $cname
+ }
+ }
+ foreach key {c g g4 m} {
+ if {[info exists data(color-$key-$cname)]} {
+ set color $data(color-$key-$cname)
+ set data(color-$cname) $color
+ set data(cname-$color) $cname
+ lappend data(colors) $color
+ break
+ }
+ }
+ if { ![info exists data(color-$cname)] } {
+ error "color definition {$line} in $file failed to define a color"
+ }
+ }
+
+ #
+ # extract the image data in the xpm data
+ #
+ set image [image create photo -width $data(width) -height $data(height)]
+ set y 0
+ foreach line [lrange $xpm [expr 1+$data(ncolors)] [expr 1+$data(ncolors)+$data(height)]] {
+ set x 0
+ set pixels {}
+ while { [string length $line] > 0 } {
+ set pixel [string range $line 0 [expr {$data(chars_per_pixel)-1}]]
+ set c $data(color-$pixel)
+ if { ![string compare $c none] } {
+ if { [string length $pixels] } {
+ $image put [list $pixels] -to [expr {$x-[llength $pixels]}] $y
+ set pixels {}
+ }
+ } else {
+ lappend pixels $c
+ }
+ set line [string range $line $data(chars_per_pixel) end]
+ incr x
+ }
+ if { [llength $pixels] } {
+ $image put [list $pixels] -to [expr {$x-[llength $pixels]}] $y
+ }
+ incr y
+ }
+
+ #
+ # return the image
+ #
+ return $image
+}
+
Copied: grass/trunk/lib/gtcltk (from rev 35191, grass/trunk/lib/gtcltk)
Property changes on: grass/trunk/lib/gtcltk
___________________________________________________________________
Name: svn:ignore
+ *OBJ*
Deleted: grass/trunk/lib/gtcltk/Makefile
===================================================================
--- grass/trunk/lib/gtcltk/Makefile 2009-01-04 14:30:59 UTC (rev 35191)
+++ grass/trunk/lib/gtcltk/Makefile 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,11 +0,0 @@
-MODULE_TOPDIR = ../..
-
-PGM=grocat
-include $(MODULE_TOPDIR)/include/Make/Etc.make
-include $(MODULE_TOPDIR)/include/Make/NoHtml.make
-
-default: etc $(ETC)/gtcltk
-
-$(ETC)/gtcltk: *.tcl
- if [ ! -d $(ETC)/gtcltk ]; then $(MKDIR) $(ETC)/gtcltk; fi
- for file in *.tcl ; do $(INSTALL_DATA) $$file $(ETC)/gtcltk/ ; done
Copied: grass/trunk/lib/gtcltk/Makefile (from rev 35191, grass/trunk/lib/gtcltk/Makefile)
===================================================================
--- grass/trunk/lib/gtcltk/Makefile (rev 0)
+++ grass/trunk/lib/gtcltk/Makefile 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,11 @@
+MODULE_TOPDIR = ../..
+
+PGM=grocat
+include $(MODULE_TOPDIR)/include/Make/Etc.make
+include $(MODULE_TOPDIR)/include/Make/NoHtml.make
+
+default: etc $(ETC)/gtcltk
+
+$(ETC)/gtcltk: *.tcl
+ if [ ! -d $(ETC)/gtcltk ]; then $(MKDIR) $(ETC)/gtcltk; fi
+ for file in *.tcl ; do $(INSTALL_DATA) $$file $(ETC)/gtcltk/ ; done
Deleted: grass/trunk/lib/gtcltk/gmsg.tcl
===================================================================
--- grass/trunk/lib/gtcltk/gmsg.tcl 2009-01-04 14:30:59 UTC (rev 35191)
+++ grass/trunk/lib/gtcltk/gmsg.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,27 +0,0 @@
-#############################################################################
-#
-# gmsg.tcl
-#
-# MODULE: Grass Tcl/Tk I18n wrapper
-# AUTHOR(S): Alex Shevlakov alex at motivation.ru
-# PURPOSE: I18N Tcl-Tk based GUI text strings wrapper procedure
-#
-# COPYRIGHT: (C) 2000 by the GRASS Development Team
-#
-# This program is free software under the GNU General Public
-# License (>=v2). Read the file COPYING that comes with GRASS
-# for details.
-#
-#############################################################################
-
-
-if [catch {package require msgcat}] {
- proc G_msg {message} {
- return $message
- }
-} else {
- ::msgcat::mcload $env(GISBASE)/etc/msgs
- proc G_msg {message} {
- return [::msgcat::mc $message]
- }
-}
Copied: grass/trunk/lib/gtcltk/gmsg.tcl (from rev 35191, grass/trunk/lib/gtcltk/gmsg.tcl)
===================================================================
--- grass/trunk/lib/gtcltk/gmsg.tcl (rev 0)
+++ grass/trunk/lib/gtcltk/gmsg.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,27 @@
+#############################################################################
+#
+# gmsg.tcl
+#
+# MODULE: Grass Tcl/Tk I18n wrapper
+# AUTHOR(S): Alex Shevlakov alex at motivation.ru
+# PURPOSE: I18N Tcl-Tk based GUI text strings wrapper procedure
+#
+# COPYRIGHT: (C) 2000 by the GRASS Development Team
+#
+# This program is free software under the GNU General Public
+# License (>=v2). Read the file COPYING that comes with GRASS
+# for details.
+#
+#############################################################################
+
+
+if [catch {package require msgcat}] {
+ proc G_msg {message} {
+ return $message
+ }
+} else {
+ ::msgcat::mcload $env(GISBASE)/etc/msgs
+ proc G_msg {message} {
+ return [::msgcat::mc $message]
+ }
+}
Deleted: grass/trunk/lib/gtcltk/grocat.c
===================================================================
--- grass/trunk/lib/gtcltk/grocat.c 2009-01-04 14:30:59 UTC (rev 35191)
+++ grass/trunk/lib/gtcltk/grocat.c 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,50 +0,0 @@
-
-/****************************************************************************
- *
- * MODULE: grocat
- * AUTHOR(S): Paul Kelly
- * PURPOSE: Copies stdin to stdout in line-buffered mode until end
- * of file is received.
- * Used with Tcl/Tk gronsole system to merge stdout and
- * stderr streams to be caught by Tcl "open" command.
- * COPYRIGHT: (C) 2006 by the GRASS Development Team
- *
- * This program is free software under the GNU General Public
- * License (>=v2). Read the file COPYING that comes with GRASS
- * for details.
- *
- *****************************************************************************/
-
-#include <stdio.h>
-#include <stdlib.h>
-
-int main(void)
-{
- int inchar, outchar;
- char inbuff[1024], outbuff[1024];
-
- /* stdin and stdout both line-buffered */
- if (setvbuf(stdin, inbuff, _IOLBF, sizeof(inbuff))) {
- fprintf(stderr, "grocat: Can't set stdin to line-buffered mode!\n");
- exit(EXIT_FAILURE);
- }
- if (setvbuf(stdout, outbuff, _IOLBF, sizeof(outbuff))) {
- fprintf(stderr, "grocat: Can't set stdout to line-buffered mode!\n");
- exit(EXIT_FAILURE);
- }
-
- while ((inchar = getc(stdin)) != EOF) {
- /* Read a character at a time from stdin until EOF
- * and copy to stdout */
- outchar = putc(inchar, stdout);
- if (outchar != inchar) {
- fprintf(stderr, "grocat: Error writing to stdout!\n");
- exit(EXIT_FAILURE);
- }
- }
-
- /* Flush in case last line wasn't terminated properly or something */
- fflush(stdout);
-
- exit(EXIT_SUCCESS);
-}
Copied: grass/trunk/lib/gtcltk/grocat.c (from rev 35191, grass/trunk/lib/gtcltk/grocat.c)
===================================================================
--- grass/trunk/lib/gtcltk/grocat.c (rev 0)
+++ grass/trunk/lib/gtcltk/grocat.c 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,50 @@
+
+/****************************************************************************
+ *
+ * MODULE: grocat
+ * AUTHOR(S): Paul Kelly
+ * PURPOSE: Copies stdin to stdout in line-buffered mode until end
+ * of file is received.
+ * Used with Tcl/Tk gronsole system to merge stdout and
+ * stderr streams to be caught by Tcl "open" command.
+ * COPYRIGHT: (C) 2006 by the GRASS Development Team
+ *
+ * This program is free software under the GNU General Public
+ * License (>=v2). Read the file COPYING that comes with GRASS
+ * for details.
+ *
+ *****************************************************************************/
+
+#include <stdio.h>
+#include <stdlib.h>
+
+int main(void)
+{
+ int inchar, outchar;
+ char inbuff[1024], outbuff[1024];
+
+ /* stdin and stdout both line-buffered */
+ if (setvbuf(stdin, inbuff, _IOLBF, sizeof(inbuff))) {
+ fprintf(stderr, "grocat: Can't set stdin to line-buffered mode!\n");
+ exit(EXIT_FAILURE);
+ }
+ if (setvbuf(stdout, outbuff, _IOLBF, sizeof(outbuff))) {
+ fprintf(stderr, "grocat: Can't set stdout to line-buffered mode!\n");
+ exit(EXIT_FAILURE);
+ }
+
+ while ((inchar = getc(stdin)) != EOF) {
+ /* Read a character at a time from stdin until EOF
+ * and copy to stdout */
+ outchar = putc(inchar, stdout);
+ if (outchar != inchar) {
+ fprintf(stderr, "grocat: Error writing to stdout!\n");
+ exit(EXIT_FAILURE);
+ }
+ }
+
+ /* Flush in case last line wasn't terminated properly or something */
+ fflush(stdout);
+
+ exit(EXIT_SUCCESS);
+}
Deleted: grass/trunk/lib/gtcltk/gronsole.tcl
===================================================================
--- grass/trunk/lib/gtcltk/gronsole.tcl 2009-01-04 14:30:59 UTC (rev 35191)
+++ grass/trunk/lib/gtcltk/gronsole.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,531 +0,0 @@
-
-############################################################################
-#
-# LIBRARY: Gronsole program run and output widget
-# AUTHOR(S): Cedric Shock (cedricgrass AT shockfamily.net)
-# Based on lib/gis/gui.tcl
-# PURPOSE: Runs programs, displays output
-# COPYRIGHT: (C) 2006 Grass Development Team
-#
-# This program is free software under the GNU General Public
-# License (>=v2). Read the file COPYING that comes with GRASS
-# for details.
-#
-#############################################################################
-
-namespace eval Gronsole {
- variable _data
- variable _options
-
- set _options [list [list -clickcmd clickCmd ClickCmd {} {}]]
-
- proc ::Gronsole { path args } { return [eval Gronsole::create $path $args] }
- proc use {} {}
-}
-
-proc Gronsole::dooptions {path args init} {
- variable _data
- variable _options
-
- foreach opt $_options {
- set sw [lindex $opt 0]
- set db [lindex $opt 1]
- set def [lindex $opt 4]
- if {[set idx [lsearch -exact $args $sw]] != -1} {
- set _data($path,$db) [lindex $args [expr $idx + 1]]
- set args [concat [lrange $args 0 [expr $idx - 1]] [lrange $args [expr $idx + 2] end]]
- } elseif {$init} {
- set _data($path,$db) $def
- }
- }
-}
-
-proc Gronsole::create {path args} {
- global keycontrol
- global bgcolor
- variable _data
-
- set args [Gronsole::dooptions $path $args 1]
-
- set gronsolewin [ScrolledWindow $path -relief flat -borderwidth 1 -auto horizontal]
- set gronsole [eval text $gronsolewin.text $args]
- $gronsolewin setwidget $gronsole
-
-
- set _data($path,count) 0
-
- bind $path.text <Destroy> "Gronsole::_destroy $path"
- bind $path.text <$keycontrol-c> "tk_textCopy %W"
- bind $path.text <$keycontrol-v> "tk_textPaste %W"
- bind $path.text <$keycontrol-x> "tk_textCut %W"
-
- rename $path ::$path:scrollwin
- proc ::$path { cmd args } "return \[eval Gronsole::\$cmd $path \$args\]"
- return $path
-}
-
-proc Gronsole::configure { path args } {
- variable _options
- variable _data
- if {$args == {}} {
- set res {}
- foreach opt $_options {
- set sw [lindex $opt 0]
- set db [lindex $opt 1]
- set title [lindex $opt 2]
- lappend res [list $sw $db $title $_data($path,$db) $_data($path,$db)]
- }
- return [concat $res [$path.text configure]]
- }
-
- set args [Gronsole::dooptions $path $args 0]
-
- $path.text configure $args
-
- return
-}
-
-
-proc Gronsole::cget { path option } {
- variable _options
- variable _data
- if {[lsearch -exact $_options $option] != -1} {
- set res $_data($path,$option)
- } else {
- set res [$path.text cget $option]
- }
- return $res
-}
-
-proc Gronsole::_destroy { path } {
- variable _data
-
- array unset _data "$path,*"
-
- catch {rename $path {}}
-}
-
-##########################################################################
-# Public contents management
-
-proc Gronsole::clear {path} {
- variable _data
-
- $path.text delete 1.0 end
-}
-
-
-# save text in output window
-proc Gronsole::save {path} {
- global env
-
- set dtxt $path.text
-
- if ![catch {$dtxt get sel.first}] {
- set svtxt [$dtxt get sel.first sel.last]
- } else {
- set svtxt [$dtxt get 1.0 end]
- }
-
- set types {
- {{TXT} {.txt}}
- }
-
- if { [info exists HOME] } {
- set dir $env(HOME)
- set path [tk_getSaveFile -initialdir $dir -filetypes $types \
- -defaultextension ".txt"]
- } else {
- set path [tk_getSaveFile -filetypes $types \
- -defaultextension ".txt"]
- }
-
- if { $path == "" } { return }
-
- set txtfile [open $path w]
- puts $txtfile $svtxt
- close $txtfile
- return
-}
-
-proc Gronsole::destroy_command {path ci} {
- variable _data
-
- catch {close $_data($path,$ci,fh)}
-
- if {[info exists _data($path,$ci,donecmd)] && $_data($path,$ci,donecmd) != {}} {
- eval $_data($path,$ci,donecmd)
- }
-
- set textarea $path.text
- set frame $_data($path,$ci,frame)
-
- set indices [$textarea tag ranges cmd$ci]
-
- eval $textarea delete $indices
-
- destroy $frame
-
- array unset _data "$path,$ci,*"
-}
-
-##########################################################################
-# Private
-
-proc Gronsole::do_click {path ci} {
- variable _data
-
- # Use this commands click command if it exists
- if {[info exists _data($path,$ci,clickCmd)]} {
- set cc $_data($path,$ci,clickCmd)
- } else {
- set cc $_data($path,clickCmd)
- }
- if {$cc != {}} {
- eval $cc $ci [list $_data($path,$ci,cmd)]
- }
-}
-
-proc Gronsole::create_command {path cmd} {
- variable _data
- set textarea $path.text
-
- incr _data($path,count)
- set ci $_data($path,count)
- set _data($path,$ci,cmd) $cmd
-
- set module [lindex $cmd 0]
- set icon [icon module $module]
-
- set frame $textarea.cmd$ci
-
- set _data($path,$ci,frame) $frame
-
- frame $frame
- frame $frame.cmdline
- set tagframe [frame $frame.cmdline.tags]
- set cmdlabel [label $frame.cmdline.cmd -textvariable Gronsole::_data($path,$ci,cmd) -anchor nw]
- bind $cmdlabel <Button-1> "Gronsole::do_click $path $ci"
- # set cmdlabel [text $frame.cmdline.cmd -height 1 -width 10]
- # $cmdlabel insert end $cmd
- set ex [button $frame.cmdline.eX -text "X" -command "Gronsole::destroy_command $path $ci"]
- pack $ex -side right
- pack $frame.cmdline.tags -side right
- set iconwidth ""
- if {$icon != 0} {
- set iconwidth " - \[winfo width $frame.cmdline.icon\]"
- button $frame.cmdline.icon -image $icon -anchor n -command "Gronsole::do_click $path $ci"
- pack $frame.cmdline.icon -side left
- }
- pack $frame.cmdline.cmd -side left -expand yes -fill x
- pack $frame.cmdline -side top -expand yes -fill x
- set pbar [ProgressBar $frame.progress -fg green -bg white -height 20 -relief raised \
- -maximum 100 -variable Gronsole::_data($path,$ci,progress)]
- pack $pbar -side left
- set _data($path,$ci,progress) -1
- set _data($path,$ci,progressbar) $pbar
- set _data($path,$ci,tags) {}
-
- $textarea insert end "\n" [list cmd$ci e1]
- $textarea insert end "\n" [list cmd$ci e2]
- $textarea mark set cmdinsert$ci "end - 2 char"
-
- $textarea window create cmdinsert$ci -window $frame
- $textarea tag add cmd$ci $frame
- $textarea insert cmdinsert$ci "$cmd\n" [list cmd$ci e2]
- # $textarea tag add cmd$ci "cmdinsert$ci - 1 char"
- # $textarea tag add e2 "cmdinsert$ci - 1 char"
-
- $textarea tag configure e1 -elide 1
- $textarea tag configure e2 -elide 1
-
-
- set pspace 12
- $pbar configure -width [expr [winfo width $textarea] - $pspace]
-# $pbar configure -width [expr [winfo width $textarea] - $pspace] -height 20
-
- bind $textarea <Configure> "+catch {$pbar configure -width \[expr \[winfo width $textarea\] - $pspace\]}"
-
-
- bind $textarea <Configure> "+catch {$cmdlabel configure -wraplength \[expr \[winfo width $textarea\] - $pspace - \[winfo width $tagframe\] - \[winfo width $ex\] $iconwidth\]}"
-
- # bind $cmdlabel <Configure> "$cmdlabel configure -wraplength \[winfo width $cmdlabel\]"
-
- return $ci
-}
-
-##########################################################################
-# Public tag management. add_data_tag is private
-
-proc Gronsole::set_click_command {path ci cmd} {
- variable _data
- set _data($path,$ci,clickCmd) $cmd
-}
-
-proc Gronsole::show_hide_tag_data {path ci tag} {
- variable _data
- set textarea $path.text
-
- set e [$textarea tag cget cmd$ci-$tag -elide]
- if {$e == {}} {
- $textarea tag configure cmd$ci-$tag -elide 1
- } else {
- $textarea tag configure cmd$ci-$tag -elide {}
- }
-}
-
-proc Gronsole::add_tag {path ci tag} {
- variable _data
- set textarea $path.text
- set frame $_data($path,$ci,frame)
- if {[lsearch -exact $_data($path,$ci,tags) $tag] != -1} {
- return
- }
- lappend _data($path,$ci,tags) $tag
- button $frame.cmdline.tags.tag$tag -text $tag -relief flat
- set icon [icon status $tag]
- if {$icon != 0} {
- $frame.cmdline.tags.tag$tag configure -image $icon
- }
- pack $frame.cmdline.tags.tag$tag -side right
-}
-
-# This is private:
-proc Gronsole::add_data_tag {path ci tag} {
- variable _data
- set textarea $path.text
- set frame $_data($path,$ci,frame)
- if {[lsearch -exact $_data($path,$ci,tags) $tag] != -1} {
- return
- }
- Gronsole::add_tag $path $ci $tag
- $frame.cmdline.tags.tag$tag configure -relief raised -command "Gronsole::show_hide_tag_data $path $ci $tag"
-}
-
-proc Gronsole::remove_tag {path ci tag} {
- variable _data
- set frame $_data($path,$ci,frame)
- pack forget $frame.cmdline.tags.tag$tag
- # destroy $frame.cmdline.tags.tag$tag
-}
-
-
-##########################################################################
-# Private (stuff done when commands are run)
-
-# This procedure doesn't really seem necessary. I've left it in
-# in case there is something I'm missing (M. Barton 29 April 2007)
-proc Gronsole::progress {path ci percent} {
- variable _data
-
- if {[info exists _data($path,$ci,progress)]} {
- set _data($path,$ci,progress) $percent
- }
- if {[info exists _data($path,$ci,progressbar)]} {
- set pbar $_data($path,$ci,progressbar)
- }
-
- if {$percent == -1} {
- $pbar configure -height 1
- } else {
- $pbar configure -height 20
- }
- # it seems that there is a bug in ProgressBar and it is not always updated ->
- $pbar _modify
-}
-
-proc Gronsole::output_to_gronsole {path mark ci tags str} {
- set outtext $path.text
-
- set tagbase cmd$ci
- # Back out backspaces:
- if {0} {
- while {[set idx [string first "\b" $str]] != -1} {
- set last [expr $idx - 1]
- set str1 [string range $str 1 $last]
- set first [expr $idx + 1]
- set str [string range $str $first end]
- set pos [$outtext index "$mark - 1 chars"]
- $outtext delete $pos
- $outtext insert $mark $str1 $tags
- }
- }
- if { [regexp -- {^GRASS_INFO_([^(]+)\(([0-9]+),([0-9]+)\): (.+)$} $str match key message_pid message_id val rest] } {
- set lkey [string tolower $key]
- Gronsole::add_tag $path $ci $lkey
- set icon [icon status $lkey]
- if {$icon != 0} {
- $outtext image create $mark -image $icon
- # $outtext tag add $tagbase "$mark -1 char"
- }
- $outtext insert $mark $val $tagbase
- } elseif { [regexp -- {^GRASS_INFO_PERCENT: (.+)$} $str match val rest] } {
- if { $val > 0 && $val < 100} {
- set Gronsole::_data($path,$ci,progress) $val
-# Gronsole::progress $path $ci $val
- } else {
-# Gronsole::progress $path $ci -1
- set Gronsole::_data($path,$ci,progress) -1
- $outtext insert $mark "\n" $tags
- }
- } elseif { [regexp -- {^GRASS_INFO_END.+} $str match key rest] } {
- # nothing
- } else {
- $outtext insert $mark $str $tags
- }
-}
-
-proc Gronsole::readeof {path ci mark fh} {
- variable _data
- # This doesn't actually get the result
- set result [catch {close $fh} error_text]
- set _data($path,$ci,result) $result
- # if {$result == 0} {
- # Gronsole::add_tag $path $ci success
- # set donecmd $_data($path,$ci,successcmd)
- #} else {
- # Gronsole::add_tag $path $ci failure
- # set donecmd $_data($path,$ci,failurecmd)
- #}
- Gronsole::remove_tag $path $ci running
-}
-
-proc Gronsole::readout {path ci mark fh} {
-
- set lines {}
-
- while {[gets $fh line] >= 0} {
- lappend lines $line
- }
-
- if {[llength $lines] != 0} {
- Gronsole::add_data_tag $path $ci out
- }
- foreach line $lines {
- Gronsole::output_to_gronsole $path $mark $ci [list cmd$ci cmd$ci-out] "$line\n"
- }
- $path.text see $mark
-}
-
-proc Gronsole::done_command {path ci} {
- variable _data
-
- if {[info exists _data($path,$ci,donecmd)] && $_data($path,$ci,donecmd) != {}} {
- set donecmd $_data($path,$ci,donecmd)
- set _data($path,$ci,donecmd) {}
- }
-
- if {[info exists donecmd] && $donecmd != {}} {
- eval $donecmd
- }
-}
-
-proc Gronsole::file_callback {path ci mark fh} {
- if [eof $fh] {
- Gronsole::readeof $path $ci $mark $fh
- Gronsole::done_command $path $ci
- } else {
- Gronsole::readout $path $ci $mark $fh
- }
-}
-
-proc Gronsole::execbg {path ci mark fh} {
- fconfigure $fh -blocking 0
- fileevent $fh readable [list Gronsole::file_callback $path $ci $mark $fh]
-}
-
-proc Gronsole::execwait {path ci mark fh} {
- while {! [eof $fh]} {
- Gronsole::readout $path $ci $mark $fh
- update
- }
- Gronsole::readeof $path $ci $mark $fh
- update
-}
-
-proc Gronsole::execout {path cmd ci execcmd} {
- global env
-
- set mark cmdinsert$ci
-
- # Actually run the program
- # |& grocat merges stdout and stderr because Tcl treats
- # anything written to stderr as an error condition
- set cmd [concat | $cmd |& $env(GISBASE)/etc/grocat]
-
- set message_env [exec g.gisenv get=GRASS_MESSAGE_FORMAT]
- set env(GRASS_MESSAGE_FORMAT) gui
- set ret [catch {open $cmd r} fh]
- set env(GRASS_MESSAGE_FORMAT) $message_env
-
- set _data($path,$ci,fh) $fh
-
- if { $ret } {
- Gronsole::remove_tag $path $ci running
- Gronsole::add_tag $path $ci error
- catch {close $fh}
- Gronsole::done_command $path $ci
- } {
- $execcmd $path $ci $mark $fh
- }
- update idletasks
-}
-
-##########################################################################
-# Public interface for running commands
-
-proc Gronsole::annotate {path cmd tags} {
- variable _data
-
- set ci [Gronsole::create_command $path $cmd]
-
- foreach tag $tags {
- Gronsole::add_tag $path $ci $tag
- }
-
- $path.text yview end
-
- return $ci
-}
-
-proc Gronsole::annotate_text {path ci text} {
- Gronsole::output_to_gronsole $path cmdinsert$ci $ci [list cmd$ci cmd$ci-out] $text
- $path.text see cmdinsert$ci
-}
-
-proc Gronsole::run {path cmd tags donecmd} {
- variable _data
-
- set tags [concat running $tags]
-
- set ci [Gronsole::annotate $path $cmd $tags]
-
- set _data($path,$ci,donecmd) $donecmd
-
- Gronsole::execout $path $cmd $ci Gronsole::execbg
-
- return $ci
-}
-
-proc Gronsole::run_wait {path cmd tags} {
- set tags [concat running $tags]
-
- set ci [Gronsole::annotate $path $cmd $tags]
-
- Gronsole::execout $path $cmd $ci Gronsole::execwait
-}
-
-proc Gronsole::run_xterm {path cmd tags} {
- global env
- global mingw
-
- Gronsole::annotate $path $cmd [concat xterm $tags]
-
- if { $mingw == "1" } {
- exec -- cmd.exe /c start $env(GISBASE)/etc/grass-run.bat $cmd &
- } else {
- exec -- $env(GISBASE)/etc/grass-xterm-wrapper -name xterm-grass -e $env(GISBASE)/etc/grass-run.sh $cmd &
- }
-
- update idletasks
-}
Copied: grass/trunk/lib/gtcltk/gronsole.tcl (from rev 35191, grass/trunk/lib/gtcltk/gronsole.tcl)
===================================================================
--- grass/trunk/lib/gtcltk/gronsole.tcl (rev 0)
+++ grass/trunk/lib/gtcltk/gronsole.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,531 @@
+
+############################################################################
+#
+# LIBRARY: Gronsole program run and output widget
+# AUTHOR(S): Cedric Shock (cedricgrass AT shockfamily.net)
+# Based on lib/gis/gui.tcl
+# PURPOSE: Runs programs, displays output
+# COPYRIGHT: (C) 2006 Grass Development Team
+#
+# This program is free software under the GNU General Public
+# License (>=v2). Read the file COPYING that comes with GRASS
+# for details.
+#
+#############################################################################
+
+namespace eval Gronsole {
+ variable _data
+ variable _options
+
+ set _options [list [list -clickcmd clickCmd ClickCmd {} {}]]
+
+ proc ::Gronsole { path args } { return [eval Gronsole::create $path $args] }
+ proc use {} {}
+}
+
+proc Gronsole::dooptions {path args init} {
+ variable _data
+ variable _options
+
+ foreach opt $_options {
+ set sw [lindex $opt 0]
+ set db [lindex $opt 1]
+ set def [lindex $opt 4]
+ if {[set idx [lsearch -exact $args $sw]] != -1} {
+ set _data($path,$db) [lindex $args [expr $idx + 1]]
+ set args [concat [lrange $args 0 [expr $idx - 1]] [lrange $args [expr $idx + 2] end]]
+ } elseif {$init} {
+ set _data($path,$db) $def
+ }
+ }
+}
+
+proc Gronsole::create {path args} {
+ global keycontrol
+ global bgcolor
+ variable _data
+
+ set args [Gronsole::dooptions $path $args 1]
+
+ set gronsolewin [ScrolledWindow $path -relief flat -borderwidth 1 -auto horizontal]
+ set gronsole [eval text $gronsolewin.text $args]
+ $gronsolewin setwidget $gronsole
+
+
+ set _data($path,count) 0
+
+ bind $path.text <Destroy> "Gronsole::_destroy $path"
+ bind $path.text <$keycontrol-c> "tk_textCopy %W"
+ bind $path.text <$keycontrol-v> "tk_textPaste %W"
+ bind $path.text <$keycontrol-x> "tk_textCut %W"
+
+ rename $path ::$path:scrollwin
+ proc ::$path { cmd args } "return \[eval Gronsole::\$cmd $path \$args\]"
+ return $path
+}
+
+proc Gronsole::configure { path args } {
+ variable _options
+ variable _data
+ if {$args == {}} {
+ set res {}
+ foreach opt $_options {
+ set sw [lindex $opt 0]
+ set db [lindex $opt 1]
+ set title [lindex $opt 2]
+ lappend res [list $sw $db $title $_data($path,$db) $_data($path,$db)]
+ }
+ return [concat $res [$path.text configure]]
+ }
+
+ set args [Gronsole::dooptions $path $args 0]
+
+ $path.text configure $args
+
+ return
+}
+
+
+proc Gronsole::cget { path option } {
+ variable _options
+ variable _data
+ if {[lsearch -exact $_options $option] != -1} {
+ set res $_data($path,$option)
+ } else {
+ set res [$path.text cget $option]
+ }
+ return $res
+}
+
+proc Gronsole::_destroy { path } {
+ variable _data
+
+ array unset _data "$path,*"
+
+ catch {rename $path {}}
+}
+
+##########################################################################
+# Public contents management
+
+proc Gronsole::clear {path} {
+ variable _data
+
+ $path.text delete 1.0 end
+}
+
+
+# save text in output window
+proc Gronsole::save {path} {
+ global env
+
+ set dtxt $path.text
+
+ if ![catch {$dtxt get sel.first}] {
+ set svtxt [$dtxt get sel.first sel.last]
+ } else {
+ set svtxt [$dtxt get 1.0 end]
+ }
+
+ set types {
+ {{TXT} {.txt}}
+ }
+
+ if { [info exists HOME] } {
+ set dir $env(HOME)
+ set path [tk_getSaveFile -initialdir $dir -filetypes $types \
+ -defaultextension ".txt"]
+ } else {
+ set path [tk_getSaveFile -filetypes $types \
+ -defaultextension ".txt"]
+ }
+
+ if { $path == "" } { return }
+
+ set txtfile [open $path w]
+ puts $txtfile $svtxt
+ close $txtfile
+ return
+}
+
+proc Gronsole::destroy_command {path ci} {
+ variable _data
+
+ catch {close $_data($path,$ci,fh)}
+
+ if {[info exists _data($path,$ci,donecmd)] && $_data($path,$ci,donecmd) != {}} {
+ eval $_data($path,$ci,donecmd)
+ }
+
+ set textarea $path.text
+ set frame $_data($path,$ci,frame)
+
+ set indices [$textarea tag ranges cmd$ci]
+
+ eval $textarea delete $indices
+
+ destroy $frame
+
+ array unset _data "$path,$ci,*"
+}
+
+##########################################################################
+# Private
+
+proc Gronsole::do_click {path ci} {
+ variable _data
+
+ # Use this commands click command if it exists
+ if {[info exists _data($path,$ci,clickCmd)]} {
+ set cc $_data($path,$ci,clickCmd)
+ } else {
+ set cc $_data($path,clickCmd)
+ }
+ if {$cc != {}} {
+ eval $cc $ci [list $_data($path,$ci,cmd)]
+ }
+}
+
+proc Gronsole::create_command {path cmd} {
+ variable _data
+ set textarea $path.text
+
+ incr _data($path,count)
+ set ci $_data($path,count)
+ set _data($path,$ci,cmd) $cmd
+
+ set module [lindex $cmd 0]
+ set icon [icon module $module]
+
+ set frame $textarea.cmd$ci
+
+ set _data($path,$ci,frame) $frame
+
+ frame $frame
+ frame $frame.cmdline
+ set tagframe [frame $frame.cmdline.tags]
+ set cmdlabel [label $frame.cmdline.cmd -textvariable Gronsole::_data($path,$ci,cmd) -anchor nw]
+ bind $cmdlabel <Button-1> "Gronsole::do_click $path $ci"
+ # set cmdlabel [text $frame.cmdline.cmd -height 1 -width 10]
+ # $cmdlabel insert end $cmd
+ set ex [button $frame.cmdline.eX -text "X" -command "Gronsole::destroy_command $path $ci"]
+ pack $ex -side right
+ pack $frame.cmdline.tags -side right
+ set iconwidth ""
+ if {$icon != 0} {
+ set iconwidth " - \[winfo width $frame.cmdline.icon\]"
+ button $frame.cmdline.icon -image $icon -anchor n -command "Gronsole::do_click $path $ci"
+ pack $frame.cmdline.icon -side left
+ }
+ pack $frame.cmdline.cmd -side left -expand yes -fill x
+ pack $frame.cmdline -side top -expand yes -fill x
+ set pbar [ProgressBar $frame.progress -fg green -bg white -height 20 -relief raised \
+ -maximum 100 -variable Gronsole::_data($path,$ci,progress)]
+ pack $pbar -side left
+ set _data($path,$ci,progress) -1
+ set _data($path,$ci,progressbar) $pbar
+ set _data($path,$ci,tags) {}
+
+ $textarea insert end "\n" [list cmd$ci e1]
+ $textarea insert end "\n" [list cmd$ci e2]
+ $textarea mark set cmdinsert$ci "end - 2 char"
+
+ $textarea window create cmdinsert$ci -window $frame
+ $textarea tag add cmd$ci $frame
+ $textarea insert cmdinsert$ci "$cmd\n" [list cmd$ci e2]
+ # $textarea tag add cmd$ci "cmdinsert$ci - 1 char"
+ # $textarea tag add e2 "cmdinsert$ci - 1 char"
+
+ $textarea tag configure e1 -elide 1
+ $textarea tag configure e2 -elide 1
+
+
+ set pspace 12
+ $pbar configure -width [expr [winfo width $textarea] - $pspace]
+# $pbar configure -width [expr [winfo width $textarea] - $pspace] -height 20
+
+ bind $textarea <Configure> "+catch {$pbar configure -width \[expr \[winfo width $textarea\] - $pspace\]}"
+
+
+ bind $textarea <Configure> "+catch {$cmdlabel configure -wraplength \[expr \[winfo width $textarea\] - $pspace - \[winfo width $tagframe\] - \[winfo width $ex\] $iconwidth\]}"
+
+ # bind $cmdlabel <Configure> "$cmdlabel configure -wraplength \[winfo width $cmdlabel\]"
+
+ return $ci
+}
+
+##########################################################################
+# Public tag management. add_data_tag is private
+
+proc Gronsole::set_click_command {path ci cmd} {
+ variable _data
+ set _data($path,$ci,clickCmd) $cmd
+}
+
+proc Gronsole::show_hide_tag_data {path ci tag} {
+ variable _data
+ set textarea $path.text
+
+ set e [$textarea tag cget cmd$ci-$tag -elide]
+ if {$e == {}} {
+ $textarea tag configure cmd$ci-$tag -elide 1
+ } else {
+ $textarea tag configure cmd$ci-$tag -elide {}
+ }
+}
+
+proc Gronsole::add_tag {path ci tag} {
+ variable _data
+ set textarea $path.text
+ set frame $_data($path,$ci,frame)
+ if {[lsearch -exact $_data($path,$ci,tags) $tag] != -1} {
+ return
+ }
+ lappend _data($path,$ci,tags) $tag
+ button $frame.cmdline.tags.tag$tag -text $tag -relief flat
+ set icon [icon status $tag]
+ if {$icon != 0} {
+ $frame.cmdline.tags.tag$tag configure -image $icon
+ }
+ pack $frame.cmdline.tags.tag$tag -side right
+}
+
+# This is private:
+proc Gronsole::add_data_tag {path ci tag} {
+ variable _data
+ set textarea $path.text
+ set frame $_data($path,$ci,frame)
+ if {[lsearch -exact $_data($path,$ci,tags) $tag] != -1} {
+ return
+ }
+ Gronsole::add_tag $path $ci $tag
+ $frame.cmdline.tags.tag$tag configure -relief raised -command "Gronsole::show_hide_tag_data $path $ci $tag"
+}
+
+proc Gronsole::remove_tag {path ci tag} {
+ variable _data
+ set frame $_data($path,$ci,frame)
+ pack forget $frame.cmdline.tags.tag$tag
+ # destroy $frame.cmdline.tags.tag$tag
+}
+
+
+##########################################################################
+# Private (stuff done when commands are run)
+
+# This procedure doesn't really seem necessary. I've left it in
+# in case there is something I'm missing (M. Barton 29 April 2007)
+proc Gronsole::progress {path ci percent} {
+ variable _data
+
+ if {[info exists _data($path,$ci,progress)]} {
+ set _data($path,$ci,progress) $percent
+ }
+ if {[info exists _data($path,$ci,progressbar)]} {
+ set pbar $_data($path,$ci,progressbar)
+ }
+
+ if {$percent == -1} {
+ $pbar configure -height 1
+ } else {
+ $pbar configure -height 20
+ }
+ # it seems that there is a bug in ProgressBar and it is not always updated ->
+ $pbar _modify
+}
+
+proc Gronsole::output_to_gronsole {path mark ci tags str} {
+ set outtext $path.text
+
+ set tagbase cmd$ci
+ # Back out backspaces:
+ if {0} {
+ while {[set idx [string first "\b" $str]] != -1} {
+ set last [expr $idx - 1]
+ set str1 [string range $str 1 $last]
+ set first [expr $idx + 1]
+ set str [string range $str $first end]
+ set pos [$outtext index "$mark - 1 chars"]
+ $outtext delete $pos
+ $outtext insert $mark $str1 $tags
+ }
+ }
+ if { [regexp -- {^GRASS_INFO_([^(]+)\(([0-9]+),([0-9]+)\): (.+)$} $str match key message_pid message_id val rest] } {
+ set lkey [string tolower $key]
+ Gronsole::add_tag $path $ci $lkey
+ set icon [icon status $lkey]
+ if {$icon != 0} {
+ $outtext image create $mark -image $icon
+ # $outtext tag add $tagbase "$mark -1 char"
+ }
+ $outtext insert $mark $val $tagbase
+ } elseif { [regexp -- {^GRASS_INFO_PERCENT: (.+)$} $str match val rest] } {
+ if { $val > 0 && $val < 100} {
+ set Gronsole::_data($path,$ci,progress) $val
+# Gronsole::progress $path $ci $val
+ } else {
+# Gronsole::progress $path $ci -1
+ set Gronsole::_data($path,$ci,progress) -1
+ $outtext insert $mark "\n" $tags
+ }
+ } elseif { [regexp -- {^GRASS_INFO_END.+} $str match key rest] } {
+ # nothing
+ } else {
+ $outtext insert $mark $str $tags
+ }
+}
+
+proc Gronsole::readeof {path ci mark fh} {
+ variable _data
+ # This doesn't actually get the result
+ set result [catch {close $fh} error_text]
+ set _data($path,$ci,result) $result
+ # if {$result == 0} {
+ # Gronsole::add_tag $path $ci success
+ # set donecmd $_data($path,$ci,successcmd)
+ #} else {
+ # Gronsole::add_tag $path $ci failure
+ # set donecmd $_data($path,$ci,failurecmd)
+ #}
+ Gronsole::remove_tag $path $ci running
+}
+
+proc Gronsole::readout {path ci mark fh} {
+
+ set lines {}
+
+ while {[gets $fh line] >= 0} {
+ lappend lines $line
+ }
+
+ if {[llength $lines] != 0} {
+ Gronsole::add_data_tag $path $ci out
+ }
+ foreach line $lines {
+ Gronsole::output_to_gronsole $path $mark $ci [list cmd$ci cmd$ci-out] "$line\n"
+ }
+ $path.text see $mark
+}
+
+proc Gronsole::done_command {path ci} {
+ variable _data
+
+ if {[info exists _data($path,$ci,donecmd)] && $_data($path,$ci,donecmd) != {}} {
+ set donecmd $_data($path,$ci,donecmd)
+ set _data($path,$ci,donecmd) {}
+ }
+
+ if {[info exists donecmd] && $donecmd != {}} {
+ eval $donecmd
+ }
+}
+
+proc Gronsole::file_callback {path ci mark fh} {
+ if [eof $fh] {
+ Gronsole::readeof $path $ci $mark $fh
+ Gronsole::done_command $path $ci
+ } else {
+ Gronsole::readout $path $ci $mark $fh
+ }
+}
+
+proc Gronsole::execbg {path ci mark fh} {
+ fconfigure $fh -blocking 0
+ fileevent $fh readable [list Gronsole::file_callback $path $ci $mark $fh]
+}
+
+proc Gronsole::execwait {path ci mark fh} {
+ while {! [eof $fh]} {
+ Gronsole::readout $path $ci $mark $fh
+ update
+ }
+ Gronsole::readeof $path $ci $mark $fh
+ update
+}
+
+proc Gronsole::execout {path cmd ci execcmd} {
+ global env
+
+ set mark cmdinsert$ci
+
+ # Actually run the program
+ # |& grocat merges stdout and stderr because Tcl treats
+ # anything written to stderr as an error condition
+ set cmd [concat | $cmd |& $env(GISBASE)/etc/grocat]
+
+ set message_env [exec g.gisenv get=GRASS_MESSAGE_FORMAT]
+ set env(GRASS_MESSAGE_FORMAT) gui
+ set ret [catch {open $cmd r} fh]
+ set env(GRASS_MESSAGE_FORMAT) $message_env
+
+ set _data($path,$ci,fh) $fh
+
+ if { $ret } {
+ Gronsole::remove_tag $path $ci running
+ Gronsole::add_tag $path $ci error
+ catch {close $fh}
+ Gronsole::done_command $path $ci
+ } {
+ $execcmd $path $ci $mark $fh
+ }
+ update idletasks
+}
+
+##########################################################################
+# Public interface for running commands
+
+proc Gronsole::annotate {path cmd tags} {
+ variable _data
+
+ set ci [Gronsole::create_command $path $cmd]
+
+ foreach tag $tags {
+ Gronsole::add_tag $path $ci $tag
+ }
+
+ $path.text yview end
+
+ return $ci
+}
+
+proc Gronsole::annotate_text {path ci text} {
+ Gronsole::output_to_gronsole $path cmdinsert$ci $ci [list cmd$ci cmd$ci-out] $text
+ $path.text see cmdinsert$ci
+}
+
+proc Gronsole::run {path cmd tags donecmd} {
+ variable _data
+
+ set tags [concat running $tags]
+
+ set ci [Gronsole::annotate $path $cmd $tags]
+
+ set _data($path,$ci,donecmd) $donecmd
+
+ Gronsole::execout $path $cmd $ci Gronsole::execbg
+
+ return $ci
+}
+
+proc Gronsole::run_wait {path cmd tags} {
+ set tags [concat running $tags]
+
+ set ci [Gronsole::annotate $path $cmd $tags]
+
+ Gronsole::execout $path $cmd $ci Gronsole::execwait
+}
+
+proc Gronsole::run_xterm {path cmd tags} {
+ global env
+ global mingw
+
+ Gronsole::annotate $path $cmd [concat xterm $tags]
+
+ if { $mingw == "1" } {
+ exec -- cmd.exe /c start $env(GISBASE)/etc/grass-run.bat $cmd &
+ } else {
+ exec -- $env(GISBASE)/etc/grass-xterm-wrapper -name xterm-grass -e $env(GISBASE)/etc/grass-run.sh $cmd &
+ }
+
+ update idletasks
+}
Deleted: grass/trunk/lib/gtcltk/options.tcl
===================================================================
--- grass/trunk/lib/gtcltk/options.tcl 2009-01-04 14:30:59 UTC (rev 35191)
+++ grass/trunk/lib/gtcltk/options.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,115 +0,0 @@
-############################################################################
-#
-# LIBRARY: options.tcl gui options
-# AUTHOR(S): Cedric Shock (cedricgrass AT shockfamily.net)
-# PURPOSE: Default options and load user options
-# COPYRIGHT: (C) 2006 GRASS Development Team
-#
-# This program is free software under the GNU General Public
-# License (>=v2). Read the file COPYING that comes with GRASS
-# for details.
-#
-############################################################################
-
-lappend auto_path $env(GISBASE)/bwidget
-package require -exact BWidget 1.2.1
-
-# set background color and help font
-# These globals are still used in a few places by things in gis.m
-set bgcolor HoneyDew2
-
-##############################################################################
-# Create fonts
-
-proc fontcreate {font args} {
- if {[lsearch [font names] $font] == -1} {
- eval font create $font $args
- } else {
- eval font configure $font $args
- }
-}
-
-fontcreate balloon-help -family Helvetica -size -12
-fontcreate default -family Helvetica -size -12
-fontcreate textfont -family Courier -size -12
-fontcreate bolddefault -family Helvetica -size 12 -weight bold
-fontcreate introfont -family Helvetica -size 14 -weight bold
-
-global bolddefault
-global introfont
-global textfont
-global default
-
-##############################################################################
-# Configure balloon help:
-
-DynamicHelp::configure -font balloon-help -fg black -bg "#FFFF77"
-
-##############################################################################
-# Configure almost everything using the options database
-
-# Font to use everywhere
-option add *font default
-# Font in labelframes of labels in bwidgets is prefixed with label:
-option add *labelfont default
-
-# Various background colors
-option add *background #dddddd
-option add *activeBackground #dddddd
-option add *highlightBackground #dddddd
-option add *ButtonBox.background HoneyDew2
-option add *ButtonBox*add.highlightBackground HoneyDew2
-option add *MainFrame.background HoneyDew2
-option add *PanedWindow.background HoneyDew2
-option add *Menu.background HoneyDew2
-option add *listbox.background white
-option add *addindicator.background white
-
-# Things that are selected:
-option add *selectBackground #ffff9b
-option add *selectForeground black
-
-# Menus use active instead of selected
-option add *Menu.activeBackground #ffff9b
-option add *Menu.activeForeground black
-
-# Scrollbar trough color
-option add *troughColor HoneyDew3
-
-# Entry widgets and text widgets should have a white background
-option add *Entry.background white
-option add *entry.background white
-option add *Entry.highlightbackground #dddddd
-option add *entrybg white
-option add *Text.background white
-option add *Entry.font textfont
-option add *Text.font textfont
-
-# Options for map canvases
-option add *mapcanvas.background #eeeeee
-option add *mapcanvas.insertbackground black
-option add *mapcanvas.selectbackground #c4c4c4
-option add *mapcanvas.selectforeground black
-
-
-##############################################################################
-# Platform specific default settings:
-# keycontrol is control key used in copy-paste bindings
-
-set keycontrol "Control"
-
-if {[info exists env(osxaqua)]} {
- set osxaqua $env(osxaqua)
-} else {
- set osxaqua "0"
-}
-
-if { $osxaqua == "1"} {
- set keycontrol "Command"
-}
-
-if {[info exists env(OS)] && $env(OS) == "Windows_NT"} {
- set mingw "1"
-} else {
- set mingw "0"
-}
Copied: grass/trunk/lib/gtcltk/options.tcl (from rev 35191, grass/trunk/lib/gtcltk/options.tcl)
===================================================================
--- grass/trunk/lib/gtcltk/options.tcl (rev 0)
+++ grass/trunk/lib/gtcltk/options.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,115 @@
+############################################################################
+#
+# LIBRARY: options.tcl gui options
+# AUTHOR(S): Cedric Shock (cedricgrass AT shockfamily.net)
+# PURPOSE: Default options and load user options
+# COPYRIGHT: (C) 2006 GRASS Development Team
+#
+# This program is free software under the GNU General Public
+# License (>=v2). Read the file COPYING that comes with GRASS
+# for details.
+#
+############################################################################
+
+lappend auto_path $env(GISBASE)/bwidget
+package require -exact BWidget 1.2.1
+
+# set background color and help font
+# These globals are still used in a few places by things in gis.m
+set bgcolor HoneyDew2
+
+##############################################################################
+# Create fonts
+
+proc fontcreate {font args} {
+ if {[lsearch [font names] $font] == -1} {
+ eval font create $font $args
+ } else {
+ eval font configure $font $args
+ }
+}
+
+fontcreate balloon-help -family Helvetica -size -12
+fontcreate default -family Helvetica -size -12
+fontcreate textfont -family Courier -size -12
+fontcreate bolddefault -family Helvetica -size 12 -weight bold
+fontcreate introfont -family Helvetica -size 14 -weight bold
+
+global bolddefault
+global introfont
+global textfont
+global default
+
+##############################################################################
+# Configure balloon help:
+
+DynamicHelp::configure -font balloon-help -fg black -bg "#FFFF77"
+
+##############################################################################
+# Configure almost everything using the options database
+
+# Font to use everywhere
+option add *font default
+# Font in labelframes of labels in bwidgets is prefixed with label:
+option add *labelfont default
+
+# Various background colors
+option add *background #dddddd
+option add *activeBackground #dddddd
+option add *highlightBackground #dddddd
+option add *ButtonBox.background HoneyDew2
+option add *ButtonBox*add.highlightBackground HoneyDew2
+option add *MainFrame.background HoneyDew2
+option add *PanedWindow.background HoneyDew2
+option add *Menu.background HoneyDew2
+option add *listbox.background white
+option add *addindicator.background white
+
+# Things that are selected:
+option add *selectBackground #ffff9b
+option add *selectForeground black
+
+# Menus use active instead of selected
+option add *Menu.activeBackground #ffff9b
+option add *Menu.activeForeground black
+
+# Scrollbar trough color
+option add *troughColor HoneyDew3
+
+# Entry widgets and text widgets should have a white background
+option add *Entry.background white
+option add *entry.background white
+option add *Entry.highlightbackground #dddddd
+option add *entrybg white
+option add *Text.background white
+option add *Entry.font textfont
+option add *Text.font textfont
+
+# Options for map canvases
+option add *mapcanvas.background #eeeeee
+option add *mapcanvas.insertbackground black
+option add *mapcanvas.selectbackground #c4c4c4
+option add *mapcanvas.selectforeground black
+
+
+##############################################################################
+# Platform specific default settings:
+# keycontrol is control key used in copy-paste bindings
+
+set keycontrol "Control"
+
+if {[info exists env(osxaqua)]} {
+ set osxaqua $env(osxaqua)
+} else {
+ set osxaqua "0"
+}
+
+if { $osxaqua == "1"} {
+ set keycontrol "Command"
+}
+
+if {[info exists env(OS)] && $env(OS) == "Windows_NT"} {
+ set mingw "1"
+} else {
+ set mingw "0"
+}
Deleted: grass/trunk/lib/gtcltk/select.tcl
===================================================================
--- grass/trunk/lib/gtcltk/select.tcl 2009-01-04 14:30:59 UTC (rev 35191)
+++ grass/trunk/lib/gtcltk/select.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -1,316 +0,0 @@
-##########################################################################
-#
-# select.tcl
-#
-# tree/listbox control for interactive selection of GRASS GIS elements
-#
-# Author: Unknown. Possibly Jacques Bouchard, author of tcltkgrass for
-# GRASS 5. Subsequent modifications by members of the GRASS Development
-# team.
-#
-# Last update: September 2007
-#
-# COPYRIGHT: (C) 1999 - 2007 by the GRASS Development Team
-#
-# This program is free software under the GNU General Public
-# License (>=v2). Read the file COPYING that comes with GRASS
-# for details.
-#
-##########################################################################
-# Frame scrolling that works:
-# Scroll if the window exists AND
-# the window is mapped AND
-# This window's parent's descendant has the focus (keyboard or mouse pointer in)
-# We use the parent because the scrollbars are in the parent, and two scrollable
-# Things shouldn't have the same parent.
-
-set bind_scroll_list {}
-
-proc handle_scroll {ammount} {
- global bind_scroll_list
-
- foreach {x y} {-1 -1} {}
-
- set window_gone 0
-
- foreach window $bind_scroll_list {
- if {![winfo exists $window]} {
- set window_gone 1
- continue
- }
- if {![winfo ismapped $window]} continue
- set parent [winfo parent $window]
- set keyboard_focus [focus -displayof $window]
- foreach {x y} [winfo pointerxy $window] {break}
- set mouse_focus [winfo containing -displayof $window $x $y]
- set l [string length $parent]
- if {[string equal -length $l $parent $keyboard_focus] || \
- [string equal -length $l $parent $mouse_focus]} {
- $window yview scroll [expr {-$ammount/120}] units
- }
- }
-
- # We should thin out windows that don't exist anymore if we find them
- if {$window_gone} {
- set new_bind_scroll_list {}
- foreach window $bind_scroll_list {
- if {[winfo exists $window]} {
- lappend new_bind_scroll_list $window
- }
- }
- set bind_scroll_list $new_bind_scroll_list
- }
-}
-
-proc bind_scroll {frame} {
- global bind_scroll_list
-
- lappend bind_scroll_list $frame
-}
-
-bind all <MouseWheel> "handle_scroll %D"
-bind all <Button-4> "handle_scroll 120"
-bind all <Button-5> "handle_scroll -120"
-
-##############################################################
-
-proc GSelect { element args } {
- # startup procedure
-
- set sel [eval [linsert $args 0 GSelect_::create $element]]
- return $sel
-
-}
-
-namespace eval GSelect_ {
- variable count 1
- variable dblclick
- variable array selwin
-}
-
-proc GSelect_::create { element args } {
- # main procedure for creating and managing selection window, which a tree
- # within a scrolling window.
-
- global env id
- variable selwin
- variable count
-
- incr count
- set id $count
-
- set selwin($id,self) selwin
- set title [G_msg "Select item"]
- set selwin($id,selected) {}
-
- if {[lsearch -exact $args "title"] > -1} {
- append title " - [lindex $args [expr [lsearch -exact $args title]+1]]"
- }
-
- # Leave selection on top of caller window till it's closed
- set parentwin "."
- if {[lsearch -exact $args "parent"] > -1} {
- set parentwin [lindex $args [expr [lsearch -exact $args "parent"]+1]]
- if { [string length $parentwin] > 1 } {
- set selwin($id,self) [regsub -all {[[:space:]]|[[:punct:]]} ".selwin[string range $parentwin 1 [string length $parentwin]]" ""]
- } elseif {[lsearch -exact $args "title"] > -1} { set selwin($id,self) [regsub -all {[[:space:]]|[[:punct:]]} ".selwin$title" ""] }
- }
- set selwin($id,self) ".$selwin($id,self)"
- set selftop "$selwin($id,self)top"
-
- # Do not create another select window, if one already exists.
- if {[winfo exists $selwin($id,self)]} {
- raise $selwin($id,self)
- focus $selwin($id,self)
- return
- }
-
- toplevel $selwin($id,self) -width 300 -height 400
- set sw [ScrolledWindow $selwin($id,self).sw -relief sunken -borderwidth 2 ]
-
- wm title $selwin($id,self) $title
- wm transient $selwin($id,self) $parentwin
-
- set tree [Tree $sw.tree \
- -relief flat -borderwidth 0 -width 15 -highlightthickness 0\
- -redraw 1 -dropenabled 1 -dragenabled 1 \
- -opencmd "GSelect_::moddir 1 $sw.tree" \
- -closecmd "GSelect_::moddir 0 $sw.tree"]
-
- $sw setwidget $tree
- bind_scroll $tree
-
- regexp -- {(.+)x(.+)([+-].+)([+-].+)} [wm geometry .] g w h x y
- #set w [expr int(2*$w/3)]
- set w 300
- set h 400
- wm geometry $selwin($id,self) ${w}x$h$x$y
-
- pack $sw -side top -expand yes -fill both
- pack $tree -side top -expand yes -fill both
-
- $tree bindText <ButtonPress-1> "GSelect_::select $id $tree"
- $tree bindImage <ButtonPress-1> "GSelect_::select $id $tree"
- $tree bindText <Double-ButtonPress-1> "GSelect_::selectclose $id $tree"
- $tree bindImage <Double-ButtonPress-1> "GSelect_::selectclose $id $tree"
- if {[lsearch $args "multiple"] >= 0} {
- $tree bindText <Control-ButtonPress-1> "GSelect_::select_toggle $id $tree"
- } else {
- $tree bindText <Control-ButtonPress-1> "GSelect_::select $id $tree"
- }
-
- set location_path "$env(GISDBASE)/$env(LOCATION_NAME)/"
- set current_mapset "$env(MAPSET)"
- set sympath "$env(GISBASE)/etc/symbol/"
-
- # main selection subroutine
- if {$element != "symbol"} {
- foreach dir [exec g.mapsets -p] {
- set windfile "$location_path/$dir/WIND"
- if { ! [ file exists $windfile ] } { continue }
- if { $dir == $current_mapset } {
- $tree insert end root ms_$dir -text $dir -data $dir -open 1 \
- -image [Bitmap::get openfold] -drawcross auto
- } else {
- $tree insert end root ms_$dir -text $dir -data $dir -open 0 \
- -image [Bitmap::get folder] -drawcross auto
- }
- set path "$location_path/$dir/$element/"
- foreach fp [ lsort [glob -nocomplain $path/*] ] {
- set file [file tail $fp]
- $tree insert end ms_$dir $file@$dir -text $file -data $file \
- -image [Bitmap::get file] -drawcross never
- }
- }
- }
-
- # vector symbol selection subroutine
- if {$element == "symbol"} {
- $tree insert end root ms_$sympath -text SYMBOLS -data $sympath -open 1 \
- -image [Bitmap::get openfold] -drawcross auto
-
- foreach ic_dir [ lsort [glob -nocomplain $sympath/*] ] {
- set dir_tail [file tail $ic_dir]
- $tree insert end ms_$sympath ms_$dir_tail -text $dir_tail -data $dir_tail \
- -image [Bitmap::get folder] -drawcross auto
-
- foreach ic_file [ lsort [glob -nocomplain $sympath/$dir_tail/*] ] {
- set file [file tail $ic_file]
- $tree insert end ms_$dir_tail $dir_tail/$file -text $file -data $file \
- -image [Bitmap::get file] -drawcross never
- }
- }
- }
-
- $tree configure -redraw 1
-
- # buttons
- button $selwin($id,self).ok -text [G_msg "Ok"] -command "destroy $selwin($id,self)"
- button $selwin($id,self).cancel -text [G_msg "Cancel"] -command "GSelect_::terminate $id"
-
- pack $selwin($id,self).ok $selwin($id,self).cancel -side left -expand yes
-
-
- # ScrollView
- toplevel $selftop -relief raised -borderwidth 2
- wm protocol $selftop WM_DELETE_WINDOW {
- # don't kill me
- }
- wm overrideredirect $selftop 1
- wm withdraw $selftop
- wm transient $selftop $selwin($id,self)
- ScrollView $selftop.sv -window $tree -fill black
- pack $selftop.sv -fill both -expand yes
-
- wm protocol $selwin($id,self) WM_DELETE_WINDOW "GSelect_::terminate $id"
- tkwait window $selwin($id,self)
-
- destroy $selftop
-
- # return selected elements -- separated by commas if there are > 1 elements
- if { $selwin($id,selected) != "" } {
- set ret ""
- set len [llength $selwin($id,selected)]
- foreach elem $selwin($id,selected) {
- append ret $elem
- if {[lsearch $selwin($id,selected) $elem] != -1 && \
- [lsearch $selwin($id,selected) $elem] < [expr $len-1]} {
- append ret ","
- }
- }
- return $ret
- }
-
- return ""
-}
-
-
-proc GSelect_::select { id tree node } {
- # Single selection (default). Clicking an item will select it and
- # deselect any other item selected
- variable selwin
-
- set parent [$tree parent $node]
- if { $parent == "root" } { return }
-
- $tree selection set $node
- update
- set selwin($id,selected) $node
-}
-
-proc GSelect_::select_toggle { id tree node} {
- # Multiple selections. Ctrl-1 will toggle an item as selected or not selected
- # and add it to a list of selected items
- variable selwin
-
- set parent [$tree parent $node]
- if { $parent == "root" } { return }
-
- if {[lsearch -exact [$tree selection get] $node] >= 0} {
- $tree selection remove $node
- update
- set nodeindex [lsearch $selwin($id,selected) $node]
- if {$nodeindex != -1} {
- set selwin($id,selected) [lreplace $selwin($id,selected) $nodeindex $nodeindex]
- }
- } else {
- $tree selection add $node
- update
- lappend selwin($id,selected) $node
- }
-
- #$tree selection add $node
-# set selwin($id,selected) [string trim $selwin($id,selected) ,]
-}
-
-proc GSelect_::selectclose { id tree node } {
- # return selection and close window (OK button)
- variable selwin
-
- GSelect_::select $id $tree $node
- destroy $selwin($id,self)
-}
-
-
-proc GSelect_::terminate { id } {
- # close window without returning selection (cancel)
- variable selwin
-
- set selwin($id,selected) {}
- destroy $selwin($id,self)
-}
-
-proc GSelect_::moddir { idx tree node } {
- if { $idx && [$tree itemcget $node -drawcross] == "always" } {
- getdir $tree $node [$tree itemcget $node -data]
- if { [llength [$tree nodes $node]] } {
- $tree itemconfigure $node -image [Bitmap::get openfold]
- } else {
- $tree itemconfigure $node -image [Bitmap::get folder]
- }
- } else {
- $tree itemconfigure $node -image [Bitmap::get [lindex {folder openfold} $idx]]
- }
-}
-
-
Copied: grass/trunk/lib/gtcltk/select.tcl (from rev 35191, grass/trunk/lib/gtcltk/select.tcl)
===================================================================
--- grass/trunk/lib/gtcltk/select.tcl (rev 0)
+++ grass/trunk/lib/gtcltk/select.tcl 2009-01-12 11:48:48 UTC (rev 35358)
@@ -0,0 +1,316 @@
+##########################################################################
+#
+# select.tcl
+#
+# tree/listbox control for interactive selection of GRASS GIS elements
+#
+# Author: Unknown. Possibly Jacques Bouchard, author of tcltkgrass for
+# GRASS 5. Subsequent modifications by members of the GRASS Development
+# team.
+#
+# Last update: September 2007
+#
+# COPYRIGHT: (C) 1999 - 2007 by the GRASS Development Team
+#
+# This program is free software under the GNU General Public
+# License (>=v2). Read the file COPYING that comes with GRASS
+# for details.
+#
+##########################################################################
+# Frame scrolling that works:
+# Scroll if the window exists AND
+# the window is mapped AND
+# This window's parent's descendant has the focus (keyboard or mouse pointer in)
+# We use the parent because the scrollbars are in the parent, and two scrollable
+# Things shouldn't have the same parent.
+
+set bind_scroll_list {}
+
+proc handle_scroll {ammount} {
+ global bind_scroll_list
+
+ foreach {x y} {-1 -1} {}
+
+ set window_gone 0
+
+ foreach window $bind_scroll_list {
+ if {![winfo exists $window]} {
+ set window_gone 1
+ continue
+ }
+ if {![winfo ismapped $window]} continue
+ set parent [winfo parent $window]
+ set keyboard_focus [focus -displayof $window]
+ foreach {x y} [winfo pointerxy $window] {break}
+ set mouse_focus [winfo containing -displayof $window $x $y]
+ set l [string length $parent]
+ if {[string equal -length $l $parent $keyboard_focus] || \
+ [string equal -length $l $parent $mouse_focus]} {
+ $window yview scroll [expr {-$ammount/120}] units
+ }
+ }
+
+ # We should thin out windows that don't exist anymore if we find them
+ if {$window_gone} {
+ set new_bind_scroll_list {}
+ foreach window $bind_scroll_list {
+ if {[winfo exists $window]} {
+ lappend new_bind_scroll_list $window
+ }
+ }
+ set bind_scroll_list $new_bind_scroll_list
+ }
+}
+
+proc bind_scroll {frame} {
+ global bind_scroll_list
+
+ lappend bind_scroll_list $frame
+}
+
+bind all <MouseWheel> "handle_scroll %D"
+bind all <Button-4> "handle_scroll 120"
+bind all <Button-5> "handle_scroll -120"
+
+##############################################################
+
+proc GSelect { element args } {
+ # startup procedure
+
+ set sel [eval [linsert $args 0 GSelect_::create $element]]
+ return $sel
+
+}
+
+namespace eval GSelect_ {
+ variable count 1
+ variable dblclick
+ variable array selwin
+}
+
+proc GSelect_::create { element args } {
+ # main procedure for creating and managing selection window, which a tree
+ # within a scrolling window.
+
+ global env id
+ variable selwin
+ variable count
+
+ incr count
+ set id $count
+
+ set selwin($id,self) selwin
+ set title [G_msg "Select item"]
+ set selwin($id,selected) {}
+
+ if {[lsearch -exact $args "title"] > -1} {
+ append title " - [lindex $args [expr [lsearch -exact $args title]+1]]"
+ }
+
+ # Leave selection on top of caller window till it's closed
+ set parentwin "."
+ if {[lsearch -exact $args "parent"] > -1} {
+ set parentwin [lindex $args [expr [lsearch -exact $args "parent"]+1]]
+ if { [string length $parentwin] > 1 } {
+ set selwin($id,self) [regsub -all {[[:space:]]|[[:punct:]]} ".selwin[string range $parentwin 1 [string length $parentwin]]" ""]
+ } elseif {[lsearch -exact $args "title"] > -1} { set selwin($id,self) [regsub -all {[[:space:]]|[[:punct:]]} ".selwin$title" ""] }
+ }
+ set selwin($id,self) ".$selwin($id,self)"
+ set selftop "$selwin($id,self)top"
+
+ # Do not create another select window, if one already exists.
+ if {[winfo exists $selwin($id,self)]} {
+ raise $selwin($id,self)
+ focus $selwin($id,self)
+ return
+ }
+
+ toplevel $selwin($id,self) -width 300 -height 400
+ set sw [ScrolledWindow $selwin($id,self).sw -relief sunken -borderwidth 2 ]
+
+ wm title $selwin($id,self) $title
+ wm transient $selwin($id,self) $parentwin
+
+ set tree [Tree $sw.tree \
+ -relief flat -borderwidth 0 -width 15 -highlightthickness 0\
+ -redraw 1 -dropenabled 1 -dragenabled 1 \
+ -opencmd "GSelect_::moddir 1 $sw.tree" \
+ -closecmd "GSelect_::moddir 0 $sw.tree"]
+
+ $sw setwidget $tree
+ bind_scroll $tree
+
+ regexp -- {(.+)x(.+)([+-].+)([+-].+)} [wm geometry .] g w h x y
+ #set w [expr int(2*$w/3)]
+ set w 300
+ set h 400
+ wm geometry $selwin($id,self) ${w}x$h$x$y
+
+ pack $sw -side top -expand yes -fill both
+ pack $tree -side top -expand yes -fill both
+
+ $tree bindText <ButtonPress-1> "GSelect_::select $id $tree"
+ $tree bindImage <ButtonPress-1> "GSelect_::select $id $tree"
+ $tree bindText <Double-ButtonPress-1> "GSelect_::selectclose $id $tree"
+ $tree bindImage <Double-ButtonPress-1> "GSelect_::selectclose $id $tree"
+ if {[lsearch $args "multiple"] >= 0} {
+ $tree bindText <Control-ButtonPress-1> "GSelect_::select_toggle $id $tree"
+ } else {
+ $tree bindText <Control-ButtonPress-1> "GSelect_::select $id $tree"
+ }
+
+ set location_path "$env(GISDBASE)/$env(LOCATION_NAME)/"
+ set current_mapset "$env(MAPSET)"
+ set sympath "$env(GISBASE)/etc/symbol/"
+
+ # main selection subroutine
+ if {$element != "symbol"} {
+ foreach dir [exec g.mapsets -p] {
+ set windfile "$location_path/$dir/WIND"
+ if { ! [ file exists $windfile ] } { continue }
+ if { $dir == $current_mapset } {
+ $tree insert end root ms_$dir -text $dir -data $dir -open 1 \
+ -image [Bitmap::get openfold] -drawcross auto
+ } else {
+ $tree insert end root ms_$dir -text $dir -data $dir -open 0 \
+ -image [Bitmap::get folder] -drawcross auto
+ }
+ set path "$location_path/$dir/$element/"
+ foreach fp [ lsort [glob -nocomplain $path/*] ] {
+ set file [file tail $fp]
+ $tree insert end ms_$dir $file@$dir -text $file -data $file \
+ -image [Bitmap::get file] -drawcross never
+ }
+ }
+ }
+
+ # vector symbol selection subroutine
+ if {$element == "symbol"} {
+ $tree insert end root ms_$sympath -text SYMBOLS -data $sympath -open 1 \
+ -image [Bitmap::get openfold] -drawcross auto
+
+ foreach ic_dir [ lsort [glob -nocomplain $sympath/*] ] {
+ set dir_tail [file tail $ic_dir]
+ $tree insert end ms_$sympath ms_$dir_tail -text $dir_tail -data $dir_tail \
+ -image [Bitmap::get folder] -drawcross auto
+
+ foreach ic_file [ lsort [glob -nocomplain $sympath/$dir_tail/*] ] {
+ set file [file tail $ic_file]
+ $tree insert end ms_$dir_tail $dir_tail/$file -text $file -data $file \
+ -image [Bitmap::get file] -drawcross never
+ }
+ }
+ }
+
+ $tree configure -redraw 1
+
+ # buttons
+ button $selwin($id,self).ok -text [G_msg "Ok"] -command "destroy $selwin($id,self)"
+ button $selwin($id,self).cancel -text [G_msg "Cancel"] -command "GSelect_::terminate $id"
+
+ pack $selwin($id,self).ok $selwin($id,self).cancel -side left -expand yes
+
+
+ # ScrollView
+ toplevel $selftop -relief raised -borderwidth 2
+ wm protocol $selftop WM_DELETE_WINDOW {
+ # don't kill me
+ }
+ wm overrideredirect $selftop 1
+ wm withdraw $selftop
+ wm transient $selftop $selwin($id,self)
+ ScrollView $selftop.sv -window $tree -fill black
+ pack $selftop.sv -fill both -expand yes
+
+ wm protocol $selwin($id,self) WM_DELETE_WINDOW "GSelect_::terminate $id"
+ tkwait window $selwin($id,self)
+
+ destroy $selftop
+
+ # return selected elements -- separated by commas if there are > 1 elements
+ if { $selwin($id,selected) != "" } {
+ set ret ""
+ set len [llength $selwin($id,selected)]
+ foreach elem $selwin($id,selected) {
+ append ret $elem
+ if {[lsearch $selwin($id,selected) $elem] != -1 && \
+ [lsearch $selwin($id,selected) $elem] < [expr $len-1]} {
+ append ret ","
+ }
+ }
+ return $ret
+ }
+
+ return ""
+}
+
+
+proc GSelect_::select { id tree node } {
+ # Single selection (default). Clicking an item will select it and
+ # deselect any other item selected
+ variable selwin
+
+ set parent [$tree parent $node]
+ if { $parent == "root" } { return }
+
+ $tree selection set $node
+ update
+ set selwin($id,selected) $node
+}
+
+proc GSelect_::select_toggle { id tree node} {
+ # Multiple selections. Ctrl-1 will toggle an item as selected or not selected
+ # and add it to a list of selected items
+ variable selwin
+
+ set parent [$tree parent $node]
+ if { $parent == "root" } { return }
+
+ if {[lsearch -exact [$tree selection get] $node] >= 0} {
+ $tree selection remove $node
+ update
+ set nodeindex [lsearch $selwin($id,selected) $node]
+ if {$nodeindex != -1} {
+ set selwin($id,selected) [lreplace $selwin($id,selected) $nodeindex $nodeindex]
+ }
+ } else {
+ $tree selection add $node
+ update
+ lappend selwin($id,selected) $node
+ }
+
+ #$tree selection add $node
+# set selwin($id,selected) [string trim $selwin($id,selected) ,]
+}
+
+proc GSelect_::selectclose { id tree node } {
+ # return selection and close window (OK button)
+ variable selwin
+
+ GSelect_::select $id $tree $node
+ destroy $selwin($id,self)
+}
+
+
+proc GSelect_::terminate { id } {
+ # close window without returning selection (cancel)
+ variable selwin
+
+ set selwin($id,selected) {}
+ destroy $selwin($id,self)
+}
+
+proc GSelect_::moddir { idx tree node } {
+ if { $idx && [$tree itemcget $node -drawcross] == "always" } {
+ getdir $tree $node [$tree itemcget $node -data]
+ if { [llength [$tree nodes $node]] } {
+ $tree itemconfigure $node -image [Bitmap::get openfold]
+ } else {
+ $tree itemconfigure $node -image [Bitmap::get folder]
+ }
+ } else {
+ $tree itemconfigure $node -image [Bitmap::get [lindex {folder openfold} $idx]]
+ }
+}
+
+
More information about the grass-commit
mailing list