Index: BWman/BWidget.html ================================================================== --- BWman/BWidget.html +++ BWman/BWidget.html @@ -172,14 +172,14 @@ path w h ?arg...?
-Used to position and resise the widget specified by +Used to position and resize the widget specified by path. w and h are used to specify the requested width and height of the path widget for use by wm -geometry. The placement of the widget relative to other widgets or +geometry (set to 0 to use current values). The placement of the widget relative to other widgets or the screen is controlled by additional arguments:
at x y
Place the widget specified by the path argument at screen position x,y. See wm geometry for information about window Index: BWman/Button.html ================================================================== --- BWman/Button.html +++ BWman/Button.html @@ -9,10 +9,11 @@
CREATION
Button pathName ?option value...?
STANDARD OPTIONS
+
Not themed
@@ -57,10 +58,31 @@
  -activebackground   -activeforeground
  -textvariable
  -wraplength
+
Themed
+
+ + + + + + + + + + + + + + + + + + +
  -compound  -cursor
  -image  -style
  -repeatdelay  -repeatinterval
  -takefocus  -text
  -textvariable
WIDGET-SPECIFIC OPTIONS
@@ -159,11 +181,12 @@ Specifies a desired height for the Button. If an image or bitmap is being displayed in the Button then the value is in screen units; for text it is in lines of text. If this option isn't specified, the Button's desired height is computed -from the size of the image or bitmap or text being displayed in it. +from the size of the image or bitmap or text being displayed in it.
+Option not available when widget is themed.
-helptext
@@ -195,11 +218,13 @@
-relief
Specifies the 3-D effect desired for the widget. Acceptable values are standard values for button relief (raised, sunken, flat, ridge, solid, and groove) and link, which specifies that button relief is flat when pointer -is outside the button and raised when pointer is inside. +is outside the button and raised when pointer is inside.
+This option has only the following effect if the widget is themed: +The value link used a style Toolbutton while any other value uses the standard effect.
-state
@@ -267,7 +292,16 @@ Button is redisplayed with active color and sunken relief, and armcommand is called. Then Button is redisplayed with normal color and its defined relief, and disarmcommand then command are called.

invoke is called when Button has input focus and user press the space bar. + +

+

+BINDINGS
+
<<Invoke>> +
+ +Invoke the invoke widget command.
+

Index: BWman/ButtonBox.html ================================================================== --- BWman/ButtonBox.html +++ BWman/ButtonBox.html @@ -15,19 +15,19 @@
- + - + - +
  -background or -bg   -default
  -homogeneous
  -homogeneous   -orient
  -padx
  -padx   -pady
  -spacing
  -spacing   -state
WIDGET COMMAND
@@ -101,11 +101,12 @@

WIDGET-SPECIFIC OPTIONS
-background
-Specifies a default background color for all added buttons and for the frame. +Specifies a default background color for all added buttons and for the frame.
+For themed wigets, the button color is not set.
-default
@@ -137,18 +138,19 @@
-padx
-Specifies a default value for the -padx option of all added buttons. - +Specifies a default value for the -padx option of all added buttons.
+Option has no effect for themed wigets.
-pady
-Specifies a default value for the -pady option of all added buttons. +Specifies a default value for the -pady option of all added buttons.
+Option has no effect for themed wigets.
-spacing
Index: BWman/ComboBox.html ================================================================== --- BWman/ComboBox.html +++ BWman/ComboBox.html @@ -143,10 +143,11 @@
pathName configure ?option? ?value option value ...?
pathName get
+
pathName getentry
pathName getlistbox
pathName getvalue
pathName icursor index
@@ -311,10 +312,17 @@
pathName get
Returns the current contents of the entry. +
+ +
pathName getentry +
+ +Returns the path to the contained entry widget. +
pathName getlistbox
Index: BWman/Dialog.html ================================================================== --- BWman/Dialog.html +++ BWman/Dialog.html @@ -31,12 +31,11 @@   -anchor   -bitmap -  -buttonwidth -  -cancel +  -cancel   -default   -geometry @@ -136,23 +135,18 @@
Specifies a bitmap to display at the left of the user frame. image option override bitmap.
-
-
-buttonwidth (read-only)
-
- -Specifies the width of the buttons as specified for the option width -of the button widget. -
-cancel
-Specifies the number of the cancel button of the Dialog. When user press Esc in the Dialog, -this button is invoked. +Specifies the number of the cancel button of the Dialog. When user presses Esc or the windows close button, +this button is invoked.
+If set to -1, Esc does not invoke anything. +The window close button destroys the dialog in this case and returns -1.
-default
Index: BWman/Entry.html ================================================================== --- BWman/Entry.html +++ BWman/Entry.html @@ -9,10 +9,11 @@
CREATION
Entry pathName ?option value...?
STANDARD OPTIONS
+
Not themed
@@ -50,10 +51,34 @@ + + + + + + + +
  -background or -bg   -borderwidth or -bd
  -selectborderwidth   -selectforeground
  -takefocus  -text
  -textvariable  -xscrollcommand
+
+
+
Themed
+
+ + + + + + + + + + + + Index: BWman/Label.html ================================================================== --- BWman/Label.html +++ BWman/Label.html @@ -9,10 +9,11 @@
CREATION
Label pathName ?option value...?
STANDARD OPTIONS
+
Not themed
  -exportselection  -font
  -insertofftime  -insertontime
  -insertwidth  -justify
  -takefocus   -text
@@ -42,10 +43,39 @@ + + + + + + + + +
  -anchor
  -background or -bg
  -pady
  -relief
  -takefocus
  -text
  -textvariable
  -wraplength
+
Themed
+
+ + + + + + + + + + + + + + + + + + @@ -235,11 +265,12 @@ Specifies a desired height for the label. If an image or bitmap is being displayed in the label then the value is in screen units, for text it is in lines of text. If this option isn't specified, the label's desired height is computed -from the size of the image or bitmap or text being displayed in it. +from the size of the image or bitmap or text being displayed in it.
+Option not available for themed widgets.
-helptext
Index: BWman/ListBox.html ================================================================== --- BWman/ListBox.html +++ BWman/ListBox.html @@ -168,11 +168,11 @@ is determined following the height of the ListBox in order to see each item vertically.



WIDGET-SPECIFIC OPTIONS
-
-autofocus
+
-autofocus (read-only)
If this option is true, the listbox will take focus any time the user clicks in it. Without focus, the listbox's mouse wheel bindings will not work properly. The default is true.
@@ -357,11 +357,11 @@ Set it to false if you call update while modifying the listbox.
-
-selectfill
+
-selectfill (read-only)
If true, the listbox will draw a selection rectangle that fills the listbox from left-to-right instead of just drawing a box around the selected item. This more closely mimics the standard Tk listbox.
@@ -663,16 +663,13 @@ BINDINGS

A <<ListboxSelect>> virtual event is generated any time the -selection in the listbox changes. This is the default behavior of an -item in the listbox, but it can be overridden with the bindText or -bindImage command. If the button 1 binding is overridden, this event may -not be generated. +selection in the listbox changes.

The listbox has all the standard mouse wheel bindings when it has focus.

Index: BWman/MainFrame.html ================================================================== --- BWman/MainFrame.html +++ BWman/MainFrame.html @@ -20,25 +20,38 @@
+
  -anchor
  -background or -bg
  -cursor
  -font
  -foreground or -fg
  -image
  -justify
  -relief
  -takefocus
  -text
  -progressmax (see -maximum)   -progresstype (see -type)
  -progressvar (see -variable)
WIDGET-SPECIFIC OPTIONS
- - + + + + + + + + + + + + + + - - + - + +
  -height
  -menu
  -height
  -menu
  -menubarfont
  -menuentryfont
  -separator
  -statusbarfont
  -separator
  -textvariable
  -textvariable
  -width
  -width
  -sizegrip
WIDGET COMMAND
pathName addindicator @@ -80,14 +93,14 @@

MainFrame manage toplevel to have:

  • simple menu creation, with automatic accelerator bindings and -DynamicHelp association, -
  • one or more toolbars that user can hide, -
  • a status bar, displaying a user message or a menu description, and optionally a -ProgressBar. +DynamicHelp association,
    • +
  • one or more toolbars that user can hide,
    • +
  • a status bar, displaying a user message or a menu description, and optionally a +ProgressBar.



WIDGET-SPECIFIC OPTIONS
-height
@@ -105,37 +118,39 @@ one cascade menu. It has the following form: {menuname tags menuId tearoff menuentries...} where menuentries is a list where each element describe one menu entry, which can be:
  • for a separator:
    - {separator} + {separator}
  • for a command:
    - {command menuname ?tags? ?description? ?accelerator? ?option value? ...} + {command menuname ?tags? ?description? ?accelerator? ?option value? ...}
  • for a check button:
    - {checkbutton menuname ?tags? ?description? ?accelerator? ?option value? ...} + {checkbutton menuname ?tags? ?description? ?accelerator? ?option value? ...}
  • for a radio button:
    - {radiobutton menuname ?tags? ?description? ?accelerator ?option value? ...} + {radiobutton menuname ?tags? ?description? ?accelerator ?option value? ...}
  • for a cascade menu:
    - {cascade menuname tags menuId tearoff menuentries} + {cascade menuname tags menuId tearoff menuentries}
where:
  • menuname is the name of the menu. If it contains a &, the following character is automatically converted to the corresponding -underline option of menu add -command. +command.
  • tags is the tags list for the entry, used for enabling or disabling menu -entries with MainFrame::setmenustate. +entries with MainFrame::setmenustate.
  • menuId is an id for the menu, from which you can get menu pathname with - MainFrame::getmenu. -
  • tearoff specifies if menu has tearoff entry. -
  • description specifies a string for DynamicHelp. + MainFrame::getmenu.
    • +
  • tearoff specifies if menu has tearoff entry.
    • +
  • description specifies a string for DynamicHelp.
  • accelerator specifies a key sequence. It is a list of two elements, where the first -is one of Ctrl, Alt or CtrlAlt, and the second as letter or a digit. +is one of Shift, Ctrl, Alt, CtrlAlt, Cmd, or ShiftCmd, and the second as letter +(see -casesensitive option for interpretation), digit or +a special key name. An accelerator string is build and corresponding binding set on the toplevel to invoke the -menu entry. +menu entry.
  • option value specifies additionnal options for the entry (see menu add -command). +command).
Each value enclosed by ? are optional and defaulted to empty string, but must be provided if one or more following options is not empty.
Example: 
@@ -152,20 +167,28 @@
         {cascade "&Recent files" {} recent 0 {}}
         {separator}
         {command "E&xit" {} "Exit the application" {} -command Menu::exit}
     }
     "&Options" {} {} 0 {
-        {checkbutton "Toolbar" {} "Show/hide toolbar" {} 
+        {checkbutton "Toolbar" {} "Show/hide toolbar" {}
             -variable Menu::_drawtoolbar
             -command  {$Menu::_mainframe showtoolbar toolbar $Menu::_drawtoolbar}
         }
     }
 }
+
-menubarfont
+
+Font for the top menu bar. +
+
-menuentryfont
+
+Font for the submenus. +
-separator (read-only)
Specifies if separator should be drawn at the top and/or at the bottom of the user window. Must be one of the values none, top, bottom or both. @@ -181,18 +204,27 @@ If this variable is changed by MainFrame::configure, menu description will not be available.
You change the text of the label by modifying the value of the variable.
+
-statusbarfont
+
+Font for the status bar. +
-width
Specifies the desired width for the user frame in any of the forms acceptable to Tk_GetPixels. If this option is less than or equal to zero (the default) then the window will not request any size at all.
+
-sizegrip (themed, read-only)
+
+ +If bool argument is true and themed mode, show a ttk sizegrip widget in the lower-right corner. +

WIDGET COMMAND
pathName addindicator ?arg...?
Index: BWman/MessageDlg.html ================================================================== --- BWman/MessageDlg.html +++ BWman/MessageDlg.html @@ -84,10 +84,11 @@ be twice as tall as it is wide, and so on. Used to choose line length for text if width option isn't specified. Defaults to 150. +The options -width and -aspect are directly heritated from the Tk message widget.
-buttons
@@ -196,14 +197,16 @@

user
Displays buttons of -buttons option.

-

-
+
- +

+For any -type but user, the native Tk widget tk_messageBox is used. +In this case, only the following options are considered: -default, -icon, -message, -title and -type. +

-width
Specifies the length of lines in the window. Index: BWman/NoteBook.html ================================================================== --- BWman/NoteBook.html +++ BWman/NoteBook.html @@ -44,17 +44,18 @@   -arcradius   -height   -homogeneous -  -side +  -internalborderwidth or -ibd +  -side   -tabbevelsize -  -tabpady +  -tabpady   -width
@@ -115,11 +116,15 @@


DESCRIPTION

-NoteBook widget manage a set of pages and displays one of them. +The NoteBook widget manages a set of pages and displays one of them. A page +is a frame or ttk::frame that is included in the NoteBook by its +insert command. Each page is associated with a tab; +the tabs are displayed in a band either above or below the pages, depending on +the value of the option -side.



WIDGET-SPECIFIC OPTIONS
-arcradius
@@ -140,14 +145,24 @@
-homogeneous
-Specifies wether or not the label of the pages must have the same width. +Specifies whether or not the label of the pages must have the same width. + +
+
+ +
-internalborderwidth or -ibd
+
+ +Value that is applied to each page in the NoteBook as its -borderwidth or -bd.
+ +
-side
Specifies the side where to place the label of the pages. Must be one of top or bottom. @@ -249,19 +264,90 @@ index page ?option value...?
-Insert a new page idendified by page at position index in the pages list. +Insert a new page identified by page at position index in the pages list. index must be numeric or end. The pathname of the new page is returned. +Dynamic help, if it is specified by the options, is +displayed when the pointer hovers over the tab that belongs to the page.

+

-activebackground
+
+ +Background color for the tab when it is active. + +
+
+
-activeforeground
+
+ +Color used for the tab's text when the tab is active. + +
+
+
-background
+
+ +Background color for the tab when it is not active. + +
+
-createcmd
Specifies a command to be called the first time the page is raised. +
+
+
-disabledforeground
+
+ +Color used for the tab's text when the tab is disabled. + +
+
+ +
-foreground
+
+ +Color used for the tab's text when the tab is neither active nor disabled. + +
+
+
-helpcmd
+
+ +Has no effect. +See also DynamicHelp. + +
+
+
-helptext
+
+ +Text for dynamic help. If empty, no help is available for this page. +See also DynamicHelp. + +
+
+
-helptype
+
+ +Type of dynamic help. Use balloon (the default for a NoteBook +page) or variable. +See also DynamicHelp. + +
+
+
-helpvar
+
+ +Variable to use when -helptype option is variable. +See also DynamicHelp. +
-image
@@ -273,17 +359,40 @@
Specifies a command to be called when a page is about to be leaved. The command must return 0 if the page can not be leaved, or 1 if it can. +
+
+
-ractiveimage
+
+ +Image to show on the right of the tab when the tab is active. +
-raisecmd
Specifies a command to be called each time the page is raised. +
+
+
-rimage
+
+ +Image to show on the right of the tab when the tab is not active. + +
+
+
-rimagecmd
+
+ +Specifies a command to be evaluated, with two arguments appended, when the +image shown on the right of the tab is clicked. The first appended argument +is the Tk window path of the NoteBook, the second is the name of the page. +
-state
Index: BWman/ScrolledWindow.html ================================================================== --- BWman/ScrolledWindow.html +++ BWman/ScrolledWindow.html @@ -9,17 +9,28 @@
CREATION
ScrolledWindow pathName ?option value...?
STANDARD OPTIONS
+
Not themed
+
  -background or -bg   -borderwidth or -bd
  -relief
+
Themed
+
+ + + + + + +
  -borderwidth or -bd  -relief
  (-bg has no effect)
WIDGET-SPECIFIC OPTIONS
@@ -98,11 +109,12 @@
-size (read-only)
Size of the scrollbars in pixels. -Use 0 for standard size (default value). +Use 0 for standard size (default value).
+This option has no effect if widget is themed.

WIDGET COMMAND
pathName cget Index: BWman/SelectColor.html ================================================================== --- BWman/SelectColor.html +++ BWman/SelectColor.html @@ -11,18 +11,23 @@
WIDGET-SPECIFIC OPTIONS
+ - + + + + + - +
  -background   -color  -parent
  -command  -help
  -parent   -placement  -title
  -title   -type
@@ -39,10 +44,14 @@
SelectColor::menu pathName placement ?option value ...? +
+
SelectColor::setbasecolor + index + color
SelectColor::setcolor index color
@@ -55,14 +64,43 @@ as a dialog box or as a menubutton.



WIDGET-SPECIFIC OPTIONS
+
-background
+
+ +Specifies the background color of the widget. + +
+
-color
-Specifies the color value of the widget. +Specifies the initial color used in the widget's color selectors. When modifying a +color that is used in the GUI, the value supplied is typically the existing value of +that color. + +
+
+
-command
+
+ +Specifies a command to be evaluated, with a color value appended, whenever +the color selected in the dialog changes. This facility can be used to modify +a color in the calling GUI and preview the change before deciding whether or not +to accept it. If the user selects "Cancel" in the dialog, the command is called +a final time to restore the initial color (supplied by option -color) that was +used before the dialog was opened. + +
+
+
-help
+
+ +This option takes a Boolean value. If the value is Boolean true, the SelectColor +dialog will include a balloon help for text entry and mouse operation.
-parent
@@ -149,10 +187,19 @@ placement will be in relation to the parent widget.

+
+
SelectColor::setbasecolor + index + color +
+ +Set the value of user predefined base color at index index to color. +index must be between 0 and 10. +
SelectColor::setcolor index color
Index: BWman/SpinBox.html ================================================================== --- BWman/SpinBox.html +++ BWman/SpinBox.html @@ -12,11 +12,11 @@
OPTIONS from ArrowButton
- + @@ -29,11 +29,11 @@
OPTIONS from Entry
  -background or -bg  -disabledforeground  -disabledforeground (not themed)
  -foreground or -fg   -repeatdelay
- + Index: BWman/Tree.html ================================================================== --- BWman/Tree.html +++ BWman/Tree.html @@ -484,13 +484,18 @@

NODE NAMES

Certain special characters in node names are automatically substituted -by the tree during operation. These characters are & | ^ !. -They are all substituted with a _ character. This is only to -avoid errors because the characters are special to the tree widget. +by the tree during operation. These characters are & | ^ ! :. +They are internally substituted by non printable characters \1 to \5. +This is only to avoid errors because the characters are special to the tree widget. +In consequence, the characters \1 to \5 are not unique in node names and should be avoided. +

+

Note: until BWidget 1.9.16, a double colon ("::") was substituded by \5 and the +single colon (":") lead to an error. This change is incompatible in the sense, that +the generated node name changed between the versions.

WIDGET COMMAND
pathName bindArea event Index: BWman/Widget.html ================================================================== --- BWman/Widget.html +++ BWman/Widget.html @@ -335,27 +335,30 @@
  • class is the name of the new widget class.
  • filename is the name of the file (without extension) in the BWidget distribution that defines this class.
    • +
  • ?-classonly? If present, the class is not setup.
    • +
  • ?-namespace ns? The namespace where the widget's procedures live + in; defaults to the class name.

Each class defined after the filename is a class that this widget depends on. The ::use command will be called for each of these classes after the new widget has been defined.

- This command does several things to setup the new class. First, it - creates an alias in the global namespace for the name of the class - that points to the class's ::create subcommand. Second, it defines - a ::use subcommand for the class which other classes can use to load - this class on the fly. Lastly, it creates a default binding to the - <Destroy> event for the class that calls Widget::destroy on - the path. This is the default setup for almost all widgets in the - BWidget package. + If -classonly option is not given this command does several things to + setup the new class. First, it creates an alias in the global namespace for + the name of the class that points to the class's ::create subcommand. + Second, it defines a ::use subcommand for the class which other classes can + use to load this class on the fly. Lastly, it creates a default binding to + the <Destroy> event for the class that calls Widget::destroy on the + path. This is the default setup for almost all widgets in the BWidget + package.

Widget::destroy Index: BWman/contents.html ================================================================== --- BWman/contents.html +++ BWman/contents.html @@ -79,6 +79,17 @@
  -command  -disabledforeground  -disabledforeground (not themed)
  -dragenabled   -dragendcmd
DropSite Commands set for Drop facilities
BWidget Description text
-
+
+ +

Load BWidget

+ +Possible load sequence: +
+# If package msgcat is available, its locale is used for BWidget
+package require msgcat
+# load BWidget
+package require BWidget
+
+ Index: ChangeLog ================================================================== --- ChangeLog +++ ChangeLog @@ -1,5 +1,571 @@ +2023-05-22 Harald Oehlmann + TCL9.0/Tk8.7 compatibility issues found by Paul Obermeier. + https://wiki.tcl-lang.org/page/Porting+extensions+to+Tcl+9 + * dropsite.tcl: Replaced "$tcl_platform" with "$::tcl_platform" + in namespaces. + * widget.tcl: Replaced "package require Tcl 8.1.1" with + "package require Tcl 8.1.1-". + Ticket [1bee17b353] + +2023-05-22 Harald Oehlmann + tree.tcl: Bug: node names with leading colons gave error. + The node name solution was changed, that ":" is now + substituded by "\5", and not "::". Ticket [d075175ade]. + Thanks to Rolf Ade for the ticket. + +2022-12-25 Harald Oehlmann + + **** BWidget 1.9.16 tagged **** + +2022-10-12 Wolfgang Kechel + dropsite.tcl: Prevent multiple drops, when movement + while drop is processed. Ticket [1ef1f56cd1] + + +2021-12-03 Harald Oehlmann + + **** BWidget 1.9.15 tagged **** + +2021-12-03 Harald Oehlmann + mainframe.tcl: Recalculate status bar height if the + text size is changed by a change of a used named font. + Ticket [acbd67752a] + +2021-08-05 Harald Oehlmann + notebook.tcl: Repaint tabs if the text size is changed + by a change of a used named font. Ticket [acbd67752a] + +2019-12-03 Harald Oehlmann + + **** BWidget 1.9.14 tagged **** + +2019-11-12 Harald Oehlmann + spinbox.tcl: fix error about unsupported option + -disabledforeground when using themed widgets. + Thanks to Gerhard Reithofer and Christian Werner. + Ticket [071fc80f14] + +2019-05-06 Harald Oehlmann + mainframe.tcl: Add optional parameter "Top" to internal + function "MainFrame::_create_menubar" to allow to use + a menu button for the main menu (Hack). + The mainframe may be initialized with "- menu {}". + Then, the menubutton may be created and the menu may + by added by: + MainFrame::_create_menubar .mf $mitems $menubutton. + Allow to skip a main menu level by empty menu label. + Purpose: support commands/checkboxes at first level. + +2018-12-11 Harald Oehlmann + scrollframe.tcl: use Tk8.7 TIP 518 virtual event + <> to resize client frame to 1x1 when + last child is unmapped. + +2018-12-06 Harald Oehlmann + + **** BWidget 1.9.13 tagged **** + +2018-11-26 Harald Oehlmann + dialog.c: For Unix, also Bind KP_Enter for default dialog + button invokation. Ticket [3e31f04367]. + Thanks to Jos for the proposal. + +2018-01-09 Harald Oehlmann + Spanish translation enhanced by Neko. + Ticket [a947e33526] + +2018-01-10 Harald Oehlmann + + **** BWidget 1.9.12 tagged **** + +2018-01-10 Harald Oehlmann + color.tcl: replace the help widget by balloons bound to the + widgets. Ticket [2cc70ce1cb] + +2018-01-09 Harald Oehlmann + color.tcl: New option -command allows to get a callback + when the user does an unvalidated choice. + New option -background and command SelectColor for + window background. + TitleFrames, Dynamic help and Aqua native buttons used. + Show current choice by highlighting, not focus, to avoid + conflict with keyboard traversal. + Shows entry widget for numerical color input/output. + New option -help to show a help area. + Patch by Keith J. Nash + Ticket [75101bf5ce] + Translators: Jima (es), Vogel (fr), Marcus (nl), Ian (da) + Ticket [a947e33526] + +2017-11-03 Harald Oehlmann + notebook.tcl (+man,demo): Add possibility to NoteBook + to add an image at the right of each tab. + Ticket [15e19fe9ec]. Patch by Keith J. Nash. + +2017-08-25 Harald Oehlmann + + **** BWidget 1.9.11 tagged **** + +2017-05-08 Harald Oehlmann + MessageDlg.html: Documented the use of the native widget for + "MessageDlg -type !user" and the limited set of recognized + options. Ticket [8edade3cea] by Gerhard Reithofer + +2016-10-31 Harald Oehlmann + scrollframe.tcl: Eric advised to check for unmapped window, + as the event may be executed in the unmapped state. + +2016-10-31 Harald Oehlmann + scrollframe.tcl: width changed when unmapped and mapped. + Checkge the Configure vound proc to not be active when + currently unmapped. Ticket [72a5727d1b]. Thanks to + Alexandru for the ticket and patch. + +2016-10-31 Harald Oehlmann + button.tcl: Reverted last change, Eric underlined to + not use ttk widgets as a base due to the option + data base. Did traditional fix to exclude all options + known by button and not known by ttk::button. + Ticket [845613e5590ae7cf] + +2016-08-23 Harald Oehlmann + button.tcl: configure option of a ::Button gave error in + themed mode. Ticket [845613e5590ae7cf]. Report by Adrian. + +2016-07-21 Harald Oehlmann + util.tcl: BWidget::place moved away from visible screens + if the current window is on a virtual screen outside of + the main screen (Windows multi-screen configuration). + Ticket [5919a0ec2d] + +2016-07-15 Adrian Madrano Calvo + pckIndex.tcl: auto-load commands also from global namespace + and not only from BWidget namespace. Ticket [c86207db01] + +2016-03-22 Harald Oehlmann + Only support themed packages Tile 0.8 or Ttk. + Repair the button spacing in themed font toolbar. + Ticket [d7ea07c40a] + +2016-03-15 Harald Oehlmann + mainframe.tcl: "Mainframe configure" caused error in themed + mode. Ticket [52273c0a4e] + +2016-03-08 Harald Oehlmann + + **** BWidget 1.9.10 tagged **** + +2016-01-07 Adrian Medrano Calvo + listbox.tcl: Listbox did not scroll to current item on + startup. Ticket [ae238d5a7] + +2016-01-07 Harald Oehlmann + lang/da.rc, lang/es.rc, lang/fr.rc, lang/no.rc: + Translations non portable on utf-8 systems. + File encoding changed to utf-8. Ticket [6c91e43d76] + +2016-01-07 Harald Oehlmann + tree.tcl: Tree lines are black by default even if background + is black. Ticket [ed4c1dab46] + +2015-12-08 Harald Oehlmann + listbox.tcl: 8.4 compatibility was broken due to the use of + min/max math functions. Ticket [0aef856302] + +2015-11-04 Harald Oehlmann + dynhelp.tcl: Drop the assumption that all windows + screen are the same size (of fix dated 2009-06-26) + and use the virtual screen information to place the bubble + help. Ticket [b64e03e548]. + +2015-10-18 Harald Oehlmann + + **** BWidget 1.9.9 tagged **** + +2015-03-18 Harald Oehlmann + + widget.tcl: Widget::define got new parameter -namespace, + allowing megawidget namespace be different to + class name. This allows lower case namespace names. + Patch by Adrian Medrano Calvo. Ticket [023a631b20] + +2014-09-10 Harald Oehlmann + + **** BWidget 1.9.8 tagged **** + +2014-09-05 Harald Oehlmann + + widget.tcl: Widget::which errors when option not present. + Ticket [397db23424] + +2014-05-21 Harald Oehlmann + + widget.tcl: Don't invoke unqualified upvar in callers + scope. Patch by Adrian Medrano Calvo. Ticket [046fa04231] + + widget.tcl: Don't double creation of temporary widget for + default values retrieval. Use result of _get_tkwidget_options + instead. By Adrian Medrano Calvo. Ticket [393b67ab19] + + widget.tcl: New procedure Widget::which (as in [namespace which]), + that returns the fully qualified name for a widget option or + widget variable. By Adrian Medrano Calvo. Ticket [a8705e5fd9] + + widget.tcl: Remove unneeded upvar. By Adrian Medrano Calvo. + Ticket [43f93e0a97] + + widget.tcl et al: remove apparently unused procedure + Widget::syncoptions and all calls. By Adrian Medrano Calvo. + Ticket [3c2b8eafc6] + + +2013-12-13 Harald Oehlmann + + scrollframe.tcl: Make -constrainedwidth 1 and + -constrainedheight 1 work together. + Patch by Simon Bachmann. Ticket [2fa44401d5] + + 2013-10-17 Harald Oehlmann + widget.tcl: Remove temporary widget. + By Wolfgang S. Kechel. Ticket [6cd041bcc1] + +2013-10-15 Harald Oehlmann + combobox.tcl: Themed ComboBox color specifications + are honored. By Wolfgang S. Kechel. Ticket [6c6704e40f] + +2013-10-14 Harald Oehlmann + combobox.tcl: Fails in themed mode with "unknown + option -bg". Patch solves this but listbox items + are white on white when "-foreground" is specified. + By Wolfgang S. Kechel. Ticket [6632134ce9] + + listbox.tcl: Update on option -deltay added. + Set x0 to 2 to make highlight work and look nice for + listbox with image. + Take image into account to show selection. + By Wolfgang S. Kechel. Ticket [ff1787af9c] + + scrollw.tcl: Raise scrolled window if it is below in + the window hierarchy. By Wolfgang S. Kechel. + Ticket [ff1787af9c] + +2013-10-07 Harald Oehlmann + dynhelp.tcl: Sometimes the tooltip does not occur under + gnome/metacity on ubuntu. By Wolfgang S. Kechel. + Ticket [a588d2f800] + +2013-09-15 Harald Oehlmann + + **** BWidget 1.9.7 tagged **** + +2013-09-11 Harald Oehlmann + + xpm2image.tcl: many issues fixed in xpm import + by Mattias Hembruch. Ticket [9a8b2ee42e] + +2013-08-14 Harald Oehlmann + + * notebook.tcl: cured error in _resize, that + data($p,width) is not (jet) present. Ticket [a4cbba655d]. + +2013-06-28 Harald Oehlmann + + * mainframe.tcl: Included Patch [9f67a66609] + curing issues of Shift-Accellerators with Shift-Lock + on Mac. By Keith Nash, Ticket [83ce3e84e7]. + +2013-06-26 Harald Oehlmann + + * mainframe.tcl: Reverted Patch [1977644] + (-casesensitive for accellerators). It has + issues with shift-lock. + +2013-06-21 Harald Oehlmann + + * labelentry.tcl: Bug fixed: + Methods from Tk entry widget restored [Bug 1002844]. + + * mainframe.tcl: Allow case sensitive accelerators + by new option -casesensitive. + Patch by cmard [Patch 1977644] + + * mainframe.tcl: Allow new modifiers Shift, Cmd and ShiftCmd + for accelerators. Patch by K.J.Nash [Patch-83ce3e84e7] + + * mainframe.tcl: When changing MainFrame -background, do + not change menu colors on Aqua. + Fix by Keith J.Nash [Bug-a81b7afc1e] + + * init.tcl: Make loadable in save interpreter. + Fix by Keith J.Nash [Bug-4365a23bd3] + + * combobox.tcl: Add method getentry to return entry + widget path for bind purposes. + Patch by Michael [Patch-2340355] + +2013-01-09 Harald Oehlmann + + * widget.tcl: Bug fixed: + Error 'invalid command name ".#BWidget.#ttk::entry"' + arises in themed mode when an Entry widget should get + focus by the tab key. + The temporary widget creation fails due to the "::" in + the command name of ttk widgets. + Any "::" is replaced by "__" [Bug 3599955]. + +2011-07-27 Harald Oehlmann + + **** BWidget 1.9.6 tagged **** + +2012-04-12 Harald Oehlmann + + * listbox.tcl ListBox::selection Only redraw if + selection changed. Patch by Wolfgang S. Kechel [Bug 3517145] + +2012-04-02 Harald Oehlmann + + * entry.tcl, BWMan/entry.tcl checkbox.tcl Themed mode: + Invoking "configure" without arguments results in errors + that non-ttk options are not present. + Removed Entry options: -background -foreground -relief + -borderwidth -fg -bg -bd. Reported by Wolfgang S. Kechel + [Bug 3513263] + * entry.tcl mapped entry option -state to ttk::entry + state in themed mode to make state change visible. + +2012-03-06 Harald Oehlmann + + * BWMan/ListBox.html documented options -selectfill and + -autofocus as read-only. Reported by Wolfgang S. Kechel + [Bug 3497592] + +2011-11-14 Harald Oehlmann + + * widget.tcl (Widget::focusOK) fixed list with update. + Arises, if a ttk widget with a widget path with spaces + is the next widget. Reported by jaspertheperson + [Bug 3437761] + +2011-06-24 Harald Oehlmann + + **** BWidget 1.9.5 tagged **** + +2011-06-23 Harald Oehlmann + + * listbox.tcl (listbox::generate_data) fixed last patch + by ryotakatsuki [Bug 3324610] + +2011-06-23 Harald Oehlmann + + * listbox.tcl Fix of Bug 3000293 broke listbox tags. + The bindImage subcommand did not report right tag. + Patch by ryotakatsuki [Bug 3324610] + +2011-06-23 Harald Oehlmann + + * listbox.tcl, tree.tcl (_update_scrollregion) the linewise + scrolling did not always scroll up to the end on windows 7. + Report and patch by Wojciech Kocjan, review and modification + by Koen Danckaert [Bug 3317772] + +2011-05-25 Harald Oehlmann + + *mainframe.tcl: Add a boolean readonly option -sizegrip + to show a sizegrip widget in themed mode. + +2011-05-24 Harald Oehlmann + + *lang/pl.rc updated by Wojciech Kocjan. + +2011-04-26 Harald Oehlmann + + *notebook.tcl The user frame of the notebook is now a themed + frame in themed mode. The set background color does not apply + to the user frame in this case. + +2011-04-26 Harald Oehlmann + + label.tcl configuring foreground color caused error when + themed [Bug 3292977] + +2011-04-20 Harald Oehlmann + + lang/hu.rc by Rezso updated + +2011-04-20 Harald Oehlmann + + * font.tcl, lang/*.rc: Add translation possibility + for color picker button of font dialog. + Used google translater to translate "Color" to all languages. + Please check if this is correct. [Bug 3289573] reported by Rezso + +2011-04-19 Harald Oehlmann + + * lang/*.rc [Bug 3289573] : Add translation (templates) for the + Color picker widget text "Base colors" and "User colors". + Only german and english locals are provided so far. + +2011-02-14 Harald Oehlmann + + * combobox.tcl: [Bug 3182287] : ComboBox failes in themed mode + due to the use of the themed entry widget. The following options + are not supported (and thus called) any more: -relief + -highlightbackground -highlightforeground + +2011-02-14 Harald Oehlmann + + * entry.tcl, labelentry.tcl, labelframe.tcl, mainframe.tcl, + pagesmgr.tcl, scrollw.tcl: [Bug 3168761]: + entry failes when themed support activated with: + unknown option "-highlightthickness" (reported by George + on clt 27 Jan., 16:55). + The patch by Wojciech Kocjan fixes this and enhances + labelentry, labelframe and pagesmgr to also use themed frames. + Within scrollw.tcl, a bug for empty background handling is fixed. + The scrollbar background is not set any more for not-themed widget. + +2011-01-17 Harald Oehlmann + + * pkgIndex.tcl: corrected package version in package provide + +2010-12-14 Harald Oehlmann + + **** BWidget 1.9.4 tagged **** + +2010-12-14 Andreas Kupries + + * tree.tcl [Bug 3106208]: Followup. Moved the fixed code of the + last entry I did (2010-11-09) into a new command Tree::MergeFlag + and call this from both Tree::itemconfigure and Tree::insert. + Missing the place in Tree::insert caused another problem, found by + Dustin Littau. + +2010-11-05 Harald Oehlmann + + **** BWidget 1.9.3 tagged **** + +2010-11-23 Harald Oehlmann + + * scrollw.tcl Add theming support for ScrolledWindow widget. + * ScrolledWindow.html Themed mode documented. + +2010-11-21 Harald Oehlmann + + * label.tcl Add theming support for Label widget. + * label.html Themed mode documented. + +2010-11-16 Harald Oehlmann + + * button.tcl Add theming support for Button widget. + Option "-relief link" is mapped to "Toolbutton style. + Option -height is not available when themed. + Thanks to Kevin Walzer for the test on MacOS. + * buttonbox.tcl When themed, only set themed button options. + The widget itself is not jet themed. + * Dialog.html Removed documentation of unavailable option -buttonwidth. + +2010-11-09 Andreas Kupries + + * tree.tcl (Tree::itemconfigure): Fix intermingling of node names + and flag values which can cause an lsearch to fail, by mistaking a + flag value as the node searched for, and then treating a node name + as flags. As the upd,nodes value is a dictionary it should not be + search as a list. Now using a temporary array for quicker check + and append/replace [Bug 3106208]. + +2010-11-09 Harald Oehlmann + + * mainframe.tcl Menu text shows white on white on Mac aqua + [Bug 3105665] reported by Scott Smedley fixed by Kevin Walzer. + +2010-10-15 Harald Oehlmann + + * label.tcl The frame surround the label gets under + unknown conditions a -padx 5. A pad of 0 is now + hard coded (Bug 3087955) + +2010-08-04 Harald Oehlmann + + * dialog.tcl Changed behaviour of window close button. + If -cancel is given, this button is invoked. + The cancel option may now be changed using the configure + method. + + * init.tcl If msgcat is available use its locale to load + a lang/*.rc file instead always using en.rc. + +2010-06-09 Harald Oehlmann + + * Included lang/pl.rc from HEAD. + +2010-06-07 Harald Oehlmann + + **** BWidget 1.9.2 tagged **** + Version 1.9.1 was skipped. + This was released in ActiveTCL and thus may exist on many + installations. + +2010-05-31 Harald Oehlmann + + * listbox.html Reflected patch 2010-05-12 in documentation. + The selection may not be disabled any more by binding button 1. + +2010-05-12 Harald Oehlmann + + * listbox.tcl(ListBox::bindText and ListBox::bindImage) + Method bindText and bindImage overwrote internal selection + bindings [Bug 3000293] reported by Robert Karen. + +2010-05-11 Harald Oehlmann + + * listbox.tcl(ListBox::see) Method see shifts image out of + view. Showed up, by a selection click on a long item with icon + [Bug 2999764] reported by Robert Karen. + +2010-05-05 Harald Oehlmann + + * listbox.tcl(ListBox::_configureSelectmode) Drag modifies + multiple selection [Bug 2995969] reported by Robert Karen. + Bound events on ButtonRelease-1 instead Button-1 for multiple + selections to avoid bug. + * listbox.tcl(ListBox::_drag_and_drop) The default drag and drop + routine only handled single drag and drop. + It was extended to handle also drag and drop of multiple entries. + +2009-09-03 Harald Oehlmann + + * util.tcl(BWidget::place), BWidget.html Widget placed incorrectly, + when bigger than current screen [Bug 2850031] by Thomas Grausgruber + Possible incompatibility: BWidget::place w h -> w,h are reduced to + screen width. + +2009-08-12 Harald Oehlmann + + * dynhelp.tcl Use balloon help font TkTooltipFont if tk <= 8.5. + Otherwise use helvetica 11 on Aqua [Patch 2835180] for Kevin Walzer + * dynhelp.tcl(DynamicHelp::_show_help)Replaced aqua conditional code + check by $Widget::_aqua + +2009-08-10 Harald Oehlmann + + * notebook.tcl (NoteBook::delete) Method delete destroyframe=1 and + reinsertion -> raise failed - state variables were deleted. + [Bug 2831785] by kjnash + * tree.tcl (Tree::_keynav) Fire virtual event <> also on + keyboard navigation [Patch 2828086] by Kevin Walzer + * combobox.tcl Replaced aqua conditional code check by $Widget::_aqua + +2009-08-10 Harald Oehlmann + + **** Branched to bwidget **** + + This is the bwidget branch of module bwidget of tcllib + Use "-r bwidget" for all cvs operations + Scope: Package BWidget compatible to tcl/tk 8.1 and tk + (e.g. no tile/ttk). + 2009-07-24 Harald Oehlmann **** BWidget 1.9.0 tagged **** * pkgIndex.tcl, README.txt: updated to BWidget 1.9 Index: README.txt ================================================================== --- README.txt +++ README.txt @@ -1,6 +1,6 @@ -BWidget ToolKit 1.9.0 July 2009 +BWidget ToolKit 1.9.15 December 2021 Copyright (c) 1998-1999 UNIFIX. Copyright (c) 2001-2002 ActiveState Corp. See the file LICENSE.txt for license info (uses Tcl's BSD-style license). Index: button.tcl ================================================================== --- button.tcl +++ button.tcl @@ -22,10 +22,16 @@ set remove [list -command -relief -text -textvariable -underline -state] if {[info tclversion] > 8.3} { lappend remove -repeatdelay -repeatinterval } + if {$::Widget::_theme} { + lappend remove -activebackground -activeforeground -anchor -background\ + -bitmap -borderwidth -disabledforeground -font -foreground\ + -height -highlightbackground -highlightcolor -highlightthickness\ + -justify -overrelief -padx -pady -relief -wraplength + } Widget::tkinclude Button button :cmd remove $remove Widget::declare Button { {-name String "" 0} {-text String "" 0} @@ -40,21 +46,20 @@ {-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 {Button::_enter %W} bind BwButton {Button::_leave %W} bind BwButton {Button::_press %W} bind BwButton {Button::_release %W} bind BwButton {Button::invoke %W; break} bind BwButton {Button::invoke %W; break} + bind BwButton <> {Button::invoke %W; break} bind BwButton {Widget::destroy %W} } # ---------------------------------------------------------------------------- @@ -61,18 +66,18 @@ # Command Button::create # ---------------------------------------------------------------------------- proc Button::create { path args } { array set maps [list Button {} :cmd {}] array set maps [Widget::parseArgs Button $args] - eval [concat [list button $path] $maps(:cmd)] + if {$::Widget::_theme} { + eval [concat [list ttk::button $path] $maps(:cmd)] + } else { + eval [concat [list button $path] $maps(:cmd)] + } Widget::initFromODB Button $path $maps(Button) # Do some extra configuration on the button - set relief [Widget::getMegawidgetOption $path -relief] - if { [string equal $relief "link"] } { - set relief "flat" - } set var [Widget::getMegawidgetOption $path -textvariable] set st [Widget::getMegawidgetOption $path -state] if { ![string length $var] } { set desc [BWidget::getname [Widget::getMegawidgetOption $path -name]] if { [llength $desc] } { @@ -88,12 +93,24 @@ set under -1 set text "" Widget::configure $path [list -underline $under] } - $path configure -relief $relief -text $text -underline $under \ - -textvariable $var -state $st + $path configure -text $text -underline $under \ + -textvariable $var -state $st + # Map relief flat on Toolbutton for ttk + set relief [Widget::getMegawidgetOption $path -relief] + if {$::Widget::_theme} { + if { [string equal $relief "link"] } { + $path configure -style Toolbutton + } + } else { + if { [string equal $relief "link"] } { + set relief "flat" + } + $path configure -relief $relief + } bindtags $path [list $path BwButton [winfo toplevel $path] all] set accel1 [string tolower [string index $text $under]] set accel2 [string toupper $accel1] if { $accel1 != "" } { @@ -121,28 +138,37 @@ } set res [Widget::configure $path $args] # Extract all the modified bits we're interested in foreach {cr cs cv cn ct cu} [Widget::hasChangedX $path \ - -relief -state -textvariable -name -text -underline] break + -relief -state -textvariable -name -text -underline] break if { $cr || $cs } { - set relief [Widget::cget $path -relief] - set state [Widget::cget $path -state] - if { [string equal $relief "link"] } { - if { [string equal $state "active"] } { - set relief "raised" - } else { - set relief "flat" - } - } - $path:cmd configure -relief $relief -state $state + set relief [Widget::cget $path -relief] + set state [Widget::cget $path -state] + if { $::Widget::_theme} { + if { [string equal $relief "link"] } { + $path:cmd configure -style Toolbutton + } else { + $path:cmd configure -style "" + } + } else { + if { [string equal $relief "link"] } { + if { [string equal $state "active"] } { + set relief "raised" + } else { + set relief "flat" + } + } + $path:cmd configure -relief $relief + } + $path:cmd configure -state $state } if { $cv || $cn || $ct || $cu } { - set var [Widget::cget $path -textvariable] - set text [Widget::cget $path -text] - set under [Widget::cget $path -underline] + set var [Widget::cget $path -textvariable] + set text [Widget::cget $path -text] + set under [Widget::cget $path -underline] if { ![string length $var] } { set desc [BWidget::getname [Widget::cget $path -name]] if { [llength $desc] } { set text [lindex $desc 0] set under [lindex $desc 1] @@ -175,41 +201,72 @@ # ---------------------------------------------------------------------------- proc Button::cget { path option } { Widget::cget $path $option } + +# ---------------------------------------------------------------------------- +# Command Button::identify +# ---------------------------------------------------------------------------- +proc Button::identify { path args } { + eval $path:cmd identify $args +} + + +# ---------------------------------------------------------------------------- +# Command Button::instate +# ---------------------------------------------------------------------------- +proc Button::instate { path args } { + eval $path:cmd instate $args +} + + +# ---------------------------------------------------------------------------- +# Command Button::state +# ---------------------------------------------------------------------------- +proc Button::state { path args } { + eval $path:cmd state $args +} + # ---------------------------------------------------------------------------- # Command Button::invoke # ---------------------------------------------------------------------------- proc Button::invoke { path } { if { ![string equal [$path:cmd cget -state] "disabled"] } { - $path:cmd configure -state active -relief sunken - update idletasks - set cmd [Widget::getMegawidgetOption $path -armcommand] + if { $::Widget::_theme} { + $path:cmd configure -state active + $path:cmd state pressed + } else { + $path:cmd configure -state active -relief sunken + } + update idletasks + set cmd [Widget::getMegawidgetOption $path -armcommand] if { $cmd != "" } { uplevel \#0 $cmd } - after 100 - set relief [Widget::getMegawidgetOption $path -relief] - if { [string equal $relief "link"] } { - set relief flat - } - $path:cmd configure \ - -state [Widget::getMegawidgetOption $path -state] \ - -relief $relief - set cmd [Widget::getMegawidgetOption $path -disarmcommand] + after 100 + $path:cmd configure -state [Widget::getMegawidgetOption $path -state] + if { $::Widget::_theme} { + $path:cmd state !pressed + } else { + set relief [Widget::getMegawidgetOption $path -relief] + if { [string equal $relief "link"] } { + set relief flat + } + $path:cmd configure -relief $relief + } + set cmd [Widget::getMegawidgetOption $path -disarmcommand] if { $cmd != "" } { uplevel \#0 $cmd } - set cmd [Widget::getMegawidgetOption $path -command] + set cmd [Widget::getMegawidgetOption $path -command] if { $cmd != "" } { uplevel \#0 $cmd } } } - # ---------------------------------------------------------------------------- # Command Button::_enter # ---------------------------------------------------------------------------- proc Button::_enter { path } { @@ -217,14 +274,18 @@ variable _pressed set _current $path if { ![string equal [$path:cmd cget -state] "disabled"] } { $path:cmd configure -state active - if { $_pressed == $path } { - $path:cmd configure -relief sunken - } elseif { [string equal [Widget::cget $path -relief] "link"] } { - $path:cmd configure -relief raised + if { $::Widget::_theme } { + # $path:cmd state active + } else { + if { $_pressed == $path } { + $path:cmd configure -relief sunken + } elseif { [string equal [Widget::cget $path -relief] "link"] } { + $path:cmd configure -relief raised + } } } } @@ -236,18 +297,21 @@ variable _pressed set _current "" if { ![string equal [$path:cmd cget -state] "disabled"] } { $path:cmd configure -state [Widget::cget $path -state] - set relief [Widget::cget $path -relief] - if { $_pressed == $path } { - if { [string equal $relief "link"] } { - set relief raised - } - $path:cmd configure -relief $relief - } elseif { [string equal $relief "link"] } { - $path:cmd configure -relief flat + if { $::Widget::_theme } { + } else { + set relief [Widget::cget $path -relief] + if { $_pressed == $path } { + if { [string equal $relief "link"] } { + set relief raised + } + $path:cmd configure -relief $relief + } elseif { [string equal $relief "link"] } { + $path:cmd configure -relief flat + } } } } @@ -257,12 +321,17 @@ proc Button::_press { path } { variable _pressed if { ![string equal [$path:cmd cget -state] "disabled"] } { set _pressed $path - $path:cmd configure -relief sunken - set cmd [Widget::getMegawidgetOption $path -armcommand] + if { $::Widget::_theme} { + ttk::clickToFocus $path + $path state pressed + } else { + $path:cmd configure -relief sunken + } + set cmd [Widget::getMegawidgetOption $path -armcommand] if { $cmd != "" } { uplevel \#0 $cmd set repeatdelay [Widget::getMegawidgetOption $path -repeatdelay] set repeatint [Widget::getMegawidgetOption $path -repeatinterval] if { $repeatdelay > 0 } { @@ -282,16 +351,20 @@ variable _current variable _pressed if { $_pressed == $path } { set _pressed "" - set relief [Widget::getMegawidgetOption $path -relief] after cancel "Button::_repeat $path" - if { [string equal $relief "link"] } { - set relief raised + if { $::Widget::_theme} { + $path state !pressed + } else { + set relief [Widget::getMegawidgetOption $path -relief] + if { [string equal $relief "link"] } { + set relief raised + } + $path:cmd configure -relief $relief } - $path:cmd configure -relief $relief set cmd [Widget::getMegawidgetOption $path -disarmcommand] if { $cmd != "" } { uplevel \#0 $cmd } if { $_current == $path && Index: buttonbox.tcl ================================================================== --- buttonbox.tcl +++ buttonbox.tcl @@ -143,15 +143,20 @@ set tags $flags(-tags) unset flags(-tags) set args [array get flags] } - eval [list Button::create $but \ - -background [Widget::getoption $path -background]\ - -padx [Widget::getoption $path -padx] \ - -pady [Widget::getoption $path -pady]] \ - $args [list -default $style] + if { $::Widget::_theme} { + eval [list Button::create $but] \ + $args [list -default $style] + } else { + eval [list Button::create $but \ + -background [Widget::getoption $path -background]\ + -padx [Widget::getoption $path -padx] \ + -pady [Widget::getoption $path -pady]] \ + $args [list -default $style] + } # ericm@scriptics.com: set up tags, just like the menu items foreach tag $tags { lappend data(tags,$tag) $but if { ![info exists data(tagstate,$tag)] } { Index: color.tcl ================================================================== --- color.tcl +++ color.tcl @@ -1,14 +1,17 @@ namespace eval SelectColor { Widget::define SelectColor color Dialog Widget::declare SelectColor { - {-title String "Select a color" 0} - {-parent String "" 0} - {-color TkResource "" 0 {label -background}} - {-type Enum "dialog" 1 {dialog popup}} - {-placement String "center" 1} + {-title String "Select a color" 0} + {-parent String "" 0} + {-command String "" 0} + {-help Boolean 0 1} + {-color TkResource "" 0 {label -background}} + {-type Enum "dialog" 1 {dialog popup}} + {-placement String "center" 1} + {-background TkResource "" 0 {label -background}} } variable _baseColors { \#0000ff \#00ff00 \#00ffff \#ff0000 \#ff00ff \#ffff00 \#000099 \#009900 \#009999 \#990000 \#990099 \#999900 @@ -29,10 +32,18 @@ variable _selectype variable _selection variable _wcolor variable _image variable _hsv + + variable _command + variable _unsavedSelection + variable _oldColor + variable _entryColor + variable _bgColor + variable _fgColor + variable _rounds } proc SelectColor::create { path args } { Widget::init SelectColor $path $args @@ -68,18 +79,25 @@ variable _baseColors variable _userColors variable _wcolor variable _selectype variable _selection + variable _command + variable _bgColor + variable _rounds Widget::init SelectColor $path $args set top [toplevel $path] set parent [winfo toplevel [winfo parent $top]] wm withdraw $top wm transient $top $parent wm overrideredirect $top 1 catch { wm attributes $top -topmost 1 } + + set _command [Widget::cget $path -command] + set _bgColor [Widget::cget $path -background] + set _rounds {} set frame [frame $top.frame \ -highlightthickness 0 \ -relief raised -borderwidth 2] set col 0 @@ -113,10 +131,18 @@ bind $top <1> {set SelectColor::_selection -1} bind $top {set SelectColor::_selection -2} bind $top [subst {if {"%W" == "$top"} \ {set SelectColor::_selection -2}}] + + # set background color for menu + $f configure -bg $_bgColor + $frame configure -bg $_bgColor + foreach w [winfo children $frame] { + $w configure -highlightcolor $_bgColor -highlightbackground $_bgColor + } + eval [list BWidget::place $top 0 0] $placement wm deiconify $top raise $top if {$::tcl_platform(platform) == "unix"} { @@ -143,17 +169,39 @@ break } lappend nativecmd $opts($key) $val } if {$native} { + # Call native dialog return [eval $nativecmd] } } + # Call BWidget dialog return [eval [list dialog $path] $args] } else { - return [lindex $colors $_selection] + # The user has either selected one of the palette colors, or has + # cancelled. The full BWidget/native dialog was not called. + # Unless the user has cancelled, pass the selected + # color to _userCommand. + set tmpCol [lindex $colors $_selection] + if {[string equal $tmpCol ""]} { + # User has cancelled - no need to call _userCommand. + } else { + _userCommand $tmpCol + } + return $tmpCol + } +} + + +proc SelectColor::_userCommand {color} { + variable _command + if {[string equal $_command {}]} { + return } + uplevel #0 $_command [list $color] + return } proc SelectColor::dialog {path args} { variable _baseColors @@ -160,22 +208,41 @@ variable _userColors variable _widget variable _selection variable _image variable _hsv + variable _command + variable _unsavedSelection + variable _oldColor + variable _entryColor + variable _bgColor + variable _fgColor + variable _rounds + Widget::init SelectColor $path:SelectColor $args set top [Dialog::create $path \ -title [Widget::cget $path:SelectColor -title] \ -parent [Widget::cget $path:SelectColor -parent] \ - -separator 1 -default 0 -cancel 1 -anchor e] + -separator 0 -default 0 -cancel 1 -anchor e] wm resizable $top 0 0 set dlgf [$top getframe] set fg [frame $dlgf.fg] set desc [list \ base _baseColors "Base colors" \ user _userColors "User colors"] + + set help [Widget::cget $path:SelectColor -help] + set _command [Widget::cget $path:SelectColor -command] + set _bgColor [Widget::cget $path:SelectColor -background] + set _rounds {} + set mouseHelpText "" + if {$help} { + append mouseHelpText [subst -nocommands -novariables\ + [lindex [BWidget::getname mouseHelpText] 0]] + } + set count 0 foreach {type varcol defTitle} $desc { set col 0 set lin 0 set title [lindex [BWidget::getname "${type}Colors"] 0] @@ -195,35 +262,87 @@ pack $fcolor -in $fround grid $fround -in $subf -row $lin -column $col -padx 1 -pady 1 bind $fround [list SelectColor::_select_rgb $count] bind $fcolor [list SelectColor::_select_rgb $count] + + DynamicHelp::add $fround -text $mouseHelpText + DynamicHelp::add $fcolor -text $mouseHelpText bind $fround \ "SelectColor::_select_rgb [list $count]; [list $top] invoke 0" bind $fcolor \ "SelectColor::_select_rgb [list $count]; [list $top] invoke 0" + + # Record list of $fround values in _rounds + lappend _rounds $fround incr count if {[incr col] == 6} { incr lin set col 0 } } pack $titf -anchor w -pady 2 } + + # Record these colors for later use + set _fgColor [$fg.round0 cget -highlightcolor] + + # Add a TitleFrame $titf to wrap $fg.round and $fg.value + set name [lindex [BWidget::getname yourSelection] 0] + set titf [TitleFrame $fg.choice -text $name] + set subf [$titf getframe] + pack $titf -anchor w -pady 2 -expand yes -fill both + + # Add an entry widget $fg.value for the #RRGGBB value + if {$::tk_version > 8.4} { + set fixedFont TkFixedFont + } else { + set fixedFont Courier + } + set subf2 $fg.vround + frame $subf2 -highlightthickness 0 -relief sunken -borderwidth 2 + entry $fg.value -width 8 -relief sunken -bd 0 -highlightthickness 0 \ + -bg white -textvariable ::SelectColor::_entryColor -font $fixedFont + pack $subf2 -in $subf -anchor w -side left + pack $fg.value -in $subf2 -anchor w -side left + + if {$help} { + DynamicHelp::add $fg.value -text [subst -nocommands -novariables\ + [lindex [BWidget::getname keyboardHelpText] 0]] + } + + # Remove focus from the entry widget by clicking anywhere... + bind $top <1> [list ::SelectColor::_CheckFocus %W] + + # ... or by pressing Return/Escape. + bind $fg.value [list ::SelectColor::_CheckFocus .] + bind $fg.value [list ::SelectColor::_CheckFocus .] + bind $fg.value {+break} + bind $fg.value {+break} + # Break so that the bindings to these events on the toplevel are not + # executed. + + # MODS - record the Tk window path for the entry widget. + set _widget(en) $fg.value + set fround [frame $fg.round \ -highlightthickness 0 \ -relief sunken -borderwidth 2] set fcolor [frame $fg.color \ -width 50 \ -highlightthickness 0 \ -relief flat -borderwidth 0] pack $fcolor -in $fround -fill y -expand yes - pack $fround -anchor e -pady 2 -fill y -expand yes + pack $fround -in $subf -side right -anchor e -pady 2 -fill y -expand yes - set fd [frame $dlgf.fd] + # Add a TitleFrame $dlgf.fd to wrap the canvas selectors. The + # labels are referenced by the DynamicHelp tooltip. + set name [lindex [BWidget::getname colorSelectors] 0] + set fd0 [TitleFrame $dlgf.fd -text $name] + set fd [$fd0 getframe] set f1 [frame $fd.f1 -relief sunken -borderwidth 2] set f2 [frame $fd.f2 -relief sunken -borderwidth 2] set c1 [canvas $f1.c -width 200 -height 200 -bd 0 -highlightthickness 0] set c2 [canvas $f2.c -width 15 -height 200 -bd 0 -highlightthickness 0] @@ -233,11 +352,12 @@ $c2 create polygon 0 0 10 5 0 10 -fill black -outline white -tags target pack $c1 $c2 pack $f1 $f2 -side left -padx 10 -anchor n - pack $fg $fd -side left -anchor n -fill y + pack $fg $fd0 -side left -anchor n -fill y + pack configure $fd0 -pady 2 -padx {4 0} bind $c1 [list SelectColor::_select_hue_sat %x %y] bind $c1 [list SelectColor::_select_hue_sat %x %y] bind $c2 [list SelectColor::_select_value %x %y] @@ -267,22 +387,78 @@ set _hsv [eval rgbToHsv $rgb] _set_rgb [eval [list format "\#%04x%04x%04x"] $rgb] _set_hue_sat [lindex $_hsv 0] [lindex $_hsv 1] _set_value [lindex $_hsv 2] - $top add -name ok - $top add -name cancel + # Initialize _oldColor which is used to reset the color supplied to + # _userCommand if the user cancels. + set _oldColor [set _unsavedSelection] + set tmp24 [::SelectColor::_24BitRgb $_oldColor] + if {[_ValidateColorEntry forced $tmp24]} { + set ::SelectColor::_entryColor $tmp24 + } else { + # Value $tmp24 does not pass entry widget validation and if used + # would disable validation. Use this default instead. + set _entryColor # + } + + # Validate input to the entry field. + # To avoid conflict with the entry -variable (_entryColor), do not set the + # latter directly (because a failed validation will switch off subsequent + # validations). Either call _SetEntryValue, or set _unsavedSelection which + # triggers the trace. + + $fg.value configure -validate all -validatecommand \ + [list SelectColor::_ValidateColorEntry %V %P] + + # Trace _unsavedSelection + # Subsequent modifications to _unsavedSelection will update the entry + # widget, if the value is valid. + # From now on, this is the only way that: + # (1) ::SelectColor::_SetEntryValue is called + # (2) ::SelectColor::_entryColor is modified (except by the user typing in + # the entry widget) + + trace add variable ::SelectColor::_unsavedSelection write ::SelectColor::_SetEntryValue + + $top add -text [lindex [BWidget::getname ok] 0] + $top add -text [lindex [BWidget::getname cancel] 0] + + # Override background color + ReColor $path $_bgColor + set res [$top draw] if {$res == 0} { set color [$fg.color cget -background] } else { + # User has cancelled - call _userCommand to undo any changes made + # in the caller. + _userCommand $_oldColor set color "" } + + trace remove variable ::SelectColor::_unsavedSelection write ::SelectColor::_SetEntryValue + destroy $top return $color } + +# ---------------------------------------------------------------------------- +# Command SelectColor::setbasecolor +# ---------------------------------------------------------------------------- +# Exported command, to allow the caller to set the base colors of the palette. + +proc SelectColor::setbasecolor { idx color } { + variable _baseColors + set _baseColors [lreplace $_baseColors $idx $idx $color] +} + +# ---------------------------------------------------------------------------- +# Command SelectColor::setcolor +# ---------------------------------------------------------------------------- + proc SelectColor::setcolor { idx color } { variable _userColors set _userColors [lreplace $_userColors $idx $idx $color] } @@ -290,19 +466,26 @@ variable _baseColors variable _userColors variable _selection variable _widget variable _hsv + variable _unsavedSelection + variable _bgColor + variable _fgColor set frame $_widget(fcolor) + + # Use highlight color instead of focus to identify the selected + # palette color. Tab traversal of focus now works correctly. if {$_selection >= 0} { $frame.round$_selection configure \ - -relief sunken -highlightthickness 1 -borderwidth 2 + -relief sunken -highlightthickness 1 -borderwidth 2 \ + -highlightbackground $_bgColor } $frame.round$count configure \ - -relief flat -highlightthickness 2 -borderwidth 1 - focus $frame.round$count + -relief flat -highlightthickness 2 -borderwidth 1 \ + -highlightbackground $_fgColor set _selection $count set bg [$frame.color$count cget -background] set user [expr {$_selection-[llength $_baseColors]}] if {$user >= 0 && [string equal \ @@ -314,22 +497,33 @@ } else { set _hsv [eval rgbToHsv [winfo rgb $frame.color$count $bg]] _set_hue_sat [lindex $_hsv 0] [lindex $_hsv 1] _set_value [lindex $_hsv 2] $frame.color configure -background $bg + + # Display selected color in entry widget (via trace on + # ::SelectColor::_unsavedSelection), and notify caller. + set ::SelectColor::_unsavedSelection $bg + _userCommand $bg } } proc SelectColor::_set_rgb {rgb} { variable _selection variable _baseColors variable _userColors variable _widget + variable _unsavedSelection set frame $_widget(fcolor) $frame.color configure -background $rgb + + # Display selected color in entry widget (via trace on + # ::SelectColor::_unsavedSelection), and notify caller. + set ::SelectColor::_unsavedSelection $rgb + _userCommand $rgb set user [expr {$_selection-[llength $_baseColors]}] if {$user >= 0} { $frame.color$_selection configure -background $rgb set _userColors [lreplace $_userColors $user $user $rgb] } @@ -489,5 +683,236 @@ } } return [list $hue $sat [expr {$max/65535}]] } +# ------------------------------------------------------------------------------ +# Command SelectColor::ReColor +# ------------------------------------------------------------------------------ +# Command to change the background color for the dialog. +# +# FIXME Ideally this would be called by "$w configure -background $value". +# Currently a "configure -background" command is passed to Dialog and Widget +# but does not change SelectColor. +# HaO: it might also be possible that this is controled by the option data base. +# ------------------------------------------------------------------------------ + +proc SelectColor::ReColor {path newColor} { + variable _bgColor + variable _rounds + + set _bgColor $newColor + + $path configure -bg $_bgColor + + # Use the internal names of the dialog widget - it would be nicer to + # use a colored dialog widget. + foreach child { + fd fd.f.f1 fd.f.f2 + fg fg.base fg.choice + fg.user fg.round fg.vround + } { + $path.frame.$child configure -background $_bgColor + } + + # Special treatment for Aqua native buttons. + # FIXME implement a general fix for BWidget Button/ButtonBox/Dialog + if {[string equal [tk windowingsystem] "aqua"]} { + $path.bbox.b0 configure -highlightbackground $_bgColor \ + -highlightthickness 0 + $path.bbox.b1 configure -highlightbackground $_bgColor \ + -highlightthickness 0 + } else { + $path.bbox.b0 configure -bg $_bgColor -activebackground $_bgColor \ + -highlightbackground $_bgColor + $path.bbox.b1 configure -bg $_bgColor -activebackground $_bgColor \ + -highlightbackground $_bgColor + } + + foreach fround $_rounds { + $fround configure -highlightbackground $_bgColor -bg $_bgColor + } + + return +} + + +# ------------------------------------------------------------------------------ +# Command SelectColor::_24BitRgb +# ------------------------------------------------------------------------------ +# Command to convert a hex 12n-bit RGB color to 24-bit, n > 0. +# Convert anything else to {}. +# Used to process the display in the entry widget. +# ------------------------------------------------------------------------------ + +proc SelectColor::_24BitRgb {col} { + set lenny [string length $col] + incr lenny -1 + + if { ($lenny % 3) + || ($lenny == 0) + || (![regexp {^#[a-fA-F0-9]*$} $col]) + } { + # Not a multiple of 3, or not leading #, or nothing after #, + # or non-HEX digits. + return {} + } elseif {$lenny == 3} { + # 12-bit, pad to 24-bit + set val $col + set val [string replace $val 3 3 "[string index $val 3]0"] + set val [string replace $val 2 2 "[string index $val 2]0"] + set val [string replace $val 1 1 "[string index $val 1]0"] + return $val + } elseif {$lenny == 6} { + # 24-bit, return unchanged + return $col + } else { + # Truncate to 24-bit + set delta [expr {$lenny / 3}] + set delta2 [expr {$delta * 2}] + set deltaP1 [incr delta] + set deltaP2 [incr delta] + set delta2P1 [incr delta2] + set delta2P2 [incr delta2] + set result # + append result [string range $col 1 2] + append result [string range $col $deltaP1 $deltaP2] + append result [string range $col $delta2P1 $delta2P2] + return $result + } +} + + +# ------------------------------------------------------------------------------ +# Command SelectColor::_SetEntryValue +# ------------------------------------------------------------------------------ +# Command to update the (hexadecimal color displayed in the) entry widget +# when there is a change in the color currently selected in the GUI, which is +# stored in _unsavedSelection. +# +# This command is called by a write trace on _unsavedSelection; if the +# value of this variable is a valid color (i.e. "#" followed by 3N hex digits), +# this command converts the value to 24 bits and sets ::SelectColor::_entryColor +# to the result, thereby displaying it in the entry widget. Therefore, +# when the user chooses a color by means other than the entry widget, this +# command updates the entry widget. +# +# This command does not update the GUI when the user changes the value in the +# entry widget: that is done instead by the -vcmd of the entry widget, which +# is SelectColor::_ValidateColorEntry. When the user chooses a color by typing +# in the entry widget, the command _ValidateColorEntry copies the value to +# _unsavedSelection if a keystroke in the widget makes its contents 3N hex +# digits long. +# ------------------------------------------------------------------------------ + +proc SelectColor::_SetEntryValue {argVarName var2 op} { + variable _entryColor + variable _unsavedSelection + + if {[string equal $argVarName ::SelectColor::_unsavedSelection] && + [string equal $var2 {}] && [string equal $op "write"]} { + # OK + } else { + # Unexpected call + return -code error "Unexpected trace of variable\ + \"$argVarName\", \"$var2\", \"$op\"" + } + + set col24bit [::SelectColor::_24BitRgb [set $argVarName]] + + if {[_ValidateColorEntry forced $col24bit]} { + set ::SelectColor::_entryColor $col24bit + } else { + # Value is invalid, and if written to _entryColor this would disable + # validation. + } + + return +} + + +# ------------------------------------------------------------------------------ +# Command SelectColor::_CheckFocus +# ------------------------------------------------------------------------------ +# This command is called with argument %W as a binding to <1> on the toplevel. +# It is also called with argument {.}, by bindings on the entry widget to +# , . +# +# The command does something only if the entry widget has focus, and the +# argument (the clicked window) is the Tk window path of somewhere else. Then, +# the command removes focus from the entry widget to the default button. +# ------------------------------------------------------------------------------ + +proc SelectColor::_CheckFocus {w} { + variable _widget + + if { (! [string equal $w $_widget(en)]) && + ([string equal [focus] $_widget(en)])} { + set top [winfo toplevel $_widget(en)] + $top setfocus default + } + + return +} + + +# ------------------------------------------------------------------------------ +# Command SelectColor::_ValidateColorEntry +# ------------------------------------------------------------------------------ +# This command is the "-validate all -vcmd" of the entry widget. +# It is also called by SelectColor::dialog and SelectColor::_SetEntryValue to +# check values assigned to _entryColor. +# +# When the user chooses a color by typing in the entry widget, this command +# copies the value to _unsavedSelection if a keystroke in the widget makes its +# contents 3N hex digits long. +# ------------------------------------------------------------------------------ + +proc SelectColor::_ValidateColorEntry {percentV percentP} { + variable _unsavedSelection + + set result [regexp -- {^#[0-9a-fA-F]*$} $percentP] + set lenny [string length $percentP] + + if {$result} { + if {[string equal $percentV "forced"]} { + # Validation only. Don't want a loop. + } elseif {[string equal $percentV "key"]} { + # Copy to GUI if a valid color. + if {($lenny - 1) % 3 || $lenny == 1} { + # Not a valid color, which needs 3n+1 characters, n > 0 + } else { + after idle [list SelectColor::_SetWithoutTrace $percentP] + } + } elseif {[string equal $percentV "focusout"]} { + # If the color is valid it will already have been copied to the GUI + # and to _userCommand by the "key" validation above. + # + # The code below only needs to reset the value in the entry widget. + # Remove an invalid value, convert a valid one to 24-bit. + # Ignore $percentP, just fire the trace on _unsavedSelection. + set color $_unsavedSelection + after idle [list set ::SelectColor::_unsavedSelection $color] + } + } + + return $result +} + + +# ------------------------------------------------------------------------------ +# Command SelectColor::_SetWithoutTrace +# ------------------------------------------------------------------------------ +# This command sets _unsavedSelection (using _set_rgb) without firing the trace +# that copies the value to _entryColor. +# The command is called by SelectColor::_ValidateColorEntry to avoid a loop. +# ------------------------------------------------------------------------------ + +proc SelectColor::_SetWithoutTrace {value} { + trace remove variable ::SelectColor::_unsavedSelection write ::SelectColor::_SetEntryValue + _set_rgb $value + set _hsv [eval rgbToHsv [winfo rgb . $value]] + _set_hue_sat [lindex $_hsv 0] [lindex $_hsv 1] + _set_value [lindex $_hsv 2] + trace add variable ::SelectColor::_unsavedSelection write ::SelectColor::_SetEntryValue + return +} Index: combobox.tcl ================================================================== --- combobox.tcl +++ combobox.tcl @@ -1,17 +1,18 @@ # ---------------------------------------------------------------------------- # combobox.tcl # This file is part of Unifix BWidget Toolkit -# $Id: combobox.tcl,v 1.42 2009/07/07 17:28:14 oehhar Exp $ +# $Id: combobox.tcl,v 1.42.2.3 2012/04/02 09:53:41 oehhar Exp $ # ---------------------------------------------------------------------------- # Index of commands: # - ComboBox::create # - ComboBox::configure # - ComboBox::cget # - ComboBox::setvalue # - ComboBox::getvalue # - ComboBox::clearvalue +# - ComboBox::getentry # - ComboBox::_create_popup # - ComboBox::_mapliste # - ComboBox::_unmapliste # - ComboBox::_select # - ComboBox::_modify_value @@ -25,13 +26,17 @@ Widget::tkinclude ComboBox frame :cmd \ include {-relief -borderwidth -bd -background} \ initialize {-relief sunken -borderwidth 2} - Widget::bwinclude ComboBox Entry .e \ - remove {-relief -bd -borderwidth -bg} \ - rename {-background -entrybg} + if {[Widget::theme]} { + Widget::bwinclude ComboBox Entry .e + } else { + Widget::bwinclude ComboBox Entry .e \ + remove {-relief -bd -borderwidth -bg} \ + rename {-background -entrybg} + } Widget::declare ComboBox { {-height TkResource 0 0 listbox} {-values String "" 0} {-images String "" 0} @@ -44,16 +49,20 @@ {-bwlistbox Boolean 0 0} {-listboxwidth Int 0 0} {-hottrack Boolean 0 0} } - Widget::addmap ComboBox ArrowButton .a { - -background {} -foreground {} -disabledforeground {} -state {} + if {[Widget::theme]} { + Widget::addmap ComboBox ArrowButton .a { + -background {} -state {} + } + } else { + Widget::addmap ComboBox ArrowButton .a { + -background {} -foreground {} -disabledforeground {} -state {} + } } - Widget::syncoptions ComboBox Entry .e {-text {}} - ::bind BwComboBox [list after idle {BWidget::refocus %W %W.e}] ::bind BwComboBox [list ComboBox::_destroy %W] ::bind ListBoxHotTrack { %W selection clear 0 end @@ -84,12 +93,17 @@ [list -highlightthickness 0 -takefocus 0 -class ComboBox] Widget::initFromODB ComboBox $path $maps(ComboBox) bindtags $path [list $path BwComboBox [winfo toplevel $path] all] - set entry [eval [list Entry::create $path.e] $maps(.e) \ - [list -relief flat -borderwidth 0 -takefocus 1]] + if {[Widget::theme]} { + set entry [eval [list Entry::create $path.e] $maps(.e) \ + [list -takefocus 1]] + } else { + set entry [eval [list Entry::create $path.e] $maps(.e) \ + [list -relief flat -borderwidth 0 -takefocus 1]] + } ::bind $path.e [list $path _focus_out] ::bind $path <> [list $path _traverse_in] if {[Widget::cget $path -autocomplete]} { @@ -282,14 +296,17 @@ # if the dropdown listbox is shown, simply force the actual entry # colors into it. If it is not shown, the next time the dropdown # is shown it'll get the actual colors anyway if {[winfo exists $path.shell.listb]} { $path.shell.listb configure \ - -bg [Widget::cget $path -entrybg] \ - -fg [Widget::cget $path -foreground] \ + -bg [_getbg $path] \ + -fg [_getfg $path] + if {![Widget::theme]} { + $path.shell.listb configure \ -selectbackground [Widget::cget $path -selectbackground] \ -selectforeground [Widget::cget $path -selectforeground] + } } return $res } @@ -433,10 +450,40 @@ # ---------------------------------------------------------------------------- proc ComboBox::clearvalue { path } { Entry::configure $path.e -text "" } +# ---------------------------------------------------------------------------- +# Command ComboBox::getentry +# ---------------------------------------------------------------------------- +proc ComboBox::getentry { path } { + return $path.e +} + +proc ComboBox::_getfg {path} { + # First try to retrieve option + set fg [Widget::cget $path -foreground]; + if { 0 == [string length $fg] && [Widget::theme] } { + # fall back to style settings when not configured for widget + return [::ttk::style lookup TEntry -foreground]; + } + return $fg; +} +proc ComboBox::_getbg {path} { + if {[Widget::theme]} { + # First try to retrieve option + set bg [Widget::cget $path -background]; + if {0 == [string length $bg]} { + # fall back to style settings when not configured for widget + return [::ttk::style lookup TEntry -backround]; + } + } else { + # fetch the entrybg resource value + set bg [Widget::cget $path -entrybg] + } + return $bg; +} # ---------------------------------------------------------------------------- # Command ComboBox::_create_popup # ---------------------------------------------------------------------------- proc ComboBox::_create_popup { path } { set shell $path.shell @@ -466,27 +513,36 @@ toplevel $shell -relief solid -bd 1 wm withdraw $shell wm overrideredirect $shell 1 # these commands cause the combobox to behave strangely on OS X - if {![string equal [tk windowingsystem] "aqua"]} { + if {! $Widget::_aqua } { update idle wm transient $shell [winfo toplevel $path] catch { wm attributes $shell -topmost 1 } } set sw [ScrolledWindow $shell.sw -managed 1 -size $sbwidth -ipad 0] if {$bw} { - set listb [ListBox $shell.listb \ - -relief flat -borderwidth 0 -highlightthickness 0 \ - -selectmode single -selectfill 1 -autofocus 0 -height $h \ - -font [Widget::cget $path -font] \ - -bg [Widget::cget $path -entrybg] \ - -fg [Widget::cget $path -foreground] \ - -selectbackground [Widget::cget $path -selectbackground] \ - -selectforeground [Widget::cget $path -selectforeground]] + if {[Widget::theme]} { + set listb [ListBox $shell.listb \ + -relief flat -borderwidth 0 -highlightthickness 0 \ + -selectmode single -selectfill 1 -autofocus 0 -height $h \ + -font [Widget::cget $path -font] \ + -bg [_getbg $path] \ + -fg [_getfg $path]] + } else { + set listb [ListBox $shell.listb \ + -relief flat -borderwidth 0 -highlightthickness 0 \ + -selectmode single -selectfill 1 -autofocus 0 -height $h \ + -font [Widget::cget $path -font] \ + -bg [_getbg $path] \ + -fg [_getfg $path] \ + -selectbackground [Widget::cget $path -selectbackground] \ + -selectforeground [Widget::cget $path -selectforeground]] + } set values [Widget::cget $path -values] set images [Widget::cget $path -images] foreach value $values image $images { $listb insert end #auto -text $value -image $image @@ -496,20 +552,31 @@ if {[Widget::cget $path -hottrack]} { $listb bindText [list $listb selection set] $listb bindImage [list $listb selection set] } } else { - set listb [listbox $shell.listb \ - -relief flat -borderwidth 0 -highlightthickness 0 \ - -exportselection false \ - -font [Widget::cget $path -font] \ - -height $h \ - -bg [Widget::cget $path -entrybg] \ - -fg [Widget::cget $path -foreground] \ - -selectbackground [Widget::cget $path -selectbackground] \ - -selectforeground [Widget::cget $path -selectforeground] \ - -listvariable [Widget::varForOption $path -values]] + if {[Widget::theme]} { + set listb [listbox $shell.listb \ + -relief flat -borderwidth 0 -highlightthickness 0 \ + -exportselection false \ + -font [Widget::cget $path -font] \ + -height $h \ + -bg [_getbg $path] \ + -fg [_getfg $path] \ + -listvariable [Widget::varForOption $path -values]] + } else { + set listb [listbox $shell.listb \ + -relief flat -borderwidth 0 -highlightthickness 0 \ + -exportselection false \ + -font [Widget::cget $path -font] \ + -height $h \ + -bg [_getbg $path] \ + -fg [_getfg $path] \ + -selectbackground [Widget::cget $path -selectbackground] \ + -selectforeground [Widget::cget $path -selectforeground] \ + -listvariable [Widget::varForOption $path -values]] + } ::bind $listb [list ComboBox::_select $path @%x,%y] if {[Widget::cget $path -hottrack]} { bindtags $listb [concat [bindtags $listb] ListBoxHotTrack] } @@ -564,14 +631,17 @@ destroy $shell.sw set sw [ScrolledWindow $shell.sw -managed 1 -size $sbwidth -ipad 0] $listb configure \ -height $h \ -font [Widget::cget $path -font] \ - -bg [Widget::cget $path -entrybg] \ - -fg [Widget::cget $path -foreground] \ - -selectbackground [Widget::cget $path -selectbackground] \ - -selectforeground [Widget::cget $path -selectforeground] + -bg [_getbg $path] \ + -fg [_getfg $path] + if {![Widget::theme]} { + $listb configure \ + -selectbackground [Widget::cget $path -selectbackground] \ + -selectforeground [Widget::cget $path -selectforeground] + } pack $sw -fill both -expand yes $sw setwidget $listb raise $listb } @@ -631,11 +701,11 @@ if {!$width} { set width [winfo width $path] } BWidget::place $path.shell $width 0 below $path wm deiconify $path.shell raise $path.shell BWidget::focus set $listb - if { ! [string equal [tk windowingsystem] "aqua"] } { + if {! $Widget::_aqua } { BWidget::grab global $path } } @@ -645,11 +715,11 @@ proc ComboBox::_unmapliste { path {refocus 1} } { # On aqua, state is zoomed, otherwise normal if {[winfo exists $path.shell] && \ ( [string equal [wm state $path.shell] "normal"] || [string equal [wm state $path.shell] "zoomed"] ) } { - if {![string equal [tk windowingsystem] "aqua"]} { + if {! $Widget::_aqua } { BWidget::grab release $path BWidget::focus release $path.shell.listb $refocus # Update now because otherwise [focus -force...] makes the app hang! if {$refocus} { update Index: demo/demo.tcl ================================================================== --- demo/demo.tcl +++ demo/demo.tcl @@ -25,10 +25,25 @@ } { namespace inscope :: source $DEMODIR/$script } } +image create photo bwidget16 -data { + R0lGODlhEAAQAOMJABat6IGYffaBCUSku/KCDcCMPomXdgCy//+AANnZ2dnZ2dnZ2dnZ2dnZ2dnZ + 2dnZ2SH5BAEKAA8ALAAAAAAQABAAAAQ58MlJq70U6a0x/9c2iRb5mNmHjmpXuiecIpRA0JWJDEfw + HIffoWU4AIBBYKuABAoxSGEQ6oxins8IADs= +} + +image create photo faded16 -data { + R0lGODlhEAAQAKEDAAAAAICAgKCgoP///yH5BAEKAAMALAAAAAAQABAAAAIjnI+py+1vQEABsDoH + blUI+XyAAImk033Zsmng8hoVRNd2XQAAOw== +} + +image create photo stop16 -data { + R0lGODlhEAAQAMIFAAAAAC8DA3gKCpYMDPAUFP///////////yH5BAEKAAcALAAAAAAQABAAAAMm + SLrc/jDKqYBgAsB8CY/ZMFjTGAzUEACoFI7d83nkUysZpe/8ngAAOw== +} proc Demo::create { } { global tk_patchLevel variable _wfont variable notebook @@ -131,10 +146,18 @@ incr prgindic set f4 [DemoDnd::create $notebook] set prgtext "Creating Tree..." incr prgindic set f5 [DemoTree::create $notebook] + + foreach page [$notebook pages] { + $notebook itemconfigure $page \ + -image bwidget16 \ + -rimage faded16 \ + -ractiveimage stop16 \ + -rimagecmd {::Demo::_close_tab} + } set prgtext "Done" incr prgindic $notebook compute_size pack $notebook -fill both -expand yes -padx 4 -pady 4 @@ -142,10 +165,35 @@ pack $mainframe -fill both -expand yes update idletasks destroy .intro } + +proc Demo::_close_tab { tabSet tabName } { + after idle [list $tabSet delete $tabName] + + set tabIndex [$tabSet index $tabName] + set tabList [$tabSet pages] + set tabTot [llength $tabList] + + # Pick another tab to raise. + if {$tabTot == 1} { + # No other tabs. + exit + } elseif {$tabIndex < $tabTot - 1} { + # Raise the tab to the right. + set raiseTabName [lindex $tabList [expr {$tabIndex + 1}]] + } else { + # This tab is furthest to the right. Raise the tab to the left. + set raiseTabName [lindex $tabList [expr {$tabIndex - 1}]] + } + + $tabSet raise $raiseTabName + $tabSet see $raiseTabName + return +} + proc Demo::update_font { newfont } { variable _wfont variable notebook @@ -196,10 +244,22 @@ lappend ::auto_path [file dirname $DEMODIR] package require BWidget option add *TitleFrame.l.font {helvetica 11 bold italic} + if {$::tk_version < 8.5} { + set helpFont {helvetica 12} + } else { + set helpFont {TkDefaultFont 10} + } + + DynamicHelp::configure \ + -background #FFFFC0 \ + -foreground #141312 \ + -padx 3 \ + -font $helpFont + wm withdraw . wm title . "BWidget demo" Demo::create BWidget::place . 0 0 center Index: demo/tmpldlg.tcl ================================================================== --- demo/tmpldlg.tcl +++ demo/tmpldlg.tcl @@ -140,11 +140,12 @@ pack $but0 $but1 $but2 $but3 -side left -padx 5 -anchor w } proc DemoDlg::_show_color {w} { set color [SelectColor::menu $w.color [list below $w] \ - -color [$w cget -background]] + -color [$w cget -background] \ + -command [list $w configure -background]] if {[string length $color]} { $w configure -background $color } } Index: dialog.tcl ================================================================== --- dialog.tcl +++ dialog.tcl @@ -1,9 +1,9 @@ # ---------------------------------------------------------------------------- # dialog.tcl # This file is part of Unifix BWidget Toolkit -# $Id: dialog.tcl,v 1.15 2004/09/24 23:56:59 hobbs Exp $ +# $Id: dialog.tcl,v 1.15.2.1 2010/08/04 13:07:59 oehhar Exp $ # ---------------------------------------------------------------------------- # Index of commands: # - Dialog::create # - Dialog::configure # - Dialog::cget @@ -116,12 +116,20 @@ Separator::create $path.sep -orient $orient -background $bg } set _widget($path,realized) 0 set _widget($path,nbut) 0 - bind $path [list ButtonBox::invoke $path.bbox [Widget::getoption $path -cancel]] + set cancel [Widget::getoption $path -cancel] + bind $path [list ButtonBox::invoke $path.bbox $cancel] + if {$cancel != -1} { + wm protocol $path WM_DELETE_WINDOW [list ButtonBox::invoke $path.bbox $cancel] + } bind $path [list ButtonBox::invoke $path.bbox default] + # Tk8.5 (TIP158) separated numeric keyboard enter and main keyboard + # enter on Unix. So bind for both. This does not harm on Tk8.4 so no + # check required. BWidget Ticket [3e31f04367]. + bind $path [list ButtonBox::invoke $path.bbox default] return [Widget::create Dialog $path] } @@ -139,10 +147,18 @@ $path.label configure -background $bg } if { [winfo exists $path.sep] } { Separator::configure $path.sep -background $bg } + } + if { [Widget::hasChanged $path -cancel cancel] } { + bind $path [list ButtonBox::invoke $path.bbox $cancel] + if {$cancel == -1} { + wm protocol $path WM_DELETE_WINDOW "" + } else { + wm protocol $path WM_DELETE_WINDOW [list ButtonBox::invoke $path.bbox $cancel] + } } return $res } Index: dropsite.tcl ================================================================== --- dropsite.tcl +++ dropsite.tcl @@ -53,11 +53,11 @@ ops,copy 1 ops,move 1 ops,link 1 } - if { $tcl_platform(platform) == "unix" } { + if { $::tcl_platform(platform) == "unix" } { set _tabops(mod,alt) 8 } else { set _tabops(mod,alt) 16 } array set _defops \ @@ -71,11 +71,11 @@ bind DragTop {DropSite::_update_operation [expr %s | 1]} bind DragTop {DropSite::_update_operation [expr %s | 1]} bind DragTop {DropSite::_update_operation [expr %s | 4]} bind DragTop {DropSite::_update_operation [expr %s | 4]} - if { $tcl_platform(platform) == "unix" } { + if { $::tcl_platform(platform) == "unix" } { bind DragTop {DropSite::_update_operation [expr %s | 8]} bind DragTop {DropSite::_update_operation [expr %s | 8]} } else { bind DragTop {DropSite::_update_operation [expr %s | 16]} bind DragTop {DropSite::_update_operation [expr %s | 16]} @@ -83,11 +83,11 @@ bind DragTop {DropSite::_update_operation [expr %s & ~1]} bind DragTop {DropSite::_update_operation [expr %s & ~1]} bind DragTop {DropSite::_update_operation [expr %s & ~4]} bind DragTop {DropSite::_update_operation [expr %s & ~4]} - if { $tcl_platform(platform) == "unix" } { + if { $::tcl_platform(platform) == "unix" } { bind DragTop {DropSite::_update_operation [expr %s & ~8]} bind DragTop {DropSite::_update_operation [expr %s & ~8]} } else { bind DragTop {DropSite::_update_operation [expr %s & ~16]} bind DragTop {DropSite::_update_operation [expr %s & ~16]} @@ -441,10 +441,15 @@ variable _data if { $_status & 1 } { upvar \#0 DropSite::$_target drop + # Ticket [1ef1f56cd1] wke/amc 2022-10-12 + # Prevent motion events to be handled as + # drop events when handler calls update and causes pending + # motion events to fire. + set _status [expr {$_status & ~1}]; 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 Index: dynhelp.tcl ================================================================== --- dynhelp.tcl +++ dynhelp.tcl @@ -1,9 +1,9 @@ # ---------------------------------------------------------------------------- # dynhelp.tcl # This file is part of Unifix BWidget Toolkit -# $Id: dynhelp.tcl,v 1.20 2009/07/15 16:50:16 oehhar Exp $ +# $Id: dynhelp.tcl,v 1.20.2.1 2009/08/12 07:20:21 oehhar Exp $ # ---------------------------------------------------------------------------- # Index of commands: # - DynamicHelp::configure # - DynamicHelp::include # - DynamicHelp::sethelp @@ -17,26 +17,34 @@ # ---------------------------------------------------------------------------- namespace eval DynamicHelp { Widget::define DynamicHelp dynhelp -classonly - Widget::declare DynamicHelp { - {-foreground TkResource black 0 label} - {-topbackground TkResource black 0 {label -foreground}} - {-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 "%d >= 100 & %d <= 2000"} - {-state Enum "normal" 0 {normal disabled}} - {-padx TkResource 1 0 label} - {-pady TkResource 1 0 label} - {-bd Synonym -borderwidth} - {-bg Synonym -background} - {-fg Synonym -foreground} - {-topbg Synonym -topbackground} - } + if {$::tcl_version >= 8.5} { + set fontdefault TkTooltipFont + } elseif {$Widget::_aqua} { + set fontdefault {helvetica 11} + } else { + set fontdefault {helvetica 8} + } + + Widget::declare DynamicHelp [list\ + {-foreground TkResource black 0 label}\ + {-topbackground TkResource black 0 {label -foreground}}\ + {-background TkResource "#FFFFC0" 0 label}\ + {-borderwidth TkResource 1 0 label}\ + {-justify TkResource left 0 label}\ + [list -font TkResource $fontdefault 0 label]\ + {-delay Int 600 0 "%d >= 100 & %d <= 2000"}\ + {-state Enum "normal" 0 {normal disabled}}\ + {-padx TkResource 1 0 label}\ + {-pady TkResource 1 0 label}\ + {-bd Synonym -borderwidth}\ + {-bg Synonym -background}\ + {-fg Synonym -foreground}\ + {-topbg Synonym -topbackground}\ + ] proc use {} {} variable _registered variable _canvases @@ -103,11 +111,11 @@ proc DynamicHelp::sethelp { path subpath {force 0}} { foreach {ctype ctext cvar} [Widget::hasChangedX $path \ -helptype -helptext -helpvar] break if { $force || $ctype || $ctext || $cvar } { set htype [Widget::cget $path -helptype] - switch $htype { + switch -- $htype { balloon { return [register $subpath balloon \ [Widget::cget $path -helptext]] } variable { @@ -660,12 +668,11 @@ -bg [Widget::getoption $_top -topbackground] \ -bd [Widget::getoption $_top -borderwidth] \ -screen [winfo screen $w] wm withdraw $_top - if {$::tk_version >= 8.4 - && [string equal [tk windowingsystem] "aqua"]} { + if { $Widget::_aqua } { ::tk::unsupported::MacWindowStyle style $_top help none } else { wm overrideredirect $_top 1 } @@ -689,27 +696,27 @@ set scrwidth [winfo vrootwidth .] set scrheight [winfo vrootheight .] set width [winfo reqwidth $_top] set height [winfo reqheight $_top] - # On windows multi screen configurations, coordinates may get outside - # the main screen. We suppose that all screens have the same size - # because it is not possible to query the size of the other screens. - - set screenx [expr {$x % $scrwidth} ] - set screeny [expr {$y % $scrheight} ] + # On windows multi screen configurations, the virtual screen may start + # at negative positions. + set scrrootx [winfo vrootx .] + set scrrooty [winfo vrooty .] # Increment the required size by the deplacement from the passed point incr width 8 incr height 12 - if { $screenx+$width > $scrwidth } { - set x [expr {$x + ($scrwidth - $screenx) - ($width - 8)}] + # Put at the right border if going over it + if { $x+$width > $scrrootx+$scrwidth } { + set x [expr {$scrwidth + $scrrootx - $width + 8}] } else { incr x 8 } - if { $screeny+$height > $scrheight } { + # Put above widget if below is no space + if { $y+$height > $scrrooty+$scrheight } { set y [expr {$y - $height}] } else { incr y 12 } @@ -717,10 +724,13 @@ update idletasks if {![winfo exists $_top]} { return } wm deiconify $_top raise $_top + # Sometimes the tooltip does not occur under + # gnome/metacity on ubuntu. + after 5; } } # ---------------------------------------------------------------------------- # Command DynamicHelp::_unset_help Index: entry.tcl ================================================================== --- entry.tcl +++ entry.tcl @@ -1,9 +1,9 @@ # ------------------------------------------------------------------------------ # entry.tcl # This file is part of Unifix BWidget Toolkit -# $Id: entry.tcl,v 1.22 2009/06/10 08:48:06 oehhar Exp $ +# $Id: entry.tcl,v 1.22.2.2 2012/04/02 09:53:41 oehhar Exp $ # ------------------------------------------------------------------------------ # Index of commands: # - Entry::create # - Entry::configure # - Entry::cget @@ -20,38 +20,46 @@ Widget::define Entry entry DragSite DropSite DynamicHelp # Note: -textvariable is pulled off of the tk entry and put onto the # BW Entry so that we avoid the TkResource test for it, which screws up # the existance/non-existance bits of the -textvariable. - Widget::tkinclude Entry entry :cmd \ - remove { -state -background -foreground -textvariable - -disabledforeground -disabledbackground } + if {[Widget::theme]} { + Widget::tkinclude Entry ttk::entry :cmd \ + remove { -state -textvariable } + } else { + Widget::tkinclude Entry entry :cmd \ + remove { -state -background -foreground -textvariable + -disabledforeground -disabledbackground } + } set declare [list \ - [list -background TkResource "" 0 entry] \ - [list -foreground TkResource "" 0 entry] \ [list -state Enum normal 0 [list normal disabled]] \ [list -text String "" 0] \ [list -textvariable String "" 0] \ [list -editable Boolean 1 0] \ [list -command String "" 0] \ - [list -relief TkResource "" 0 entry] \ - [list -borderwidth TkResource "" 0 entry] \ - [list -fg Synonym -foreground] \ - [list -bg Synonym -background] \ - [list -bd Synonym -borderwidth] \ - ] - - if {![package vsatisfies [package provide Tk] 8.4]} { - ## If we're not running version 8.4 or higher, get our - ## disabled resources from the button widget. - lappend declare [list -disabledforeground TkResource "" 0 button] - lappend declare [list -disabledbackground TkResource "" 0 \ - {button -background}] - } else { - lappend declare [list -disabledforeground TkResource "" 0 entry] - lappend declare [list -disabledbackground TkResource "" 0 entry] + ] + if {![Widget::theme]} { + lappend declare \ + [list -background TkResource "" 0 entry] \ + [list -foreground TkResource "" 0 entry] \ + [list -relief TkResource "" 0 entry] \ + [list -borderwidth TkResource "" 0 entry] \ + [list -fg Synonym -foreground] \ + [list -bg Synonym -background] \ + [list -bd Synonym -borderwidth] + + if {![package vsatisfies [package provide Tk] 8.4]} { + ## If we're not running version 8.4 or higher, get our + ## disabled resources from the button widget. + lappend declare [list -disabledforeground TkResource "" 0 button] + lappend declare [list -disabledbackground TkResource "" 0 \ + {button -background}] + } else { + lappend declare [list -disabledforeground TkResource "" 0 entry] + lappend declare [list -disabledbackground TkResource "" 0 entry] + } } Widget::declare Entry $declare Widget::addmap Entry "" :cmd { -textvariable {} } @@ -62,13 +70,19 @@ FGCOLOR {move {}} BGCOLOR {move {}} COLOR {move {}} } - foreach event [bind Entry] { - bind BwEntry $event [bind Entry $event] - } + if {[Widget::theme]} { + foreach event [bind TEntry] { + bind BwEntry $event [bind TEntry $event] + } + } else { + foreach event [bind Entry] { + bind BwEntry $event [bind Entry $event] + } + } # Copy is kind of a special event. It should be enabled when the # widget is editable but not disabled, and not when the widget is disabled. # To make this a bit easier to manage, we will handle it separately. @@ -90,33 +104,51 @@ array set maps [list Entry {} :cmd {}] array set maps [Widget::parseArgs Entry $args] set data(afterid) "" - eval [list entry $path] $maps(:cmd) + if {[Widget::theme]} { + eval [list ttk::entry $path] $maps(:cmd) + } else { + eval [list entry $path] $maps(:cmd) + } Widget::initFromODB Entry $path $maps(Entry) set state [Widget::getMegawidgetOption $path -state] set editable [Widget::getMegawidgetOption $path -editable] set text [Widget::getMegawidgetOption $path -text] if { $editable && [string equal $state "normal"] } { bindtags $path [list $path BwEntry [winfo toplevel $path] all] - $path configure -takefocus 1 -insertontime 600 + if {[Widget::theme]} { + $path configure -takefocus 1 + } else { + $path configure -takefocus 1 -insertontime 600 + } } else { bindtags $path [list $path BwDisabledEntry [winfo toplevel $path] all] - $path configure -takefocus 0 -insertontime 0 + if {[Widget::theme]} { + $path configure -takefocus 0 + } else { + $path configure -takefocus 0 -insertontime 0 + } } if { $editable == 0 } { $path configure -cursor left_ptr } if { [string equal $state "disabled"] } { - $path configure \ - -foreground [Widget::getMegawidgetOption $path -disabledforeground] \ - -background [Widget::getMegawidgetOption $path -disabledbackground] + if {[Widget::theme]} { + $path state disabled + } else { + $path configure \ + -foreground [Widget::getMegawidgetOption $path -disabledforeground] \ + -background [Widget::getMegawidgetOption $path -disabledbackground] + } } else { - $path configure \ - -foreground [Widget::getMegawidgetOption $path -foreground] \ - -background [Widget::getMegawidgetOption $path -background] + if {![Widget::theme]} { + $path configure \ + -foreground [Widget::getMegawidgetOption $path -foreground] \ + -background [Widget::getMegawidgetOption $path -background] + } bindtags $path [linsert [bindtags $path] 2 BwEditableEntry] } if { [string length $text] } { set varName [$path cget -textvariable] if { ![string equal $varName ""] } { @@ -150,13 +182,18 @@ set Widget::Entry::${path}:opt(-text) [$path:cmd get] set res [Widget::configure $path $args] # Extract the modified bits that we are interested in. - set vars [list chstate cheditable chfg chdfg chbg chdbg chtext] - set opts [list -state -editable -foreground -disabledforeground \ - -background -disabledbackground -text] + if {[Widget::theme]} { + set vars [list chstate cheditable chtext] + set opts [list -state -editable -text] + } else { + set vars [list chstate cheditable chfg chdfg chbg chdbg chtext] + set opts [list -state -editable -foreground -disabledforeground \ + -background -disabledbackground -text] + } foreach $vars [eval [linsert $opts 0 Widget::hasChangedX $path]] { break } if { $chstate || $cheditable } { set state [Widget::getMegawidgetOption $path -state] set editable [Widget::getMegawidgetOption $path -editable] @@ -164,24 +201,40 @@ if { $editable && [string equal $state "normal"] } { set idx [lsearch $btags BwDisabledEntry] if { $idx != -1 } { bindtags $path [lreplace $btags $idx $idx BwEntry] } - $path:cmd configure -takefocus 1 -insertontime 600 + if {[Widget::theme]} { + $path:cmd configure -takefocus 1 + } else { + $path:cmd configure -takefocus 1 -insertontime 600 + } } else { set idx [lsearch $btags BwEntry] if { $idx != -1 } { bindtags $path [lreplace $btags $idx $idx BwDisabledEntry] } - $path:cmd configure -takefocus 0 -insertontime 0 + if {[Widget::theme]} { + $path:cmd configure -takefocus 0 + } else { + $path:cmd configure -takefocus 0 -insertontime 0 + } if { [string equal [focus] $path] } { focus . } } } - if { $chstate || $chfg || $chdfg || $chbg || $chdbg } { + if { [Widget::theme] && $chstate } { + set state [Widget::getMegawidgetOption $path -state] + if { [string equal $state "disabled"] } { + $path:cmd state disabled + } else { + $path:cmd state !disabled + } + } + if { ![Widget::theme] && ($chstate || $chfg || $chdfg || $chbg || $chdbg) } { set state [Widget::getMegawidgetOption $path -state] if { [string equal $state "disabled"] } { $path:cmd configure \ -fg [Widget::cget $path -disabledforeground] \ -bg [Widget::cget $path -disabledbackground] @@ -265,11 +318,11 @@ switch -exact -- $cmd { configure - cget - invoke { return [eval [linsert $larg 0 Entry::$cmd $path]] } default { - return [eval [linsert $larg 0 $path:cmd $cmd]] + return [uplevel 2 [linsert $larg 0 $path:cmd $cmd]] } } } Index: font.tcl ================================================================== --- font.tcl +++ font.tcl @@ -225,12 +225,16 @@ -highlightcolor black] set script "set [list SelectFont::${path}(fontcolor)] \[tk_chooseColor -parent $colf.button -initialcolor \[set [list SelectFont::${path}(fontcolor)]\]\];\ SelectFont::_update [list $path]" + set name [lindex [BWidget::getname colorPicker] 0] + if { $name == "" } { + set name "Color..." + } set but [button $colf.button -command $script \ - -text "Color..."] + -text $name] $lab configure -foreground $thecolor $frc configure -bg $thecolor pack $but -side left @@ -278,10 +282,11 @@ -values $_sizes \ -textvariable SelectFont::${path}(size) \ -state readonly] bind $lbf <> [list SelectFont::_update $path] bind $lbs <> [list SelectFont::_update $path] + ttk::style configure BWSlim.Toolbutton -padding 0 } else { frame $path -background $bg set lbf [ComboBox::create $path.font \ -highlightthickness 0 -takefocus 0 -background $bg \ -values $_families($fams) \ @@ -298,11 +303,11 @@ } bind $path [list SelectFont::_destroy $path] pack $lbf -side left -anchor w pack $lbs -side left -anchor w -padx 4 foreach st $_styles { - if {$::Widget::_theme} { + if {[Widget::theme]} { ttk::checkbutton $path.$st -takefocus 0 \ -style BWSlim.Toolbutton \ -image [Bitmap::get $st] \ -variable SelectFont::${path}($st) \ -command [list SelectFont::_update $path] Index: init.tcl ================================================================== --- init.tcl +++ init.tcl @@ -27,11 +27,26 @@ } } } Widget::_opt_defaults -option read [file join $::BWIDGET::LIBRARY "lang" "en.rc"] +# Try to load lang file corresponding to current msgcat locale +proc Widget::_opt_lang {} { + if {0 != [llength [info commands ::msgcat::mcpreferences]]} { + set langs [::msgcat::mcpreferences] + } + lappend langs en + + foreach lang $langs { + set l [file join $::BWIDGET::LIBRARY "lang" "$lang.rc"] + if {(![catch {file readable $l} result]) && ($result)} { + option read $l + break + } + } +} +Widget::_opt_lang ## Add a TraverseIn binding to standard Tk widgets to handle some of ## the BWidget-specific things we do. bind Entry <> { %W selection range 0 end; %W icursor end } bind Spinbox <> { %W selection range 0 end; %W icursor end } Index: label.tcl ================================================================== --- label.tcl +++ label.tcl @@ -1,9 +1,9 @@ # ------------------------------------------------------------------------------ # label.tcl # This file is part of Unifix BWidget Toolkit -# $Id: label.tcl,v 1.10 2003/10/20 21:23:52 damonc Exp $ +# $Id: label.tcl,v 1.10.2.3 2011/04/26 08:24:28 oehhar Exp $ # ------------------------------------------------------------------------------ # Index of commands: # - Label::create # - Label::configure # - Label::cget @@ -14,12 +14,17 @@ # ------------------------------------------------------------------------------ namespace eval Label { Widget::define Label label DragSite DropSite DynamicHelp - Widget::tkinclude Label label .l \ - remove { -foreground -text -textvariable -underline } + if {$::Widget::_theme} { + Widget::tkinclude Label label .l \ + remove { -foreground -text -textvariable -underline -state} + } else { + Widget::tkinclude Label label .l \ + remove { -foreground -text -textvariable -underline } + } Widget::declare Label { {-name String "" 0} {-text String "" 0} {-textvariable String "" 0} @@ -41,12 +46,10 @@ FGCOLOR {move {}} BGCOLOR {move {}} COLOR {move {}} } - Widget::syncoptions Label "" .l {-text {} -underline {}} - bind BwLabel [list Label::setfocus %W] bind BwLabel [list Label::_destroy %W] } @@ -54,25 +57,36 @@ # Command Label::create # ------------------------------------------------------------------------------ proc Label::create { path args } { array set maps [list Label {} .l {}] array set maps [Widget::parseArgs Label $args] - frame $path -class Label -borderwidth 0 -highlightthickness 0 -relief flat + frame $path -class Label -borderwidth 0 -highlightthickness 0 -relief flat -padx 0 -pady 0 Widget::initFromODB Label $path $maps(Label) - eval [list label $path.l] $maps(.l) + if {$::Widget::_theme} { + eval [list ttk::label $path.l] $maps(.l) + } else { + eval [list label $path.l] $maps(.l) + } - if { [Widget::cget $path -state] == "normal" } { - set fg [Widget::cget $path -foreground] + if {$::Widget::_theme} { + if { [Widget::cget $path -state] != "normal" } { + $path.l state disabled + } } else { - set fg [Widget::cget $path -disabledforeground] - } + if { [Widget::cget $path -state] == "normal" } { + set fg [Widget::cget $path -foreground] + } else { + set fg [Widget::cget $path -disabledforeground] + } + $path.l configure -foreground $fg + } set var [Widget::cget $path -textvariable] if { $var == "" && [Widget::cget $path -image] == "" && - [Widget::cget $path -bitmap] == ""} { + ($::Widget::_theme || [Widget::cget $path -bitmap] == "")} { set desc [BWidget::getname [Widget::cget $path -name]] if { $desc != "" } { set text [lindex $desc 0] set under [lindex $desc 1] } else { @@ -83,11 +97,11 @@ set under -1 set text "" } $path.l configure -text $text -textvariable $var \ - -underline $under -foreground $fg + -underline $under set accel [string tolower [string index $text $under]] if { $accel != "" } { bind [winfo toplevel $path] "Label::setfocus $path" } @@ -116,24 +130,42 @@ 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.l configure -fg $fg - } else { - $path.l configure -fg $dfg + if {$::Widget::_theme} { + if { $cfg } { + $path.l configure -foreground $fg + } + if { $cst } { + if { $state == "normal" } { + $path.l state !disabled + } else { + $path.l state disabled + } + } + } else { + set cdfg [Widget::hasChanged $path -disabledforeground dfg] + if { $cst || $cfg || $cdfg } { + if { $state == "normal" } { + $path.l configure -fg $fg + } else { + $path.l configure -fg $dfg + } } - } + } set cv [Widget::hasChanged $path -textvariable var] set cb [Widget::hasChanged $path -image img] - set ci [Widget::hasChanged $path -bitmap bmp] + if {$::Widget::_theme} { + set ci 0 + set bmp "" + } else { + 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 } { @@ -172,10 +204,34 @@ # ------------------------------------------------------------------------------ proc Label::cget { path option } { return [Widget::cget $path $option] } + +# ---------------------------------------------------------------------------- +# Command Label::identify +# ---------------------------------------------------------------------------- +proc Label::identify { path args } { + eval $path.l identify $args +} + + +# ---------------------------------------------------------------------------- +# Command Label::instate +# ---------------------------------------------------------------------------- +proc Label::instate { path args } { + eval $path.l instate $args +} + + +# ---------------------------------------------------------------------------- +# Command Label::state +# ---------------------------------------------------------------------------- +proc Label::state { path args } { + eval $path.l state $args +} + # ------------------------------------------------------------------------------ # Command Label::setfocus # ------------------------------------------------------------------------------ proc Label::setfocus { path } { Index: labelentry.tcl ================================================================== --- labelentry.tcl +++ labelentry.tcl @@ -1,9 +1,9 @@ # ------------------------------------------------------------------------------ # labelentry.tcl # This file is part of Unifix BWidget Toolkit -# $Id: labelentry.tcl,v 1.6 2003/10/20 21:23:52 damonc Exp $ +# $Id: labelentry.tcl,v 1.6.2.1 2011/02/14 16:56:09 oehhar Exp $ # ------------------------------------------------------------------------------ # Index of commands: # - LabelEntry::create # - LabelEntry::configure # - LabelEntry::cget @@ -22,13 +22,10 @@ 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 [list focus %W.labf] ::bind BwLabelEntry [list LabelEntry::_destroy %W] } @@ -37,12 +34,17 @@ # ------------------------------------------------------------------------------ proc LabelEntry::create { path args } { array set maps [list LabelEntry {} :cmd {} .labf {} .e {}] array set maps [Widget::parseArgs LabelEntry $args] - eval [list frame $path] $maps(:cmd) -class LabelEntry \ - -relief flat -bd 0 -highlightthickness 0 -takefocus 0 + if {[Widget::theme]} { + eval [list ttk::frame $path] $maps(:cmd) -class LabelEntry \ + -takefocus 0 + } else { + eval [list frame $path] $maps(:cmd) -class LabelEntry \ + -relief flat -bd 0 -highlightthickness 0 -takefocus 0 + } Widget::initFromODB LabelEntry $path $maps(LabelEntry) set labf [eval [list LabelFrame::create $path.labf] $maps(.labf) \ [list -relief flat -borderwidth 0 -focus $path.e]] set subf [LabelFrame::getframe $labf] @@ -51,11 +53,14 @@ pack $entry -in $subf -fill both -expand yes pack $labf -fill both -expand yes bindtags $path [list $path BwLabelEntry [winfo toplevel $path] all] - return [Widget::create LabelEntry $path] + Widget::create LabelEntry $path + proc ::$path { cmd args } \ + "return \[LabelEntry::_path_command [list $path] \$cmd \$args\]" + return $path } # ------------------------------------------------------------------------------ # Command LabelEntry::configure Index: labelframe.tcl ================================================================== --- labelframe.tcl +++ labelframe.tcl @@ -1,9 +1,9 @@ # ------------------------------------------------------------------------------ # labelframe.tcl # This file is part of Unifix BWidget Toolkit -# $Id: labelframe.tcl,v 1.6 2003/10/20 21:23:52 damonc Exp $ +# $Id: labelframe.tcl,v 1.6.2.1 2011/02/14 16:56:09 oehhar Exp $ # ------------------------------------------------------------------------------ # Index of commands: # - LabelFrame::create # - LabelFrame::getframe # - LabelFrame::configure @@ -31,12 +31,10 @@ } Widget::addmap LabelFrame "" :cmd {-background {}} Widget::addmap LabelFrame "" .f {-background {} -relief {} -borderwidth {}} - Widget::syncoptions LabelFrame Label .l {-text {} -underline {}} - bind BwLabelFrame [list Label::setfocus %W.l] bind BwLabelFrame [list LabelFrame::_destroy %W] } @@ -44,19 +42,29 @@ # Command LabelFrame::create # ---------------------------------------------------------------------------- proc LabelFrame::create { path args } { Widget::init LabelFrame $path $args - set path [eval [list frame $path] [Widget::subcget $path :cmd] \ - -relief flat -bd 0 -takefocus 0 -highlightthickness 0 \ - -class LabelFrame] + if {[Widget::theme]} { + set path [eval [list ttk::frame $path] [Widget::subcget $path :cmd] \ + -takefocus 0 \ + -class LabelFrame] + } else { + set path [eval [list frame $path] [Widget::subcget $path :cmd] \ + -relief flat -bd 0 -takefocus 0 -highlightthickness 0 \ + -class LabelFrame] + } set label [eval [list Label::create $path.l] [Widget::subcget $path .l] \ - -takefocus 0 -highlightthickness 0 -relief flat \ - -borderwidth 0 -dropenabled 0 -dragenabled 0] - set frame [eval [list frame $path.f] [Widget::subcget $path .f] \ - -highlightthickness 0 -takefocus 0] + -takefocus 0 -dropenabled 0 -dragenabled 0] + if {[Widget::theme]} { + set frame [eval [list ttk::frame $path.f] [Widget::subcget $path .f] \ + -takefocus 0] + } else { + set frame [eval [list 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"} Index: lang/da.rc ================================================================== --- lang/da.rc +++ lang/da.rc @@ -5,28 +5,30 @@ ! ----------------------------------------------------------------------------- ! --- symbolic names of buttons ----------------------------------------------- -*abortName: &Annullér -*retryName: P&røv igen +*abortName: &Annullér +*retryName: P&røv igen *ignoreName: &Ignorer *okName: &OK *cancelName: &Cancel *yesName: &Ja *noName: &Nej ! --- symbolic names of label of SelectFont dialog ---------------------------- -*boldName: Fed -*italicName: Kursiv -*underlineName: Understreg -*overstrikeName: Overstreg -*fontName: &Font -*sizeName: &Størrelse -*styleName: St&il +*boldName: Fed +*italicName: Kursiv +*underlineName: Understreg +*overstrikeName: Overstreg +*fontName: &Font +*sizeName: &Størrelse +*styleName: St&il +*colorPickerName: F&arve... + ! --- symbolic names of label of PasswdDlg dialog ----------------------------- *loginName: &Brugernavn *passwordName: &Password @@ -33,20 +35,33 @@ ! --- resource for SelectFont dialog ------------------------------------------ *SelectFont.title: Font-valg -*SelectFont.sampletext: Eksempeltekst æøå +*SelectFont.sampletext: Eksempeltekst æøå ! --- resource for MessageDlg dialog ------------------------------------------ *MessageDlg.noneTitle: Besked *MessageDlg.infoTitle: Information -*MessageDlg.questionTitle: Spørgsmål +*MessageDlg.questionTitle: SpørgsmÃ¥l *MessageDlg.warningTitle: Advarsel *MessageDlg.errorTitle: Fejl - ! --- resource for PasswdDlg dialog ------------------------------------------- *PasswdDlg.title: Indtast brugernavn og password + +! --- symbolic names of label of SelectColor dialog ---------------------------- + +*baseColorsName: Grundfarver +*userColorsName: Brugerdefinerede farver + +*yourSelectionName: Dit valg +*colorSelectorsName: Farvervælger + +! --- dynamic help text for SelectColor dialog. Lines 75 chars max, split by '\n'. + +*mouseHelpTextName: Klik eller træk musen i farvervælgeren for at vælge en farve.\nHvis den valgte farve altid er sort, uanset værdierne til venstre,\ntjek intensitetsværdien til højere.\n\nKlik en af "grundfarverne" for at aflæse værdierne fra paletten,\neller for at tildele en, hvis farven er sort. Hvis du efterfølgende\nbruger farvevælgeren til at ændre en farver, gemmes ændringen under\nbrugerdefinerede farver indtil en ny paletfarve er valgt. + +*keyboardHelpTextName: Klik i tekstboksen til venstre i "dit valg" omrÃ¥det.\n\nIndtast den ønskede farve i hexadecimalt RGB-format.\nVærdien er gyldig nÃ¥r den bestÃ¥r af et antal cifre deleligt med 3,\ni sÃ¥ fald opdateres resten af farvervælgeren.\n\nForlad tekstboksen ved at klikke andetsteds, eller ved at taste\n"Escape" eller "Return". Tekstboksen viser efterfølgende farven i\n24-bit RGB-format, dog arbejder farvevælgeren internt med\n48-bit værdier.\n\nNÃ¥r tekstboksen ikke har fokus fungerer "Return" og "Escape"\ntasterne lige som henholdsvis "OK" og "Annullér". Index: lang/de.rc ================================================================== --- lang/de.rc +++ lang/de.rc @@ -16,17 +16,18 @@ *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 +*boldName: Fett +*italicName: Kursiv +*underlineName: Unterstrichen +*overstrikeName: Durchgestrichen +*fontName: &Schriftart +*sizeName: S&chriftgrad +*styleName: Sc&hriftschnitt +*colorPickerName: &Farbe... ! --- symbolic names of label of PasswdDlg dialog ----------------------------- *loginName: &Login *passwordName: &Password @@ -48,5 +49,19 @@ ! --- resource for PasswdDlg dialog ------------------------------------------- *PasswdDlg.title: Enter login and password + +! --- symbolic names of label of SelectColor dialog ---------------------------- + +*baseColorsName: Grundfarben +*userColorsName: Benutzerdefinierte Farben + +*yourSelectionName: Gewählte Farbe +*colorSelectorsName: Farbraum + +! --- dynamic help text for SelectColor dialog. Lines 75 chars max, split by '\n'. + +*mouseHelpTextName: Um eine Farbe zu wählen bitte im Farbraum und im Helligkeitsregler\nklicken oder ziehen. Bleibt die gewählte Farbe wieder erwarten schwarz,\nso muß die Helligkeit ganz rechts erhöht werden.\n\nMit einem Klick auf die Grundfarbenpalette kann diese gewählt werden.\n\nEin benutzerdefinierter Farbspeicher kann durch einen Klick selektiert\nwerden. Ab dann wird jede Farbveränderung auch in den Farbspeicher\n geschrieben. + +*keyboardHelpTextName: Aktivieren sie das Texteingabefenster mit einem Klick oder mit der\nTabulatortaste. Eine Farbe kann als RGB-Wert eingegeben mit 3 oder 6\nhexadezimalen Ziffern eingegeben werden.\n\nDie Eingabe kann mit der Escape- oder Eingabetaste abgeschlossen werden.\n\nAusserhalb des Eingabefensters wird der Dialog mit der Eingabetaste\nbestätigt und mit der Escapetaste zurückgenommen. Index: lang/en.rc ================================================================== --- lang/en.rc +++ lang/en.rc @@ -16,17 +16,18 @@ *noName: &No ! --- symbolic names of label of SelectFont dialog ---------------------------- -*boldName: Bold -*italicName: Italic -*underlineName: Underline -*overstrikeName: Overstrike -*fontName: &Font -*sizeName: &Size -*styleName: St&yle +*boldName: Bold +*italicName: Italic +*underlineName: Underline +*overstrikeName: Overstrike +*fontName: &Font +*sizeName: &Size +*styleName: St&yle +*colorPickerName: &Color... ! --- symbolic names of label of PasswdDlg dialog ----------------------------- *loginName: &Login @@ -48,5 +49,19 @@ *MessageDlg.errorTitle: Error ! --- resource for PasswdDlg dialog ------------------------------------------- *PasswdDlg.title: Enter login and password + +! --- symbolic names of label of SelectColor dialog ---------------------------- + +*baseColorsName: Base colors +*userColorsName: User colors + +*yourSelectionName: Your Selection +*colorSelectorsName: Color Selectors + +! --- dynamic help text for SelectColor dialog. Lines 75 chars max, split by '\n'. + +*mouseHelpTextName: Click or drag the mouse in the Color Selectors to choose a color.\nIf the selected color remains black, regardless of what you\ndo in the left-hand Color Selector (for hue and saturation), check\nthe position of the pointer in the right-hand Color Selector\n(for brightness).\n\nClick one of the "Base colors" to read a value from this palette.\n\nClick one of the "User colors" to read a value from this palette,\nor to write to the palette if the color is blank. If you then\nuse the Color Selectors to change the color, your choice will be\nwritten to this (User) palette color until you select another\n(Base or User) palette color. + +*keyboardHelpTextName: Click in the text entry window in the left of the "Your\nSelection" area.\n\nType the color that you want in hexadecimal RGB format.\nWhenever the number of hexadecimal digits is a multiple\nof 3, the color value is valid and will be copied to the\nother parts of the Color Selector.\n\nLeave the text entry window by clicking anywhere else,\nor by pressing the "Escape" or "Return" key. The text\nentry window will then display the color in 24-bit RGB\nformat, although internally the Color Selector uses\n48-bit colors.\n\nWhen the text entry widget does not have keyboard focus\n(i.e. does not show a cursor), the "Return" and "Escape"\nkeys do the same as the "OK" and "Cancel" buttons,\nrespectively. Index: lang/es.rc ================================================================== --- lang/es.rc +++ lang/es.rc @@ -1,53 +1,69 @@ ! ------------------------------------------------------------------------------ ! es.rc ! This file is part of Unifix BWidget Toolkit ! Definition of spanish resources -! daniel@rawbyte.com +! daniel@rawbyte.com, jima, neko ! ------------------------------------------------------------------------------ ! --- symbolic names of buttons ------------------------------------------------ -*abortName: A&bortar +*abortName: &Abortar *retryName: &Reintentar *ignoreName: &Ignorar *okName: &OK -*cancelName: &Anular -*yesName: &Sí +*cancelName: &Cancelar +*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 +*boldName: Negrita +*italicName: Cursiva +*underlineName: Subrayado +*overstrikeName: Tachado +*fontName: &Fuente +*sizeName: &Tamaño +*styleName: &Estilo +*colorPickerName: &Color... ! --- symbolic names of label of PasswdDlg dialog ----------------------------- -*loginName: Nombre de &usuario -*passwordName: &Contraseña +*loginName: &Usuario +*passwordName: &Contraseña + ! --- resource for SelectFont dialog ------------------------------------------ -*SelectFont.title: Selección de fuente +*SelectFont.title: Selección de fuente *SelectFont.sampletext: Texto de Ejemplo ! --- resource for MessageDlg dialog ------------------------------------------ -*MessageDlg.noneTitle: Indicación -*MessageDlg.infoTitle: Información +*MessageDlg.noneTitle: Mensaje +*MessageDlg.infoTitle: Información *MessageDlg.questionTitle: Pregunta -*MessageDlg.warningTitle: Atención +*MessageDlg.warningTitle: Aviso *MessageDlg.errorTitle: Error - ! --- resource for PasswdDlg dialog ------------------------------------------- -*PasswdDlg.title: Introduzca su nombre de usuario y contraseña +*PasswdDlg.title: Introduzca su usuario y contraseña + +! --- symbolic names of label of SelectColor dialog ---------------------------- + +*baseColorsName: Colores base +*userColorsName: Colores de usuario + +*yourSelectionName: Su selección +*colorSelectorsName: Selectores de color + + +! --- dynamic help text for SelectColor dialog. Lines 75 chars max, split by '\n'. + +*mouseHelpTextName: Haga click o arrastre el ratón en los selectores de color para elegir un color.\nSi el color seleccionado permanece negro, sin importar lo que haga en el selector de\ncolor izquierdo (para tono y saturación), compruebe la posición del puntero en el selector\nde color derecho (para brillo).\n\nHaga click en uno de los "Colores base" para leer un valor de esa paleta.\n\nClick en uno de los "Colores de usuario" para leer un valor de esa paleta, o para escribir\nla paleta si el color está vacio. Si luego usted usa los Selectores de color para cambiar\nel color, su elección se escribirá en ese color de la paleta (de usuario) hasta seleccionar\notro color de la paleta (base o de usuario). +*keyboardHelpTextName: Haga click en la ventana de entrada de texto a la izquierda del área "Su\nSelección".\n\nTeclee el color que desee en formato RGB hexadecimal. Siempre que el número de dígitos\nhexadecimales sea múltiplo de 3, el valor de color es válido y se copiará a las\notras partes del Selector de Color.\n\nSalga de la ventana de entrada de texto haciendo click en otro lugar, o presionando la\ntecla "Escape" o "Enter". La ventana de entrada de texto mostrará entonces el color en\nformato RGB 24-bit, aunque internamente el Selector de Color usa colores de 48-bit.\n\nCuando el control de entrada de texto no tenga el foco de teclado (ej, no muestra un\ncursor), las teclas "Enter" y "Escape" hacen lo mismo que los botones "OK" y "Cancel",\nrespectivamente. Index: lang/fr.rc ================================================================== --- lang/fr.rc +++ lang/fr.rc @@ -6,26 +6,28 @@ ! --- symbolic names of buttons ------------------------------------------------ *abortName: A&bandonner -*retryName: &Réessayer +*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 +*boldName: &Gras +*italicName: &Italique +*underlineName: &Souligné +*overstrikeName: &Barré +*fontName: &Police +*sizeName: &Taille +*styleName: St&yle +*colorPickerName: &Couleur... ! --- symbolic names of label of PasswdDlg dialog ----------------------------- *loginName: Nom de l'&utilisateur @@ -32,11 +34,11 @@ *passwordName: Mot de &passe ! --- resource for SelectFont dialog ------------------------------------------ -*SelectFont.title: Sélection d'une police +*SelectFont.title: Sélection d'une police *SelectFont.sampletext: Texte d'exemple ! --- resource for MessageDlg dialog ------------------------------------------ @@ -44,9 +46,24 @@ *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 + +! --- symbolic names of label of SelectColor dialog ---------------------------- + +*baseColorsName: Couleurs de base +*userColorsName: Couleurs utilisateur + +*yourSelectionName: Votre sélection +*colorSelectorsName: Sélecteur de couleurs + +! --- dynamic help text for SelectColor dialog. Lines 75 chars max, split by '\n'. + + +*mouseHelpTextName: Cliquez ou déplacez la souris dans la palette pour choisir une couleur.\nSi la couleur affichée reste noire quelle que soit la sélection dans la palette (teinte et\nsaturation), vérifiez la position du pointeur dans le sélecteur de droite (luminosité).\n\nCliquez sur l'une des "Couleurs de base" pour la sélectionner.\n\nCliquez sur l'une des "Couleurs utilisateurs" pour la sélectionner, ou pour la\nsauver dans la palette utilisateur dans une case blanche. Les modifications via le\nsélecteur de couleurs sont alors propagées dans la case sélectionnée de la palette\nutilisateur jusqu'à ce qu'une autre couleur (de base ou utilisateur) soit sélectionnée. + +*keyboardHelpTextName: Cliquez dans la zone de saisie à gauche, dans la zone "Votre sélection".\n\nEntrez la couleur désirée au format RGB hexadécimal.\nLa valeur est validée lorsque le nombre de chiffres hexadécimaux est un multiple de 3.\nElle est alors propagée aux autres zones du sélecteur de couleurs.\n\nLa zone de saisie peut être quittée en cliquant n'importe où ailleurs ou en appuyant sur la\ntouche "Escape" ou "Entrée" du clavier. Bien que le sélecteur de couleurs utilise\n48 bits en interne, la zone de saisie affichera alors la couleur au format RGB en\nhexadécimal sur 24 bits.\n\nLorsque la zone de saisie n'a pas le focus (i.e. ne montre pas le curseur), les touches\n"Entrée" et "Escape" ont la même fonction que les boutons "OK" et "Annuler" respectivement. + Index: lang/hu.rc ================================================================== --- lang/hu.rc +++ lang/hu.rc @@ -23,10 +23,11 @@ *underlineName: Aláhúzott *overstrikeName: Felülírás *fontName: &Betűtípus *sizeName: &Méret *styleName: S&tílus +*colorPickerName: &Szín... ! --- symbolic names of label of PasswdDlg dialog ----------------------------- *loginName: &Felhasználónév @@ -48,5 +49,19 @@ *MessageDlg.errorTitle: Hiba ! --- resource for PasswdDlg dialog ------------------------------------------- *PasswdDlg.title: Add meg a felhasználónevet és a jelszót + +! --- symbolic names of label of SelectColor dialog ---------------------------- + +*baseColorsName: Alapszínek +*userColorsName: Felhasználói színek + +*yourSelectionName: Your Selection +*colorSelectorsName: Color Selectors + +! --- dynamic help text for SelectColor dialog. Lines 75 chars max, split by '\n'. + +*mouseHelpTextName: Click or drag the mouse in the Color Selectors to choose a color.\nIf the selected color remains black, regardless of what you\ndo in the left-hand Color Selector (for hue and saturation), check\nthe position of the pointer in the right-hand Color Selector\n(for brightness).\n\nClick one of the "Base colors" to read a value from this palette.\n\nClick one of the "User colors" to read a value from this palette,\nor to write to the palette if the color is blank. If you then\nuse the Color Selectors to change the color, your choice will be\nwritten to this (User) palette color until you select another\n(Base or User) palette color. + +*keyboardHelpTextName: Click in the text entry window in the left of the "Your\nSelection" area.\n\nType the color that you want in hexadecimal RGB format.\nWhenever the number of hexadecimal digits is a multiple\nof 3, the color value is valid and will be copied to the\nother parts of the Color Selector.\n\nLeave the text entry window by clicking anywhere else,\nor by pressing the "Escape" or "Return" key. The text\nentry window will then display the color in 24-bit RGB\nformat, although internally the Color Selector uses\n48-bit colors.\n\nWhen the text entry widget does not have keyboard focus\n(i.e. does not show a cursor), the "Return" and "Escape"\nkeys do the same as the "OK" and "Cancel" buttons,\nrespectively. Index: lang/nl.rc ================================================================== --- lang/nl.rc +++ lang/nl.rc @@ -16,17 +16,18 @@ *noName: &Nee ! --- symbolic names of label of SelectFont dialog ---------------------------- -*boldName: Vet -*italicName: Cursief -*underlineName: Onderstrepen -*overstrikeName: Doorhalen -*fontName: &Lettertype -*sizeName: &Grootte -*styleName: &Stijl +*boldName: Vet +*italicName: Cursief +*underlineName: Onderstrepen +*overstrikeName: Doorhalen +*fontName: &Lettertype +*sizeName: &Grootte +*styleName: &Stijl +*colorPickerName: &Kleur... ! --- symbolic names of label of PasswdDlg dialog ----------------------------- *loginName: &Inlognaam @@ -48,5 +49,19 @@ *MessageDlg.errorTitle: Fout ! --- resource for PasswdDlg dialog ------------------------------------------- *PasswdDlg.title: Voer inlognaam en wachtwoord in + +! --- symbolic names of label of SelectColor dialog ---------------------------- + +*baseColorsName: Basiskleuren +*userColorsName: Aangepaste kleuren + +*yourSelectionName: Uw selectie +*colorSelectorsName: Selecteren kleuren + +! --- dynamic help text for SelectColor dialog. Lines 75 chars max, split by '\n'. + +*mouseHelpTextName: Klik of sleep de muis in de kleurselectors om een kleur te kiezen.\nAls de geselecteerde kleur zwart blijft, ongeacht wat je doet in het\nlinkerdeel (tint en verzadiging), controleer de positie van de muispointer\nin het rechterdeel (helderheid).\n\nKlik op een van de basiskleuren om een waarde uit dit palet te lezen.\n\nKlik op een van de basiskleuren om een waarde uit dit palet te lezen of\nom een nieuwe waarde in te voeren als het vakje leeg is. Als je dan de\nkleurselectors gebruikt om de kleur te wijzigen, dan wordt die nieuwe\nkeuze naar het aanpasbare kleurvakje geschreven tot je een andere\nbasiskleur of aanpasbare kleur kiest. + +*keyboardHelpTextName: Klik in het invoerveld links van het deel "Uw selectie".\nTyp de gewenste kleur in volgens het hexadecimale RGB-format.\nDe kleurwaarde is acceptabel als het aantal hexadecimale cijfers een\nveelvoud is van 3. De waarde wordt gekopieerd naar andere delen van de\nkleurselector.\n\nVerlaat het invoerveld door ergens anders te klikken of via "Escape" of\n"Return". Het invoerveld toont dan de kleur in 24-bits RGB-format\n(overigens wordt intern een 48-bits RGB-format gebruikt).\n\nAls het invoerveld niet de focus heeft (geen tekstcursor vertoont), dan\nwerken de "Return"- en "Escape"-toetsen net als de "OK"- en\n"Cancel"-buttons. Index: lang/no.rc ================================================================== --- lang/no.rc +++ lang/no.rc @@ -1,52 +1,67 @@ -! ------------------------------------------------------------------------------ -! no.rc -! This file is part of Unifix BWidget Toolkit -! Definition of norwegian resources -! ------------------------------------------------------------------------------ - - -! --- symbolic names of buttons ------------------------------------------------ - -*abortName: &Om -*retryName: &Prøv igjen -*ignoreName: &Ignore -*okName: &OK -*cancelName: &Avbryt -*yesName: &Ja -*noName: &Nei - - -! --- symbolic names of label of SelectFont dialog ---------------------------- - -*boldName: Halvfet -*italicName: Kursiv -*underlineName: Understreking -*overstrikeName: Overstryke -*fontName: &Skrift -*sizeName: &Størrelse -*styleName: St&il - - -! --- symbolic names of label of PasswdDlg dialog ----------------------------- - -*loginName: &Logg inn -*passwordName: &Passord - - -! --- resource for SelectFont dialog ------------------------------------------ - -*SelectFont.title: Skriftvalg -*SelectFont.sampletext: Prøve tekst - - -! --- resource for MessageDlg dialog ------------------------------------------ - -*MessageDlg.noneTitle: Melding -*MessageDlg.infoTitle: Informasjon -*MessageDlg.questionTitle: Spørsmål -*MessageDlg.warningTitle: Advarsel -*MessageDlg.errorTitle: Feil - -! --- resource for PasswdDlg dialog ------------------------------------------- - -*PasswdDlg.title: Skriv inn logginn og passord +! ------------------------------------------------------------------------------ +! no.rc +! This file is part of Unifix BWidget Toolkit +! Definition of norwegian resources +! ------------------------------------------------------------------------------ + + +! --- symbolic names of buttons ------------------------------------------------ + +*abortName: &Om +*retryName: &Prøv igjen +*ignoreName: &Ignore +*okName: &OK +*cancelName: &Avbryt +*yesName: &Ja +*noName: &Nei + + +! --- symbolic names of label of SelectFont dialog ---------------------------- + +*boldName: Halvfet +*italicName: Kursiv +*underlineName: Understreking +*overstrikeName: Overstryke +*fontName: &Skrift +*sizeName: &Størrelse +*styleName: St&il +*colorPickerName: &Color... + + +! --- symbolic names of label of PasswdDlg dialog ----------------------------- + +*loginName: &Logg inn +*passwordName: &Passord + + +! --- resource for SelectFont dialog ------------------------------------------ + +*SelectFont.title: Skriftvalg +*SelectFont.sampletext: Prøve tekst + + +! --- resource for MessageDlg dialog ------------------------------------------ + +*MessageDlg.noneTitle: Melding +*MessageDlg.infoTitle: Informasjon +*MessageDlg.questionTitle: SpørsmÃ¥l +*MessageDlg.warningTitle: Advarsel +*MessageDlg.errorTitle: Feil + +! --- resource for PasswdDlg dialog ------------------------------------------- + +*PasswdDlg.title: Skriv inn logginn og passord + +! --- symbolic names of label of SelectColor dialog ---------------------------- + +*baseColorsName: Base colors +*userColorsName: User colors + +*yourSelectionName: Your Selection +*colorSelectorsName: Color Selectors + +! --- dynamic help text for SelectColor dialog. Lines 75 chars max, split by '\n'. + +*mouseHelpTextName: Click or drag the mouse in the Color Selectors to choose a color.\nIf the selected color remains black, regardless of what you\ndo in the left-hand Color Selector (for hue and saturation), check\nthe position of the pointer in the right-hand Color Selector\n(for brightness).\n\nClick one of the "Base colors" to read a value from this palette.\n\nClick one of the "User colors" to read a value from this palette,\nor to write to the palette if the color is blank. If you then\nuse the Color Selectors to change the color, your choice will be\nwritten to this (User) palette color until you select another\n(Base or User) palette color. + +*keyboardHelpTextName: Click in the text entry window in the left of the "Your\nSelection" area.\n\nType the color that you want in hexadecimal RGB format.\nWhenever the number of hexadecimal digits is a multiple\nof 3, the color value is valid and will be copied to the\nother parts of the Color Selector.\n\nLeave the text entry window by clicking anywhere else,\nor by pressing the "Escape" or "Return" key. The text\nentry window will then display the color in 24-bit RGB\nformat, although internally the Color Selector uses\n48-bit colors.\n\nWhen the text entry widget does not have keyboard focus\n(i.e. does not show a cursor), the "Return" and "Escape"\nkeys do the same as the "OK" and "Cancel" buttons,\nrespectively. ADDED lang/pl.rc Index: lang/pl.rc ================================================================== --- /dev/null +++ lang/pl.rc @@ -0,0 +1,67 @@ +! ------------------------------------------------------------------------------ +! pl.rc +! This file is part of Unifix BWidget Toolkit +! Definition of english resources +! ------------------------------------------------------------------------------ + + +! --- symbolic names of buttons ------------------------------------------------ + +*abortName: &Porzuć +*retryName: P&onów +*ignoreName: &Ignoruj +*okName: &OK +*cancelName: &Anyluj +*yesName: &Tak +*noName: &Nie + + +! --- symbolic names of label of SelectFont dialog ---------------------------- + +*boldName: Pogrubiona +*italicName: Kursywa +*underlineName: PodkreÅ›lenie +*overstrikeName: PrzekreÅ›lenie +*fontName: &Czcionka: +*sizeName: &Rozmiar: +*styleName: St&yl czcionki: +*colorPickerName: &Kolor... + + +! --- symbolic names of label of PasswdDlg dialog ----------------------------- + +*loginName: &Login +*passwordName: &HasÅ‚o + + +! --- resource for SelectFont dialog ------------------------------------------ + +*SelectFont.title: Wybór czcionki +*SelectFont.sampletext: PrzykÅ‚adowy tekst + + +! --- resource for MessageDlg dialog ------------------------------------------ + +*MessageDlg.noneTitle: Wiadomość +*MessageDlg.infoTitle: Informacja +*MessageDlg.questionTitle: Pytanie +*MessageDlg.warningTitle: Ostrzeżenie +*MessageDlg.errorTitle: BÅ‚Ä…d + +! --- resource for PasswdDlg dialog ------------------------------------------- + +*PasswdDlg.title: Wpisz login i hasÅ‚o + +! --- symbolic names of label of SelectColor dialog ---------------------------- + +*baseColorsName: Kolory podstawowe +*userColorsName: Kolory niestandardowe + +*yourSelectionName: Your Selection +*colorSelectorsName: Color Selectors + +! --- dynamic help text for SelectColor dialog. Lines 75 chars max, split by '\n'. + +*mouseHelpTextName: Click or drag the mouse in the Color Selectors to choose a color.\nIf the selected color remains black, regardless of what you\ndo in the left-hand Color Selector (for hue and saturation), check\nthe position of the pointer in the right-hand Color Selector\n(for brightness).\n\nClick one of the "Base colors" to read a value from this palette.\n\nClick one of the "User colors" to read a value from this palette,\nor to write to the palette if the color is blank. If you then\nuse the Color Selectors to change the color, your choice will be\nwritten to this (User) palette color until you select another\n(Base or User) palette color. + +*keyboardHelpTextName: Click in the text entry window in the left of the "Your\nSelection" area.\n\nType the color that you want in hexadecimal RGB format.\nWhenever the number of hexadecimal digits is a multiple\nof 3, the color value is valid and will be copied to the\nother parts of the Color Selector.\n\nLeave the text entry window by clicking anywhere else,\nor by pressing the "Escape" or "Return" key. The text\nentry window will then display the color in 24-bit RGB\nformat, although internally the Color Selector uses\n48-bit colors.\n\nWhen the text entry widget does not have keyboard focus\n(i.e. does not show a cursor), the "Return" and "Escape"\nkeys do the same as the "OK" and "Cancel" buttons,\nrespectively. Index: listbox.tcl ================================================================== --- listbox.tcl +++ listbox.tcl @@ -1,9 +1,9 @@ # ---------------------------------------------------------------------------- # listbox.tcl # This file is part of Unifix BWidget Toolkit -# $Id: listbox.tcl,v 1.29 2009/06/30 16:17:37 oehhar Exp $ +# $Id: listbox.tcl,v 1.29.2.7 2012/04/12 12:46:47 oehhar Exp $ # ---------------------------------------------------------------------------- # Index of commands: # - ListBox::create # - ListBox::configure # - ListBox::cget @@ -25,10 +25,11 @@ # - ListBox::xview # - ListBox::yview # - ListBox::_update_edit_size # - ListBox::_destroy # - ListBox::_see +# - ListBox::_see_item # - ListBox::_update_scrollregion # - ListBox::_draw_item # - ListBox::_redraw_items # - ListBox::_redraw_selection # - ListBox::_redraw_listbox @@ -128,10 +129,11 @@ # widget informations set data(nrows) -1 # items informations set data(items) {} + set data(seeitem) {} set data(selitems) {} # update informations set data(upd,level) 0 set data(upd,afterid) "" @@ -188,41 +190,41 @@ # Configure the selectmode proc ListBox::_configureSelectmode { path selectmode {previous none} } { # clear current binding switch -exact -- $previous { single { - $path bindText "" - $path bindImage "" + $path _bindText "" + $path _bindImage "" } multiple { - $path bindText "" - $path bindText "" - $path bindText "" + $path _bindText "" + $path _bindText "" + $path _bindText "" - $path bindImage "" - $path bindImage "" - $path bindImage "" + $path _bindImage "" + $path _bindImage "" + $path _bindImage "" } } # set new bindings switch -exact -- $selectmode { single { - $path bindText [list ListBox::_mouse_select $path set] - $path bindImage [list ListBox::_mouse_select $path set] + $path _bindText [list ListBox::_mouse_select $path set] + $path _bindImage [list ListBox::_mouse_select $path set] if {1 < [llength [ListBox::selection $path get]]} { ListBox::selection $path clear } } multiple { set cmd ListBox::_multiple_select - $path bindText [list $cmd $path n %x %y] - $path bindText [list $cmd $path s %x %y] - $path bindText [list $cmd $path c %x %y] + $path _bindText [list $cmd $path n %x %y] + $path _bindText [list $cmd $path s %x %y] + $path _bindText [list $cmd $path c %x %y] - $path bindImage [list $cmd $path n %x %y] - $path bindImage [list $cmd $path s %x %y] - $path bindImage [list $cmd $path c %x %y] + $path _bindImage [list $cmd $path n %x %y] + $path _bindImage [list $cmd $path s %x %y] + $path _bindImage [list $cmd $path c %x %y] } default { if {0 < [llength [ListBox::selection $path get]]} { ListBox::selection $path clear } @@ -238,21 +240,24 @@ if { [Widget::hasChanged $path -selectmode selectmode] } { _configureSelectmode $path $selectmode $selectmodePrevious } - set ch1 [expr {[Widget::hasChanged $path -deltay dy] | + set ch0 [expr {[Widget::hasChanged $path -deltay dy]}] + set ch1 [expr {$ch0 | [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] } { + if { [Widget::hasChanged $path -height h] || $ch0 } { $path.c configure -height [expr {$h*$dy}] - set redraw 1 + if {!$ch0} { + set redraw 1 + } } if { [Widget::hasChanged $path -width w] } { $path.c configure -width [expr {$w*8}] set redraw 1 } @@ -417,11 +422,11 @@ if { [string equal $type "img"] } { $path.c itemconfigure $idi -image $img } else { $path.c delete $idi $path.c create image $x0 $y0 -image $img -anchor w \ - -tags [list img i:$item] + -tags [list img imgbind i:$item] } } else { $path.c delete $idi } } @@ -459,34 +464,46 @@ return [Widget::cget $path.$item $option] } # ---------------------------------------------------------------------------- -# Command ListBox::bindText +# Command ListBox::_bindText # ---------------------------------------------------------------------------- -proc ListBox::bindText { path event script } { +proc ListBox::_bindText { path event script {tag click} } { if { $script != "" } { set map [list %W $path] set script [string map $map $script] append script " \[ListBox::_get_current [list $path]\]" } - $path.c bind "click" $event $script + $path.c bind $tag $event $script +} + +# ---------------------------------------------------------------------------- +# Command ListBox::bindText +# ---------------------------------------------------------------------------- +proc ListBox::bindText { path event script } { + _bindText $path $event $script clickbind } - +# ---------------------------------------------------------------------------- +# Command ListBox::_bindImage # ---------------------------------------------------------------------------- -# Command ListBox::bindImage -# ---------------------------------------------------------------------------- -proc ListBox::bindImage { path event script } { +proc ListBox::_bindImage { path event script {tag img} } { if { $script != "" } { set map [list %W $path] set script [string map $map $script] append script " \[ListBox::_get_current [list $path]\]" } - $path.c bind "img" $event $script + $path.c bind $tag $event $script } +# ---------------------------------------------------------------------------- +# Command ListBox::bindImage +# ---------------------------------------------------------------------------- +proc ListBox::bindImage { path event script } { + _bindImage $path $event $script imgbind +} # ---------------------------------------------------------------------------- # Command ListBox::delete # ---------------------------------------------------------------------------- proc ListBox::delete { path args } { @@ -554,10 +571,11 @@ # ---------------------------------------------------------------------------- proc ListBox::selection { path cmd args } { variable $path upvar 0 $path data + set oldsel $data(selitems); switch -- $cmd { set { set data(selitems) {} foreach item $args { if { [lsearch -exact $data(selitems) $item] == -1 } { @@ -594,12 +612,14 @@ } default { return } } - - _redraw_idle $path 1 + if {[string compare $oldsel $data(selitems)]} { + _redraw_idle $path 1 + } + return; } # ---------------------------------------------------------------------------- # Command ListBox::exists @@ -653,11 +673,11 @@ set item [lindex $ltags 0] if { [string equal $item "item"] || [string equal $item "img"] || [string equal $item "win"] } { # item is the label or image/window of the node - set item [string range [lindex $ltags 1] 2 end] + set item [ListBox::_get_node_name $path $id] set found 1 break } } break @@ -719,20 +739,23 @@ # Command ListBox::see # ---------------------------------------------------------------------------- proc ListBox::see { path item } { variable $path upvar 0 $path data + + if {$data(nrows) == -1} { + # Not yet realized. + set data(seeitem) $item + return + } if { [Widget::getoption $path -redraw] && $data(upd,afterid) != "" } { after cancel $data(upd,afterid) _redraw_listbox $path } - set idn [$path.c find withtag n:$item] - if { $idn != "" } { - ListBox::_see $path $idn right - ListBox::_see $path $idn left - } + + _see_item $path $item; } # ---------------------------------------------------------------------------- # Command ListBox::edit @@ -936,10 +959,24 @@ $path.c xview scroll [expr {$x0-$xv0}] units } } } + +# ---------------------------------------------------------------------------- +# Command ListBox::_see_item +# ---------------------------------------------------------------------------- +proc ListBox::_see_item { path item } { + set idn [$path.c find withtag n:$item] + if { $idn != "" } { + set idi [$path.c find withtag i:$item] + if { $idi == "" } { set idi $idn } + _see $path $idn right + _see $path $idi left + } +} + # ---------------------------------------------------------------------------- # Command ListBox::_update_scrollregion # ---------------------------------------------------------------------------- proc ListBox::_update_scrollregion { path } { @@ -954,20 +991,14 @@ 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}] - } + set w [expr {$xs + $w % $xinc}] } if { $h < $ys } { - set h [expr {int($ys)}] - if { [set r [expr {$h % $yinc}]] } { - set h [expr {$h+$yinc-$r}] - } + set h [expr {$ys + $h % $yinc}] } } $path.c configure -scrollregion [list 0 0 $w $h] } @@ -997,26 +1028,26 @@ set i [$path.c create text [expr {$x1+$indent}] $y \ -text [Widget::getoption $path.$item -text] \ -fill [_getoption $path $item -foreground] \ -font [_getoption $path $item -font] \ -anchor w \ - -tags [list item n:$item click]] + -tags [list item n:$item click clickbind]] if { $selfill && !$multi } { set bbox [$path.c bbox n:$item] set bbox [list 0 [lindex $bbox 1] $ww [lindex $bbox 3]] - set tags [list box b:$item click] + set tags [list box b:$item click clickbind] $path.c create rect $bbox -fill $bg -width 0 -tags $tags $path.c raise $i } if { [set win [Widget::getoption $path.$item -window]] != "" } { $path.c create window [expr {$x0+$indent}] $y \ -window $win -anchor w -tags [list win i:$item] } elseif { [set img [Widget::getoption $path.$item -image]] != "" } { $path.c create image [expr {$x0+$indent}] $y \ - -image $img -anchor w -tags [list img i:$item] + -image $img -anchor w -tags [list img imgbind i:$item] } _set_help $path $item } @@ -1033,11 +1064,12 @@ update idletasks ; # make sure watch cursor is reflected 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 + # Changed from 4 to 2 to make highlight work and look nice for listbox with image as well + set x0 2 set x1 [expr {$x0+$padx}] set nitem 0 set width 0 set drawn {} set data(xlist) {} @@ -1100,11 +1132,11 @@ set selbg [Widget::getoption $path -selectbackground] set selfg [Widget::getoption $path -selectforeground] set selfill [Widget::getoption $path -selectfill] set multi [Widget::getoption $path -multicolumn] foreach id [$path.c find withtag sel] { - set item [string range [lindex [$path.c gettags $id] 1] 2 end] + set item [ListBox::_get_node_name $path $id] if {-1 == [lsearch -exact $data(upd,delete) $item]} { $path.c itemconfigure "n:$item" \ -fill [_getoption $path $item -foreground] } } @@ -1114,15 +1146,24 @@ set width [winfo width $path] } foreach item $data(selitems) { set bbox [$path.c bbox "n:$item"] if { [llength $bbox] } { + set imgbox [$path.c bbox i:$item] + lassign $bbox x0 y0 x1 y1; + if {[string compare "" $imgbox]} { + # image may exist and may be higher than text! + lassign $imgbox ix0 iy0 ix1 iy1; + set bbox [list $x0 [expr {$iy0<$y0?$iy0:$y0}] $x1 [expr {$iy1<$y1?$iy1:$y1}]]; + } else { + set bbox [list $x0 [lindex $bbox 1] $x1 [lindex $bbox 3]] + } if { $selfill && !$multi } { # With -selectfill, make box occupy full width of widget set bbox [list 0 [lindex $bbox 1] $width [lindex $bbox 3]] } - set tags [list sel s:$item click] + set tags [list sel s:$item click clickbind] set id [$path.c create rectangle $bbox \ -fill $selbg -outline $selbg -tags $tags] if {$selfg != ""} { # Don't allow an empty fill - that would be transparent $path.c itemconfigure "n:$item" -fill $selfg @@ -1148,12 +1189,16 @@ _redraw_selection $path _update_scrollregion $path if {[Widget::cget $path -selectfill]} { _update_select_fill $path } + if {![string equal $data(seeitem) ""]} { + _see_item $path $data(seeitem); + } set data(upd,level) 0 set data(upd,afterid) "" + set data(seeitem) ""; } } # ---------------------------------------------------------------------------- @@ -1222,11 +1267,11 @@ set ltags [$path.c gettags current] set item [lindex $ltags 0] if { [string equal $item "item"] || [string equal $item "img"] || [string equal $item "win"] } { - set item [string range [lindex $ltags 1] 2 end] + set item [ListBox::_get_node_name $path] if {[llength [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" @@ -1620,14 +1665,36 @@ event generate $path <> } } } + +# ListBox::_get_node_name -- +# +# Given a listbox item, get the name of the node represented by that +# item. +# +# Arguments: +# path listbox to query +# item Optional item to examine; if omitted, +# defaults to "current" +# +# Results: +# node name of the listbox node. +proc ListBox::_get_node_name {path {item current}} { + set tags [$path.c gettags $item] + if {[lindex $tags 0] == "img"} { + set node [string range [lindex $tags 2] 2 end] + } else { + set node [string range [lindex $tags 1] 2 end] + } + return $node +} + proc ListBox::_get_current { path } { - set t [$path.c gettags current] - return [string range [lindex $t 1] 2 end] + return [ListBox::_get_node_name $path] } # ListBox::_drag_and_drop -- # @@ -1662,17 +1729,36 @@ "widget" { set idx [llength $items] } } - if {$idx > [$path index $startItem]} { incr idx -1 } - - if {[string equal $operation "copy"]} { - set options [Widget::options $path.$startItem] - eval [linsert $options 0 $path insert $idx $startItem\#auto] + # Check if startItem is part of the current selection and process the + # whole selection if so + set selItems [selection $path get] + if {-1 != [lsearch -exact $selItems $startItem]} { + set dragItems $selItems } else { - $path move $startItem $idx + set dragItems [list $startItem] + } + + # get drag indexes (to sort them) + foreach dragItem $dragItems { + lappend dragIdx [$path index $dragItem] + } + foreach pos [lsort -integer -indices $dragIdx] { + set dragItem [lindex $dragItems $pos] + set dragIdx [$path index $dragItem] + if {$idx > $dragIdx} { incr idx -1 } + if {[string equal $operation "copy"]} { + set options [Widget::options $path.$dragItem] + eval [linsert $options 0 $path insert $idx $dragItem\#auto] + incr idx + } else { + $path move $dragItem $idx + set idx [$path index $dragItem] + incr idx + } } } proc ListBox::_keyboard_navigation { path dir } { Index: mainframe.tcl ================================================================== --- mainframe.tcl +++ mainframe.tcl @@ -1,9 +1,9 @@ # ---------------------------------------------------------------------------- # mainframe.tcl # This file is part of Unifix BWidget Toolkit -# $Id: mainframe.tcl,v 1.24 2009/07/01 14:41:30 oehhar Exp $ +# $Id: mainframe.tcl,v 1.24.2.3 2011/05/25 15:10:07 oehhar Exp $ # ------------------------------------------------------------------------------ # Index of commands: # - MainFrame::create # - MainFrame::configure # - MainFrame::cget @@ -35,32 +35,51 @@ -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} - - {-menubarfont String "" 0} - {-menuentryfont String "" 0} - {-statusbarfont String "" 0} - } - - 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} + if {[Widget::theme]} { + # No option -background for themed MainFrame + Widget::declare MainFrame { + {-width TkResource 0 0 frame} + {-height TkResource 0 0 frame} + {-textvariable String "" 0} + {-menu String {} 1} + {-separator Enum both 1 {none top bottom both}} + + {-menubarfont String "" 0} + {-menuentryfont String "" 0} + {-statusbarfont String "" 0} + {-sizegrip Boolean 0 1} + } + + Widget::addmap MainFrame "" .frame {-width {} -height {}} + } else { + 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} + + {-menubarfont String "" 0} + {-menuentryfont String "" 0} + {-statusbarfont String "" 0} + {-sizegrip Boolean 0 1} + } + + 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} + } variable _widget } @@ -164,10 +183,13 @@ [Widget::subcget $path .status.prg] \ -width 50 \ -height [expr {[winfo reqheight $label]-2}] \ -borderwidth 1 \ -relief sunken] + if {[Widget::theme] && [Widget::getoption $path -sizegrip]} { + pack [ttk::sizegrip $botframe.sg] -side right -anchor se + } 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 @@ -178,10 +200,11 @@ if { [llength $menu] } { _create_menubar $path $menu } bind $path [list MainFrame::_destroy %W] + bind $path <> [list MainFrame::_world_changed %W %d] return [Widget::create MainFrame $path] } @@ -197,11 +220,12 @@ uplevel \#0 $path.status.label configure -textvariable [list $newv] } # The ttk frame has no -background if {![Widget::theme] && [Widget::hasChanged $path -background bg] } { - if {$::tcl_platform(platform) == "unix"} { + if {($::tcl_platform(platform) == "unix") + && (0 != [string compare [tk windowingsystem] "aqua"])} { set listmenu [$_widget($path,top) cget -menu] while { [llength $listmenu] } { set newlist {} foreach menu $listmenu { $menu configure -background $bg @@ -265,19 +289,15 @@ for {set index 0} {$index<$_widget($path,nindic)} {incr index} { set indic $path.status.indf.f$index eval [list $indic configure] $sbfnt } eval [list $path.status.label configure] $sbfnt - $path.status configure -height [winfo reqheight $path.status.label] - - $path.status.prg configure \ - -height [expr {[winfo reqheight $path.status.label]-2}] + _evaluate_status_height $path } return $res } - # ---------------------------------------------------------------------------- # Command MainFrame::cget # ---------------------------------------------------------------------------- proc MainFrame::cget { path option } { @@ -301,23 +321,24 @@ 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" } { if {[Widget::theme]} { ttk::frame $toolframe -padding 1 } else { + set bg [Widget::getoption $path -background] frame $toolframe -relief raised -borderwidth 1 \ -takefocus 0 -highlightthickness 0 -background $bg } } else { if {[Widget::theme]} { ttk::frame $toolframe set sep [ttk::separator $toolframe.sep -orient horizontal] } else { + set bg [Widget::getoption $path -background] 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 @@ -498,29 +519,57 @@ foreach index [array names _widget $path,*] { unset _widget($index) } } +# ----------------------------------------------------------------------------- +# Command MainFrame::_world_changed +# ----------------------------------------------------------------------------- +proc MainFrame::_world_changed { path type} { + # Check if font changed + if {$type == "FontChanged"} { + _evaluate_status_height $path + } +} + +# ----------------------------------------------------------------------------- +# Command MainFrame::_evaluate_status_height +# ----------------------------------------------------------------------------- +# Change the status bar height in dependence of the status bar font. +# This is used on configure -statusfont and on world change, where the font +# height may also change. +proc MainFrame::_evaluate_status_height {path} { + $path.status configure -height [winfo reqheight $path.status.label] + + $path.status.prg configure \ + -height [expr {[winfo reqheight $path.status.label]-2}] +} # ---------------------------------------------------------------------------- # Command MainFrame::_create_menubar # ---------------------------------------------------------------------------- -proc MainFrame::_create_menubar { path descmenu } { +# For Android, a menubutton is more appropriate. +# To support this, the menubutton widget may be passed as 3rd +# parameter. +proc MainFrame::_create_menubar { path descmenu {top ""} } { variable _widget global tcl_platform - set top $_widget($path,top) + if {![string length $top]} { + set top $_widget($path,top) + } foreach {v x} {mbfnt -menubarfont mefnt -menuentryfont} { if {[string length [Widget::getoption $path $x]]} { set $v [list -font [Widget::getoption $path $x]] } else { set $v "" } } - if {![Widget::theme] && $tcl_platform(platform) == "unix"} { + if { ![Widget::theme] && $tcl_platform(platform) == "unix" + && [tk windowingsystem] !="aqua" } { set menuopts [list -background [Widget::getoption $path -background] \ -borderwidth 1] } else { set menuopts [list] } @@ -527,35 +576,44 @@ set menubar [eval [list menu $top.menubar -tearoff 0] $menuopts $mbfnt] $top configure -menu $menubar set count 0 foreach {name tags menuid tearoff entries} $descmenu { - set opt [_parse_name $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 + # Check if only one menu with an empty name is given + # In this case, remove the top level menu item + # This allows to also have checkboxes and commands at the top level. + if {![string length $name] && 5 == [llength $descmenu]} { + # A single namesless menu - skip the first level to allow other + # than cascade as first level. + set menu $menubar } else { - set menu $menubar.menu$count - } - eval [list $menubar add cascade] $opt [list -menu $menu] - eval [list menu $menu -tearoff $tearoff] $menuopts $mefnt - foreach tag $tags { - lappend _widget($path,tags,$tag) $menubar $count - # ericm@scriptics: Add a tagstate tracker - if { ![info exists _widget($path,tagstate,$tag)] } { - set _widget($path,tagstate,$tag) 1 - } - } - # ericm@scriptics: Add mapping from menu items to tags - set _widget($path,menutags,[list $menubar $count]) $tags - - if { [string length $menuid] } { - # menu has identifier - set _widget($path,menuid,$menuid) $menu + set opt [_parse_name $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 [list $menubar add cascade] $opt [list -menu $menu] + eval [list menu $menu -tearoff $tearoff] $menuopts $mefnt + foreach tag $tags { + lappend _widget($path,tags,$tag) $menubar $count + # ericm@scriptics: Add a tagstate tracker + if { ![info exists _widget($path,tagstate,$tag)] } { + set _widget($path,tagstate,$tag) 1 + } + } + # ericm@scriptics: Add mapping from menu items to tags + set _widget($path,menutags,[list $menubar $count]) $tags + + if { [string length $menuid] } { + # menu has identifier + set _widget($path,menuid,$menuid) $menu + } } _create_entries $path $menu $menuopts $entries incr count } } @@ -619,11 +677,20 @@ # 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] [list $menu invoke $count] + foreach event [lindex $accel 1] { + bind $_widget($path,top) $event [list $menu invoke $count] + } + foreach event [lindex $accel 2] { + if {[bind $_widget($path,top) $event] == {}} { + bind $_widget($path,top) $event { # do nothing } + } else { + # The existing binding will intercept these events. + } + } } # user options set useropt [lrange $entry 5 end] if { [string equal $type "command"] || @@ -655,58 +722,136 @@ # MainFrame::_parse_accelerator -- # # Given a key combo description, construct an appropriate human readable -# string (for display on as a menu accelerator) and the corresponding -# bind event. +# string (for display on as a menu accelerator), a list of the +# corresponding bind events, and a separate list of bind events that need +# to be blocked. +# +# When argument $desc does not include "Shift", the bindings to $events +# will in some cases also intercept events that have the modifier "Shift", +# unless more specific bindings $blockEvents exist to the latter. This +# situation occurs, for example, when a Cmd binding exists without a +# corresponding ShiftCmd binding. The list of events that need to be +# blocked is returned as the third element of the result. # # Arguments: # desc a list with the following format: # ?sequence? key -# sequence may be None, Ctrl, Alt, or CtrlAlt +# sequence may be None, Ctrl, Alt, CtrlAlt, Shift, Cmd or +# ShiftCmd # key may be any key # # Results: -# {accel event} a list containing the accelerator string and the event +# {accel events blockEvents} a list containing the accelerator string and +# two lists of events proc MainFrame::_parse_accelerator { desc } { + variable _widget + + set fKey 0 if { [llength $desc] == 1 } { set seq None set key [string tolower [lindex $desc 0]] # If the key is an F key (ie, F1, F2, etc), it has to be capitalized if {[regexp {^f([1-9]|([12][0-9]|3[0-5]))$} $key]} { set key [string toupper $key] + set fKey 1 } } elseif { [llength $desc] == 2 } { set seq [lindex $desc 0] set key [string tolower [lindex $desc 1]] # If the key is an F key (ie, F1, F2, etc), it has to be capitalized if {[regexp {^f([1-9]|([12][0-9]|3[0-5]))$} $key]} { set key [string toupper $key] + set fKey 1 } } else { return {} } + + # Plain "Shift" can be used only with F keys, but "ShiftCmd" is allowed. + if {[string equal $seq "Shift"] && (!$fKey)} { + return -code error {Shift accelerator can be used only with F keys} + } + + set blockEvents {} + set upc [string toupper $key] + switch -- $seq { None { - set accel "[string toupper $key]" - set event "" + set accel "$upc" + set events [list ""] + if {$fKey} { + set blockEvents [list ""] + } + } + Shift { + # Used only with Function keys. + set accel "Shift+$upc" + set events [list ""] + } + Cmd { + set accel "Cmd+$upc" + + if { [string equal [tk windowingsystem] "aqua"] && + ([string first AppKit [winfo server .]] == -1) + } { + # Carbon + set events [list "" \ + "" ] + set blockEvents [list ""] + # Both bindings must be included in $events - the first binding + # does not fire if "Lock" is set, and this is as bind(n) states + # because the second binding is NOT a more specialized form of + # the first. + } else { + # Cocoa and anything else that uses Cmd + set events [list ""] + # A binding to "" must not be included + # here - both events fire if "Lock" is set. + set blockEvents [list ""] + } + } + ShiftCmd { + if { [string equal [tk windowingsystem] "aqua"] && + ([string first AppKit [winfo server .]] == -1) + } { + # Carbon + set accel "Shift+Cmd+$upc" + set events [list "" \ + ""] + # Both bindings must be included here - the first binding does + # not fire if "Lock" is set, even though the second binding + # should be recognized as a more specialized form of the first. + } else { + # Cocoa and anything else that uses Cmd + set accel "Shift+Cmd+$upc" + set events [list ""] + # A binding to "" must not be + # included here - both events fire if "Lock" is set. + # Tk/Cocoa fails to recognize + # as a "more specialized" binding + # than . + # Perversely, Tk/Carbon (above) makes the opposite error. + } } Ctrl { - set accel "Ctrl+[string toupper $key]" - set event "" + set accel "Ctrl+$upc" + set events [list ""] } Alt { - set accel "Alt+[string toupper $key]" - set event "" + set accel "Alt+$upc" + set events [list ""] } CtrlAlt { - set accel "Ctrl+Alt+[string toupper $key]" - set event "" + set accel "Ctrl+Alt+$upc" + set events [list ""] } default { return -code error "invalid accelerator code $seq" } } - return [list $accel $event] + + return [list $accel $events $blockEvents] } Index: notebook.tcl ================================================================== --- notebook.tcl +++ notebook.tcl @@ -1,9 +1,9 @@ # --------------------------------------------------------------------------- # notebook.tcl # This file is part of Unifix BWidget Toolkit -# $Id: notebook.tcl,v 1.25 2009/07/01 14:41:30 oehhar Exp $ +# $Id: notebook.tcl,v 1.25.2.2 2011/04/26 14:13:24 oehhar Exp $ # --------------------------------------------------------------------------- # Index of commands: # - NoteBook::create # - NoteBook::configure # - NoteBook::cget @@ -41,10 +41,13 @@ {-state Enum normal 0 {normal disabled}} {-createcmd String "" 0} {-raisecmd String "" 0} {-leavecmd String "" 0} {-image TkResource "" 0 label} + {-rimage String "" 0} + {-ractiveimage String "" 0} + {-rimagecmd String "" 0} {-text String "" 0} {-foreground String "" 0} {-background String "" 0} {-activeforeground String "" 0} {-activebackground String "" 0} @@ -96,10 +99,11 @@ variable _warrow 12 bind NoteBook [list NoteBook::_resize %W] bind NoteBook [list NoteBook::_destroy %W] + bind NoteBook <> [list NoteBook::_worldchanged %W %d] } # --------------------------------------------------------------------------- # Command NoteBook::create @@ -180,12 +184,14 @@ } set chibd [Widget::hasChanged $path -internalborderwidth ibd] set chbg [Widget::hasChanged $path -background bg] if {$chibd || $chbg} { foreach page $data(pages) { - $path.f$page configure \ - -borderwidth $ibd -background $bg + if { ! $::Widget::_theme } { + $path.f$page configure -background $bg + } + $path.f$page configure -borderwidth $ibd } } if {$chbg} { set col [BWidget::get3dcolor $path $bg] @@ -261,19 +267,25 @@ Widget::init NoteBook::Page $f $args set data(pages) [linsert $data(pages) $index $page] # If the page doesn't exist, create it; if it does reset its bg and ibd if { ![winfo exists $f] } { - frame $f \ - -relief flat \ - -background [Widget::cget $path -background] \ - -borderwidth [Widget::cget $path -internalborderwidth] + if {$::Widget::_theme} { + ttk::frame $f + } else { + frame $f \ + -relief flat \ + -background [Widget::cget $path -background] \ + -borderwidth [Widget::cget $path -internalborderwidth] + } set data($page,realized) 0 + set data($page,rimage) 0 } else { - $f configure \ - -background [Widget::cget $path -background] \ - -borderwidth [Widget::cget $path -internalborderwidth] + if { ! $::Widget::_theme} { + $f configure -background [Widget::cget $path -background] + } + $f configure -borderwidth [Widget::cget $path -internalborderwidth] } _compute_height $path _compute_width $path _draw_page $path $page 1 _set_help $path $page @@ -300,13 +312,13 @@ if { $pos < $data(base) } { incr data(base) -1 } if { $destroyframe } { destroy $path.f$page + unset data($page,width) data($page,realized) data($page,rimage) } _redraw $path - unset data($page,width) data($page,realized) } # --------------------------------------------------------------------------- # Command NoteBook::itemconfigure @@ -497,10 +509,13 @@ if { [Widget::hasChanged $path.f$page -text foo] } { _compute_width $path } elseif { [Widget::hasChanged $path.f$page -image foo] } { _compute_height $path _compute_width $path + } elseif { [Widget::hasChanged $path.f$page -rimage foo] } { + _compute_height $path + _compute_width $path } if { [Widget::hasChanged $path.f$page -state state] && $state == "disabled" && $data(select) == $page } { set data(select) "" } @@ -537,10 +552,17 @@ set wtext [expr {$wtext + [image width $img] + 4}] set himg [expr {[image height $img] + 6}] if { $himg > $hmax } { set hmax $himg } + } + if { [set jmg [Widget::cget $path.f$page -rimage]] != "" } { + set wtext [expr {$wtext + [image width $jmg] + 4}] + set hjmg [expr {[image height $jmg] + 6}] + if { $hjmg > $hmax } { + set hmax $hjmg + } } set wmax [expr {$wtext > $wmax ? $wtext : $wmax}] incr wtot $wtext set data($page,width) $wtext } @@ -565,23 +587,30 @@ set font [Widget::cget $path -font] set pady0 [Widget::_get_padding $path -tabpady 0] set pady1 [Widget::_get_padding $path -tabpady 1] set metrics [font metrics $font -linespace] set imgh 0 + set jmgh 0 set lines 1 foreach page $data(pages) { set img [Widget::cget $path.f$page -image] + set jmg [Widget::cget $path.f$page -rimage] set text [Widget::cget $path.f$page -text] set len [llength [split $text \n]] if {$len > $lines} { set lines $len} if {$img != ""} { set h [image height $img] if {$h > $imgh} { set imgh $h } } + if {$jmg != ""} { + set h [image height $jmg] + if {$h > $jmgh} { set jmgh $h } + } } set height [expr {$metrics * $lines}] if {$imgh > $height} { set height $imgh } + if {$jmgh > $height} { set height $jmgh } set data(hpage) [expr {$height + $pady0 + $pady1}] } # --------------------------------------------------------------------------- @@ -657,10 +686,62 @@ -fill [_getoption $path $page -foreground] } } } + +# --------------------------------------------------------------------------- +# Command NoteBook::_rightImage +# --------------------------------------------------------------------------- +proc NoteBook::_rightImage { type path page } { + variable $path + upvar 0 $path data + + if { [string equal [Widget::cget $path.f$page -state] "disabled"] } { + return + } + + switch -- $type { + on { + set data($page,rimage) 1 + set jmg [Widget::cget $path.f$page -rimage] + set jamg [Widget::cget $path.f$page -ractiveimage] + if { ($jmg ne {}) + && ($jamg ne {}) + && ([image height $jmg] == [image height $jamg]) + && ([image width $jmg] == [image width $jamg]) + } { + $path.c itemconfigure "$page:jmg" \ + -image $jamg + } else { + # Don't replace the -rimage with the -raimage if they are + # different sizes. + } + } + off { + set data($page,rimage) 0 + $path.c itemconfigure "$page:jmg" \ + -image [Widget::cget $path.f$page -rimage] + } + command { + set cmd [Widget::cget $path.f$page -rimagecmd] + if {$cmd ne {}} { + after idle [list uplevel #0 [list NoteBook::_rightImage execute $path $page]] + # Call after idle so that, if the pointer has left the -rimage, + # the event fires and resets data($page,rimage) before + # NoteBook::_rightImage execute is evaluated. + } + } + execute { + set cmd [Widget::cget $path.f$page -rimagecmd] + if {$cmd ne {} && $data($page,rimage)} { + uplevel #0 [concat $cmd [list $path $page]] + } + } + } +} + # --------------------------------------------------------------------------- # Command NoteBook::_select # --------------------------------------------------------------------------- proc NoteBook::_select { path page } { @@ -829,10 +910,11 @@ $rightPlusRadius $h \ ] } set img [Widget::cget $path.f$page -image] + set jmg [Widget::cget $path.f$page -rimage] set ytext $top if { $tabsOnBottom } { # The "+ 2" below moves the text closer to the bottom of the tab, # so it doesn't look so cramped. I should be able to achieve the @@ -848,10 +930,19 @@ if { $img != "" } { # if there's an image, put it on the left and move the text right set ximg $xtext incr xtext [expr {[image width $img] + 2}] } + + if { $jmg != "" } { + # if there's an image, put it on the right and leave the text + set xjmg $xtext + if { $img != "" } { + set xjmg $ximg + } + incr xjmg [expr {$data($page,width) - [image width $jmg] - 10}] + } if { $data(select) == $page } { set bd [Widget::cget $path -borderwidth] if {$bd < 1} { set bd 1 } set fg [_getoption $path $page -foreground] @@ -919,10 +1010,30 @@ $path.c itemconfigure $id -image $img # Sven end } else { $path.c delete $page:img } + + if { $jmg != "" } { + set id [$path.c find withtag $page:jmg] + if { [string equal $id ""] } { + set id [$path.c create image $xjmg $ytext \ + -anchor nw \ + -tags [list page p:$page $page:jmg]] + } + $path.c coords $id $xjmg $ytext + $path.c itemconfigure $id -image $jmg + + $path.c bind $page:jmg \ + [list NoteBook::_rightImage on $path $page] + $path.c bind $page:jmg \ + [list NoteBook::_rightImage off $path $page] + $path.c bind $page:jmg \ + [list NoteBook::_rightImage command $path $page] + } else { + $path.c delete $page:jmg + } if { $data(select) == $page } { $path.c raise p:$page } elseif { $pos == 0 } { if { $data(select) == "" } { @@ -1098,16 +1209,26 @@ # ----------------------------------------------------------------------------- proc NoteBook::_resize { path } { variable $path upvar 0 $path data + # Check if pages are fully initialized or if we are still initializing + if { 0 < [llength $data(pages)] && + ![info exists data([lindex $data(pages) end],width)] } { + return + } + if {!$data(realized)} { - if { [set width [Widget::cget $path -width]] == 0 || - [set height [Widget::cget $path -height]] == 0 } { - compute_size $path - } set data(realized) 1 + if { [Widget::cget $path -width] == 0 || + [Widget::cget $path -height] == 0 } { + # This does an update allowing other events (resize) to enter + # In addition, it does a redraw, so first set the realized and + # then exit + compute_size $path + return + } } NoteBook::_redraw $path } @@ -1162,5 +1283,20 @@ proc NoteBook::_get_page_name { path {item current} {tagindex end-1} } { return [string range [lindex [$path.c gettags $item] $tagindex] 2 end] } + +# ----------------------------------------------------------------------------- +# Command NoteBook::_worldchanged +# ----------------------------------------------------------------------------- +proc NoteBook::_worldchanged { path type} { + # Check if font changed + if {$type == "FontChanged"} { + # The tabs are redraws, as the font of the labels may have changed in + # size. Note: the following operations are the same as "configure -font" + _compute_height $path + _compute_width $path + _redraw $path + } +} + Index: pagesmgr.tcl ================================================================== --- pagesmgr.tcl +++ pagesmgr.tcl @@ -1,9 +1,9 @@ # ------------------------------------------------------------------------------ # pagesmgr.tcl # This file is part of Unifix BWidget Toolkit -# $Id: pagesmgr.tcl,v 1.6 2003/10/20 21:23:52 damonc Exp $ +# $Id: pagesmgr.tcl,v 1.6.2.1 2011/02/14 16:56:09 oehhar Exp $ # ------------------------------------------------------------------------------ # Index of commands: # - PagesManager::create # - PagesManager::configure # - PagesManager::cget @@ -108,12 +108,16 @@ return -code error "page \"$page\" already exists" } lappend data(pages) $page - frame $path.f$page -relief flat \ - -background [Widget::cget $path -background] -borderwidth 0 + if {[Widget::theme]} { + ttk::frame $path.f$page + } else { + frame $path.f$page -relief flat \ + -background [Widget::cget $path -background] -borderwidth 0 + } return $path.f$page } Index: pkgIndex.tcl ================================================================== --- pkgIndex.tcl +++ pkgIndex.tcl @@ -1,47 +1,48 @@ if {[catch {package require Tcl}]} return -package ifneeded BWidget 1.9 "\ +# NOTE: auto_loaded top-level commands shall not be qualified (no leading ::) +# but all others should. See auto_qualify for details. +package ifneeded BWidget 1.9.16 "\ package require Tk 8.1.1;\ - [list tclPkgSetup $dir BWidget 1.9 { -{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}} -{panelframe.tcl source {PanelFrame PanelFrame::create PanelFrame::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}} -{statusbar.tcl source {StatusBar StatusBar::create StatusBar::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::menu SelectColor::dialog SelectColor::setcolor}} -{dynhelp.tcl source {DynamicHelp::configure DynamicHelp::use DynamicHelp::register DynamicHelp::include DynamicHelp::add DynamicHelp::delete}} -{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}} -{wizard.tcl source {Wizard Wizard::create Wizard::use SimpleWizard ClassicWizard}} -{xpm2image.tcl source {xpm-to-image}} -}]; \ - [list namespace eval ::BWIDGET {}]; \ - [list set ::BWIDGET::LIBRARY $dir]; \ + [list tclPkgSetup $dir BWidget 1.9.16 { + {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}} + {panelframe.tcl source {PanelFrame ::PanelFrame::create ::PanelFrame::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}} + {statusbar.tcl source {StatusBar ::StatusBar::create ::StatusBar::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::menu ::SelectColor::dialog ::SelectColor::setcolor ::SelectColor::setbasecolor}} + {dynhelp.tcl source {::DynamicHelp::configure ::DynamicHelp::use ::DynamicHelp::register ::DynamicHelp::include ::DynamicHelp::add ::DynamicHelp::delete}} + {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}} + {wizard.tcl source {Wizard ::Wizard::create ::Wizard::use SimpleWizard ClassicWizard}} + {xpm2image.tcl source {xpm-to-image}} + }]; \ + [list namespace eval ::BWIDGET {}]; \ + [list set ::BWIDGET::LIBRARY $dir]; \ [list source [file join $dir widget.tcl]]; \ [list source [file join $dir init.tcl]]; \ [list source [file join $dir utils.tcl]]; \ " Index: scrollframe.tcl ================================================================== --- scrollframe.tcl +++ scrollframe.tcl @@ -95,13 +95,16 @@ # add binding: is not called when frame # becomes so small that it suddenly falls outside of currently visible area. # but now we need to add a binding too bind $frame \ [list ScrollableFrame::_frameConfigure $canvas] - bind $frame \ - [list ScrollableFrame::_frameConfigure $canvas 1] + # Tk 8.7/TIP518 allows to get an event when the last child is removed. + # In this case, we should resize to 1x1 pixel. + bind $frame <>\ + [list ScrollableFrame::_frameNoManagedChild $frame] + bindtags $path [list $path BwScrollableFrame [winfo toplevel $path] all] return [Widget::create ScrollableFrame $path] } @@ -114,24 +117,24 @@ 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 } + if { $cw } { + set w [winfo width $path] + } 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 { $ch } { + set h [winfo height $path] + } if { $upd } { $path:cmd itemconfigure win -width $w -height $h } return $res @@ -244,19 +247,26 @@ # ---------------------------------------------------------------------------- # Command ScrollableFrame::_frameConfigure # ---------------------------------------------------------------------------- proc ScrollableFrame::_max {a b} {return [expr {$a <= $b ? $b : $a}]} -proc ScrollableFrame::_frameConfigure {canvas {unmap 0}} { +proc ScrollableFrame::_frameConfigure {canvas} { # This ensures that we don't get funny scrollability in the frame # when it is smaller than the canvas space # use [winfo] to get height & width of frame - - # [winfo] doesn't work for unmapped frame - set frameh [expr {$unmap ? 0 : [winfo height $canvas.frame]}] - set framew [expr {$unmap ? 0 : [winfo width $canvas.frame]}] - - set height [_max $frameh [winfo height $canvas]] - set width [_max $framew [winfo width $canvas]] + if {![winfo ismapped $canvas.frame]} { return } + set height [_max [winfo height $canvas.frame] [winfo height $canvas]] + set width [_max [winfo width $canvas.frame] [winfo width $canvas]] $canvas:cmd configure -scrollregion [list 0 0 $width $height] } + + +# ---------------------------------------------------------------------------- +# Command ScrollableFrame::_frameNoManagedChild +# ---------------------------------------------------------------------------- +proc ScrollableFrame::_frameNoManagedChild {frame} { + # There are no childs mapped any more, so resize frame to 1x1 + $frame configure -width 1 -height 1 + # Do not fix size, so set values to 0 + $frame configure -width 0 -height 0 +} Index: scrollw.tcl ================================================================== --- scrollw.tcl +++ scrollw.tcl @@ -1,9 +1,9 @@ # ----------------------------------------------------------------------------- # scrollw.tcl # This file is part of Unifix BWidget Toolkit -# $Id: scrollw.tcl,v 1.13 2009/06/29 13:28:24 oehhar Exp $ +# $Id: scrollw.tcl,v 1.13.2.2 2011/02/14 16:56:09 oehhar Exp $ # ----------------------------------------------------------------------------- # Index of commands: # - ScrolledWindow::create # - ScrolledWindow::getframe # - ScrolledWindow::setwidget @@ -45,25 +45,36 @@ Widget::getVariable $path data set bg [Widget::cget $path -background] set sbsize [Widget::cget $path -size] - set sw [eval [list frame $path \ - -relief flat -borderwidth 0 -background $bg \ - -highlightthickness 0 -takefocus 0] \ - [Widget::subcget $path :cmd]] - - scrollbar $path.hscroll \ - -highlightthickness 0 -takefocus 0 \ - -orient horiz \ - -relief sunken \ - -bg $bg - scrollbar $path.vscroll \ - -highlightthickness 0 -takefocus 0 \ - -orient vert \ - -relief sunken \ - -bg $bg + + if { $::Widget::_theme } { + set sw [eval [list ttk::frame $path \ + -relief flat -borderwidth 0 -takefocus 0] \ + [Widget::subcget $path :cmd]] + ttk::scrollbar $path.hscroll \ + -takefocus 0 -orient horiz + ttk::scrollbar $path.vscroll \ + -takefocus 0 -orient vert + } else { + if {$bg != ""} { + set bg [list -background $bg] + } + set sw [eval [list frame $path \ + -relief flat -borderwidth 0] $bg [list \ + -highlightthickness 0 -takefocus 0] \ + [Widget::subcget $path :cmd]] + scrollbar $path.hscroll \ + -highlightthickness 0 -takefocus 0 \ + -orient horiz \ + -relief sunken + scrollbar $path.vscroll \ + -highlightthickness 0 -takefocus 0 \ + -orient vert \ + -relief sunken + } set data(realized) 0 _setData $path \ [Widget::cget $path -scrollbar] \ @@ -75,15 +86,17 @@ set data(vsb,packed) $data(vsb,present) } else { set data(hsb,packed) 0 set data(vsb,packed) 0 } - if {$sbsize} { - $path.vscroll configure -width $sbsize - $path.hscroll configure -width $sbsize - } else { - set sbsize [$path.vscroll cget -width] + if { ! $::Widget::_theme } { + if {$sbsize} { + $path.vscroll configure -width $sbsize + $path.hscroll configure -width $sbsize + } else { + set sbsize [$path.vscroll cget -width] + } } set data(ipad) [Widget::cget $path -ipad] if {$data(hsb,packed)} { grid $path.hscroll -column 1 -row $data(hsb,row) \ @@ -123,10 +136,11 @@ grid remove $data(widget) $data(widget) configure -xscrollcommand "" -yscrollcommand "" } set data(widget) $widget grid $widget -in $path -row 1 -column 1 -sticky news + raise $widget; $path.hscroll configure -command [list $widget xview] $path.vscroll configure -command [list $widget yview] $widget configure \ -xscrollcommand [list ScrolledWindow::_set_hscroll $path] \ @@ -139,14 +153,14 @@ # ----------------------------------------------------------------------------- proc ScrolledWindow::configure { path args } { Widget::getVariable $path data set res [Widget::configure $path $args] - if { [Widget::hasChanged $path -background bg] } { - $path configure -background $bg - catch {$path.hscroll configure -background $bg} - catch {$path.vscroll configure -background $bg} + if { ! $::Widget::_theme && [Widget::hasChanged $path -background bg] } { + $path configure -background $bg + catch {$path.hscroll configure -background $bg} + catch {$path.vscroll configure -background $bg} } if {[Widget::hasChanged $path -scrollbar scrollbar] | \ [Widget::hasChanged $path -auto auto] | \ [Widget::hasChanged $path -sides sides]} { Index: spinbox.tcl ================================================================== --- spinbox.tcl +++ spinbox.tcl @@ -37,17 +37,28 @@ {-repeatinterval Int 100 0 {%d >= 0}} {-foreground TkResource black 0 {button}} } Widget::addmap SpinBox "" :cmd {-background {}} - Widget::addmap SpinBox ArrowButton .arrup { - -foreground {} -background {} -disabledforeground {} -state {} \ - -repeatinterval {} -repeatdelay {} - } - Widget::addmap SpinBox ArrowButton .arrdn { - -foreground {} -background {} -disabledforeground {} -state {} \ - -repeatinterval {} -repeatdelay {} + if {$::Widget::_theme} { + Widget::addmap SpinBox ArrowButton .arrup { + -foreground {} -background {} -state {} \ + -repeatinterval {} -repeatdelay {} + } + Widget::addmap SpinBox ArrowButton .arrdn { + -foreground {} -background {} -state {} \ + -repeatinterval {} -repeatdelay {} + } + } else { + Widget::addmap SpinBox ArrowButton .arrup { + -foreground {} -background {} -disabledforeground {} -state {} \ + -repeatinterval {} -repeatdelay {} + } + Widget::addmap SpinBox ArrowButton .arrdn { + -foreground {} -background {} -disabledforeground {} -state {} \ + -repeatinterval {} -repeatdelay {} + } } ::bind SpinBox [list after idle {BWidget::refocus %W %W.e}] ::bind SpinBox [list SpinBox::_destroy %W] @@ -63,11 +74,15 @@ array set maps [Widget::parseArgs SpinBox $args] eval [list frame $path] $maps(:cmd) \ [list -highlightthickness 0 -takefocus 0 -class SpinBox] Widget::initFromODB SpinBox $path $maps(SpinBox) - set entry [eval [list Entry::create $path.e] $maps(.e) -relief flat -bd 0] + if {$Widget::_theme} { + set entry [eval [list Entry::create $path.e] $maps(.e)] + } else { + set entry [eval [list Entry::create $path.e] $maps(.e) -relief flat -bd 0] + } bindtags $path.e [linsert [bindtags $path.e] 1 SpinBoxEntry] set farr [frame $path.farr -relief flat -bd 0 -highlightthickness 0] set height [expr {[winfo reqheight $path.e]/2-2}] set width 11 Index: tests/entry.test ================================================================== --- tests/entry.test +++ tests/entry.test @@ -21,11 +21,11 @@ {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"}} {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} {-command foo foo {} {}} {-disabledforeground blue blue non-existent \ {unknown color name "non-existent"}} - {-editable false false shazbot {expected boolean value but got "shazbot"}} + {-editable false 0 shazbot {expected boolean value but got "shazbot"}} {-exportselection yes 1 xyzzy {expected boolean value but got "xyzzy"}} {-fg #110022 #110022 bogus {unknown color name "bogus"}} {-font {Helvetica 12 italic} {Helvetica 12 italic} {} \ {font "" doesn't exist}} {-foreground #110022 #110022 bogus {unknown color name "bogus"}} @@ -63,11 +63,11 @@ } destroy .e test Entry-2.1 {Entry} { list [catch {Entry} msg] $msg -} {1 {no value given for parameter "path" to "Entry"}} +} {1 {wrong # args: should be "Entry path ..."}} test Entry-2.2 {Entry} { list [catch {Entry gorp} msg] $msg } {1 {bad window path name "gorp"}} test Entry-2.3 {Entry procedure} { Entry .e Index: tree.tcl ================================================================== --- tree.tcl +++ tree.tcl @@ -1,9 +1,9 @@ # ---------------------------------------------------------------------------- # tree.tcl # This file is part of Unifix BWidget Toolkit -# $Id: tree.tcl,v 1.60 2009/07/24 16:01:55 oehhar Exp $ +# $Id: tree.tcl,v 1.60.2.4 2011/06/23 08:28:04 oehhar Exp $ # ---------------------------------------------------------------------------- # Index of commands: # - Tree::create # - Tree::configure # - Tree::cget @@ -91,13 +91,13 @@ {-selectcommand String "" 0} {-width TkResource "" 0 listbox} {-height TkResource "" 0 listbox} {-selectfill Boolean 0 0} {-showlines Boolean 1 0} - {-linesfill TkResource black 0 {listbox -foreground}} + {-linesfill TkResource "" 0 {listbox -foreground}} {-linestipple TkResource "" 0 {label -bitmap}} - {-crossfill TkResource black 0 {listbox -foreground}} + {-crossfill TkResource "" 0 {listbox -foreground}} {-redraw Boolean 1 0} {-opencmd String "" 0} {-closecmd String "" 0} {-dropovermode Flag "wpn" 0 "wpn"} {-bg Synonym -background} @@ -348,11 +348,11 @@ if { [Widget::getMegawidgetOption $path.$parent -open] } { # ...and opened -> redraw whole _redraw_idle $path 3 } else { # ...and closed -> redraw cross - lappend data(upd,nodes) $parent 8 + MergeFlag $path $parent 8 _redraw_idle $path 2 } } return $node @@ -398,23 +398,31 @@ if {$data(upd,level) < 3 && [Widget::hasChanged $path.$node -padx x]} { _redraw_idle $path 3 } if { $data(upd,level) < 3 && $flag } { - if { [set idx [lsearch -exact $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] - } + MergeFlag $path $node $flag _redraw_idle $path 2 } } return $result } +proc Tree::MergeFlag { path node flag } { + variable $path + upvar 0 $path data + + # data(upd,nodes) is a key-val list: emulate a dict by an array + array set n $data(upd,nodes) + if {![info exists n($node)]} { + lappend data(upd,nodes) $node $flag + } else { + set n($node) [expr {$n($node) | $flag}] + set data(upd,nodes) [array get n] + } + return +} # ---------------------------------------------------------------------------- # Command Tree::itemcget # ---------------------------------------------------------------------------- proc Tree::itemcget { path node option } { @@ -1219,20 +1227,14 @@ 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}] - } + set w [expr {$xs + $w % $xinc}] } if { $h < $ys } { - set h [expr {int($ys)}] - if { [set r [expr {$h % $yinc}]] } { - set h [expr {$h+$yinc-$r}] - } + set h [expr {$ys + $h % $yinc}] } } $path.c configure -scrollregion [list 0 0 $w $h] @@ -1921,28 +1923,31 @@ incr index -1 if { $index >= 0 } { $win selection set [lindex $nodes $index] _set_current_node $win [lindex $nodes $index] $win see [lindex $nodes $index] + event generate $win <> return } } "down" { # Down goes to the node that is vertically below the current node if { [string equal $node ""] } { $win selection set [lindex $nodes 0] _set_current_node $win [lindex $nodes 0] $win see [lindex $nodes 0] + event generate $win <> return } set index [lsearch -exact $nodes $node] incr index if { $index < [llength $nodes] } { $win selection set [lindex $nodes $index] _set_current_node $win [lindex $nodes $index] $win see [lindex $nodes $index] + event generate $win <> return } } "right" { # On a right arrow, if the current node is closed, open it. @@ -1957,10 +1962,11 @@ incr index if { $index < [llength $nodes] } { $win selection set [lindex $nodes $index] _set_current_node $win [lindex $nodes $index] $win see [lindex $nodes $index] + event generate $win <> return } } } else { $win itemconfigure $node -open 1 @@ -1997,10 +2003,11 @@ } } $win selection set $parent _set_current_node $win $parent $win see $parent + event generate $win <> return } } "space" { if { [string equal $node ""] } { @@ -2206,17 +2213,17 @@ } } proc Tree::_node_name { path node } { # Make sure node names are safe as tags and variable names - set map [list & \1 | \2 ^ \3 ! \4 :: \5] + set map [list & \1 | \2 ^ \3 ! \4 : \5] return [string map $map $node] } proc Tree::_node_name_rev { path node } { # Allow reverse interpretation of node names - set map [list \1 & \2 | \3 ^ \4 ! \5 ::] + set map [list \1 & \2 | \3 ^ \4 ! \5 :] return [string map $map $node] } # ---------------------------------------------------------------------------- Index: utils.tcl ================================================================== --- utils.tcl +++ utils.tcl @@ -1,9 +1,9 @@ # ---------------------------------------------------------------------------- # utils.tcl # This file is part of Unifix BWidget Toolkit -# $Id: utils.tcl,v 1.15 2009/06/10 08:48:06 oehhar Exp $ +# $Id: utils.tcl,v 1.15.2.1 2009/09/03 17:29:03 oehhar Exp $ # ---------------------------------------------------------------------------- # Index of commands: # - GlobalVar::exists # - GlobalVar::setvarvar # - GlobalVar::getvarvar @@ -244,14 +244,34 @@ # 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} + + # If the window is not mapped, it may have any current size. + # Then use required size, but bound it to the screen width. + # This is mostly inexact, because any toolbars will still be removed + # which may reduce size. + if { $w == 0 && [winfo ismapped $path] } { + set w [winfo width $path] + } else { + if { $w == 0 } { + set w [winfo reqwidth $path] + } + set vsw [winfo vrootwidth $path] + if { $w > $vsw } { set w $vsw } + } + + if { $h == 0 && [winfo ismapped $path] } { + set h [winfo height $path] + } else { + if { $h == 0 } { + set h [winfo reqheight $path] + } + set vsh [winfo vrootheight $path] + if { $h > $vsh } { set h $vsh } + } set arglen [llength $args] if { $arglen > 3 } { return -code error "BWidget::place: bad number of argument" } @@ -304,12 +324,41 @@ # 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 [winfo rootx $path] + set x0 [expr {($sw - $w)/2}] + set vx [winfo vrootx $path] + set vw [winfo vrootwidth $path] + if {$x < 0 && $vx < 0} { + # We are left to the main screen + # Start of left screen: vx (negative) + # End coordinate of left screen: -1 + # Width of left screen: vx * -1 + # x0 = vx + ( -vx - w ) / 2 + set x0 [expr {($vx - $w)/2}] + } elseif {$x > $sw && $vx+$vw > $sw} { + # We are right to the main screen + # Start of right screen: sw + # End of right screen: vx+vw-1 + # Width of right screen: vx+vw-sw + # x0 = sw + ( vx + vw - sw - w ) / 2 + set x0 [expr {($vx+$vw+$sw-$w)/2}] + } + # Same for y + set y [winfo rooty $path] + set y0 [expr {($sh - $h)/2}] + set vy [winfo vrooty $path] + set vh [winfo vrootheight $path] + if {$y < 0 && $vy < 0} { + # We are above to the main screen + set y0 [expr {($vy - $h)/2}] + } elseif {$y > $sh && $vy+$vh > $sh} { + # We are below to the main screen + set x0 [expr {($vy+$vh-$sh-$h)/2+$sh}] + } } set x "+$x0" set y "+$y0" if {$::tcl_platform(platform) != "windows"} { if { $x0+$w > $sw } {set x "-0"; set x0 [expr {$sw-$w}]} Index: widget.tcl ================================================================== --- widget.tcl +++ widget.tcl @@ -1,9 +1,9 @@ # ---------------------------------------------------------------------------- # widget.tcl # This file is part of Unifix BWidget Toolkit -# $Id: widget.tcl,v 1.35 2009/07/02 16:22:18 oehhar Exp $ +# $Id: widget.tcl,v 1.35.2.1 2011/11/14 14:33:29 oehhar Exp $ # ---------------------------------------------------------------------------- # Index of commands: # - Widget::tkinclude # - Widget::bwinclude # - Widget::declare @@ -54,11 +54,11 @@ # 2. Create frame with appropriate class and command line options # 3. Get initialization options from optionDB, using frame # 4. create subwidgets # Uses newer string operations -package require Tcl 8.1.1 +package require Tcl 8.1.1- namespace eval Widget { variable _optiontype variable _class variable _tk_widget @@ -135,11 +135,10 @@ upvar 0 ${class}::opt classopt upvar 0 ${class}::map classmap upvar 0 ${class}::map$subpath submap upvar 0 ${class}::optionExports exports - set foo [$tkwidget ".ericFoo###"] # 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)] } { @@ -187,11 +186,10 @@ lappend classmap($option) $subpath "" $realopt set submap($realopt) $option } } } - ::destroy $foo } # ---------------------------------------------------------------------------- # Command Widget::bwinclude @@ -369,31 +367,31 @@ set exports($option) $optionDbName set classopt($option) [list $type $value $ro $arg] continue } - # retreive default value for TkResource + # retrieve default value for TkResource if { [string equal $type "TkResource"] } { set tkwidget [lindex $arg 0] - set foo [$tkwidget ".ericFoo##"] set realopt [lindex $arg 1] if { ![string length $realopt] } { set realopt $option } set tkoptions [_get_tkwidget_options $tkwidget] + set ind [lsearch $tkoptions [list $realopt *]] + set optdesc [lindex $tkoptions $ind]; + set tkoptions [_get_tkwidget_options $tkwidget] if { ![string length $value] } { # We initialize default value - set ind [lsearch $tkoptions [list $realopt *]] - set value [lindex [lindex $tkoptions $ind] end] + set value [lindex $optdesc end] } set optionDbName ".[lindex [_configure_option $option ""] 0]" option add *${class}${optionDbName} $value widgetDefault set exports($option) $optionDbName set classopt($option) [list TkResource $value $ro \ [list $tkwidget $realopt]] - set optionClass($option) [lindex [$foo configure $realopt] 1] - ::destroy $foo + set optionClass($option) [lindex $optdesc 1] continue } set optionDbName ".[lindex [_configure_option $option ""] 0]" option add *${class}${optionDbName} $value widgetDefault @@ -402,33 +400,90 @@ set classopt($option) [list $type $value $ro $arg] } } +# ---------------------------------------------------------------------------- +# Command Widget::define +# Declares a new class and loads its dependencies. +# +# Arguments: +# class megawidget class +# filename file where the class resides +# options The following options are supported: +# -classonly Prevents megawidget setup: creation of +# megawidget alias, binding of the +# event and stubbing of the +# 'use' procedure. +# -namespace ns Indicate the namespace where the +# megawidget's procedures reside. Defaults +# to ::${class}. +# dependencies classes the class being defined depends on. +# +# ---------------------------------------------------------------------------- proc Widget::define { class filename args } { variable ::BWidget::use + set classonly 0; + set ns ::${class}; + for {set i 0; set n [llength $args]} {$i < $n} {incr i} { + set option [lindex $args $i]; + switch -- $option { + -classonly { + set classonly 1; + } + -namespace { + incr i; + set ns [lindex $args $i]; + } + default { + # stop processing options + break; + } + } + } + set args [lrange $args $i end] + set use($class) $args set use($class,file) $filename + set use($class,namespace) $ns; lappend use(classes) $class - if {[set x [lsearch -exact $args "-classonly"]] > -1} { - set args [lreplace $args $x $x] - } else { - interp alias {} ::${class} {} ${class}::create - proc ::${class}::use {} {} + # Make sure the class description namespace exists. + namespace eval $class {} + # Make sure the megawidget namespace exists. + namespace eval $ns {} + if {!$classonly} { + interp alias {} ${ns} {} ${ns}::create + proc ${ns}::use {} {} bind $class [list Widget::destroy %W] } - foreach class $args { ${class}::use } + foreach dep $args { + if {![info exists use(${dep},namespace)]} { + # Lazy-loaded modules are not yet loaded (actually that seems to be + # the whole point of this 'use' mechanism.) so they have not configured + # a namespace. Use namespace=class convention. Note that the class MUST + # not be prefixed by ::. + ${dep}::use; + } else { + $use(${dep},namespace)::use; + } + } } proc Widget::create { class path {rename 1} } { if {$rename} { rename $path ::$path:cmd } + + variable ::BWidget::use; + set ns [expr {[info exists use(${class},namespace)] + ? $use(${class},namespace) + : $class}]; + proc ::$path { cmd args } \ - [subst {return \[eval \[linsert \$args 0 ${class}::\$cmd [list $path]\]\]}] + [subst {return \[eval \[linsert \$args 0 ${ns}::\$cmd [list $path]\]\]}] return $path } # ---------------------------------------------------------------------------- @@ -435,11 +490,10 @@ # Command Widget::addmap # ---------------------------------------------------------------------------- proc Widget::addmap { class subclass subpath options } { upvar 0 ${class}::opt classopt upvar 0 ${class}::optionExports exports - upvar 0 ${class}::optionClass optionClass upvar 0 ${class}::map classmap upvar 0 ${class}::map$subpath submap foreach {option realopt} $options { if { ![string length $realopt] } { @@ -457,25 +511,10 @@ lappend classmap($option) $subpath $subclass $realopt set submap($realopt) $option } } - -# ---------------------------------------------------------------------------- -# 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 } { @@ -770,12 +809,19 @@ unset pathinit } if {![string equal [info commands $path] ""]} { rename $path "" } - ## Unset any variables used in this widget. - foreach var [info vars ::${class}::$path:*] { unset $var } + # Unset any variables used in this widget. + # Guard, as some internal classes (Bitmap, LabelEntry, ListBox::Item, + # NoteBook::Page, PanedWindow::Pane, ScrollableFrame, ScrollableFrame, + # ScrollableFrame, Tree::Node, Wizard::Branch, Wizard::Step, Wizard::Widget) + # are declared but not defined. + if {[info exists ::BWidget::use(${class},namespace)]} { + set ns $::BWidget::use(${class},namespace); + foreach var [info vars ${ns}::${path}:*] { unset $var } + } unset _class($path) } @@ -827,12 +873,13 @@ # | * | * | subwidget | window.subpath | current | if { [string length $subclass] && ! [string equal $subclass ":cmd"] } { if { [string equal $subpath ":cmd"] } { set subpath "" } - set curval [${subclass}::cget $window$subpath $realopt] - ${subclass}::configure $window$subpath $realopt $newval + set ns $::BWidget::use(${subclass},namespace); + set curval [${ns}::cget $window$subpath $realopt] + ${ns}::configure $window$subpath $realopt $newval } else { set curval [$window$subpath cget $realopt] $window$subpath configure $realopt $newval } } @@ -1098,20 +1145,33 @@ set optclass [string range $option 1 end] } return [list $optdb $optclass] } +# ---------------------------------------------------------------------------- +# Command Widget::_make_tk_widget_name +# ---------------------------------------------------------------------------- +# Before, the widget meta name was build as: ".#BWidget.#$tkwidget" +# This does not work for ttk widgets, as they have an "::" in their name. +# Thus replace any "::" by "__" will do the job. +proc Widget::_make_tk_widget_name { tkwidget } { + set pos 0 + for {set pos 0} {0 <= [set pos [string first "::" $tkwidget $pos]]} {incr pos} { + set tkwidget [string range $tkwidget 0 [expr {$pos-1}]]__[string range $tkwidget [expr {$pos+2}] end] + } + return ".#BWidget.#$tkwidget" +} # ---------------------------------------------------------------------------- # Command Widget::_get_tkwidget_options # ---------------------------------------------------------------------------- proc Widget::_get_tkwidget_options { tkwidget } { variable _tk_widget variable _optiondb variable _optionclass - set widget ".#BWidget.#$tkwidget" + set widget [_make_tk_widget_name $tkwidget] # encapsulation frame to not pollute '.' childspace if {![winfo exists ".#BWidget"]} { frame ".#BWidget" } if { ![winfo exists $widget] || ![info exists _tk_widget($tkwidget)] } { set widget [$tkwidget $widget] # JDC: Withdraw toplevels, otherwise visible @@ -1160,11 +1220,11 @@ # ---------------------------------------------------------------------------- proc Widget::_test_tkresource { option value arg } { # set tkwidget [lindex $arg 0] # set realopt [lindex $arg 1] foreach {tkwidget realopt} $arg break - set path ".#BWidget.#$tkwidget" + set path [_make_tk_widget_name $tkwidget] set old [$path cget $realopt] $path configure $realopt $value set res [$path cget $realopt] $path configure $realopt $old @@ -1433,11 +1493,11 @@ if {$value == 0} { return 0 } elseif {$value == 1} { return [winfo viewable $w] } else { - set value [uplevel \#0 $value $w] + set value [uplevel \#0 [list $value $w]] if {$value != ""} { return $value } } } @@ -1473,36 +1533,83 @@ focus $w event generate $w <> } +# Widget::which -- +# +# Retrieve a fully qualified variable name for the specified option or +# widget variable. +# +# If the option is not one for which a variable exists, throw an error +# (ie, those options that map directly to widget options). +# +# For widget variables, return the fully qualified name even if the +# variable had not been previously set, in order to allow adding variable +# traces prior to their creation. +# +# Arguments: +# path megawidget to get an option var for. +# type either -option or -variable. +# name name of the option or widget variable. +# +# Results: +# Fully qualified name of the variable for the option or the widget +# variable. +# +proc Widget::which {path args} { + switch -- [llength $args] { + 1 { + set type -option; + set name [lindex $args 0]; + } + 2 { + set type [lindex $args 0]; + set name [lindex $args 1]; + } + default { + return -code error "incorrect number of arguments"; + } + } + + variable _class; + set class $_class($path); + + switch -- $type { + -option { + upvar 0 ${class}::$path:opt pathopt; + + if { ![info exists pathopt($name)] } { + error "unable to find variable for option \"$name\""; + } + + return ::Widget::${class}::${path}:opt(${name}); + } + -variable { + set ns $::BWidget::use(${class},namespace); + return ${ns}::${path}:${name}; + } + } +} + # Widget::varForOption -- # # Retrieve a fully qualified variable name for the option specified. # If the option is not one for which a variable exists, throw an error -# (ie, those options that map directly to widget options). +# (ie, those options that map directly to widget options) Superseded by +# widget::which. # # Arguments: # path megawidget to get an option var for. # option option to get a var for. # # Results: # varname name of the variable, fully qualified, suitable for tracing. proc Widget::varForOption {path option} { - variable _class - variable _optiontype - - set class $_class($path) - upvar 0 ${class}::$path:opt pathopt - - if { ![info exists pathopt($option)] } { - error "unable to find variable for option \"$option\"" - } - set varname "::Widget::${class}::$path:opt($option)" - return $varname + return [::Widget::which $path -option $option]; } # Widget::getVariable -- # # Get a variable from within the namespace of the widget. @@ -1515,12 +1622,13 @@ # Results: # Creates a reference to newVarName in the calling proc. proc Widget::getVariable { path varName {newVarName ""} } { variable _class set class $_class($path) + set ns $::BWidget::use(${class},namespace); if {![string length $newVarName]} { set newVarName $varName } - uplevel 1 [list upvar \#0 ${class}::$path:$varName $newVarName] + uplevel 1 [list ::upvar \#0 ${ns}::${path}:${varName} $newVarName] } # Widget::options -- # # Return a key-value list of options for a widget. This can @@ -1595,16 +1703,13 @@ proc Widget::theme {{bool {}}} { # Private, *experimental* API that may change at any time - JH variable _theme if {[llength [info level 0]] == 2} { # set theme-ability - if {[catch {package require Tk 8.5a6}] - && [catch {package require tile 0.6}] - && [catch {package require tile 1}]} { - return -code error "BWidget's theming requires tile 0.6+" - } else { - catch {style default BWSlim.Toolbutton -padding 0} + if {[catch {package require Ttk}] + && [catch {package require tile 0.8}]} { + return -code error "BWidget's theming requires ttk/tile 0.8+" } set _theme [string is true -strict $bool] } return $_theme } Index: xpm2image.tcl ================================================================== --- xpm2image.tcl +++ xpm2image.tcl @@ -7,21 +7,92 @@ # Copyright 1996 by Roger E. Critchlow Jr., San Francisco, California # All rights reserved, fair use permitted, caveat emptor. # rec@elf.org # # ---------------------------------------------------------------------------- + +proc _xpm-to-image_process_line { line } { + upvar 1 data data + set line [string map {"\t" " "} $line] + + set idx $data(chars_per_pixel) + incr idx -1 + set cname [string range $line 0 $idx] + + + set lend [string trim [string range $line $data(chars_per_pixel) end]] + + ## now replace multiple spaces with just one.. + while {-1 != [string first " " $lend]} { + set lend [string map {" " " "} $lend] + } + set cl [split $lend " "] + + set idx 0 + set clen [llength $cl] + + ## scan through the line, looking for records of type c, g or m + while { $idx < $clen } { + set key [lindex $cl $idx] + if { [string equal $key {}] } { + incr idx + continue + } + + while { ![string equal $key "c"] + && ![string equal $key "m"] + && ![string equal $key "g"] + && ![string equal $key "g4"] + && ![string equal $key ""] + } { + incr idx + set key [lindex $cl $idx] + } + + incr idx + set color [string tolower [lindex $cl $idx]] + + ## one file used opaque to mean black + if { [string equal -nocase $color "opaque"] } { + set color "black" + } + set data(color-$key-$cname) $color + if { [string equal -nocase $color "none"] } { + set data(transparent) $cname + } + incr idx + } + + + 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} failed to define a color" + } +} 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"] { + ## some files have blank lines in them, skip those + ## also, some files indent each line with spaces - remove those + set line [string trim $line] + if { $line eq "" } { continue } + if {[regexp {^"([^\"]*)"} $line all meat]} { if {[string first XPMEXT $meat] == 0} { break } lappend xpm $meat @@ -49,48 +120,37 @@ # # 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 equal -nocase $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" - } + _xpm-to-image_process_line $line } # # extract the image data in the xpm data # set image [image create photo -width $data(width) -height $data(height)] set y 0 + set idx 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}]] + ## see if they lied about the number of colors by not counting + ## "none" in the color count entry + set none 0 + if { ($idx == 0) && ([info exists data(cname-none)]) && \ + ![info exists data(color-$pixel)] } { + ## it appears that way - process this line as another + ## color entry + _xpm-to-image_process_line $line + incr idx + set none 1 + break; + } + incr idx set c $data(color-$pixel) if { [string equal $c none] } { if { [string length $pixels] } { $image put [list $pixels] -to [expr {$x-[llength $pixels]}] $y set pixels {} @@ -98,10 +158,13 @@ } else { lappend pixels $c } set line [string range $line $data(chars_per_pixel) end] incr x + } + if { $none == 1 } { + continue } if { [llength $pixels] } { $image put [list $pixels] -to [expr {$x-[llength $pixels]}] $y } incr y @@ -110,6 +173,5 @@ # # return the image # return $image } -