Binary files /tmp/RqGKr15_al/bwidget-1.9.6/.fslckout and /tmp/WYZhxTndt2/bwidget-1.9.7/.fslckout differ
diff -Nru bwidget-1.9.6/BWman/ComboBox.html bwidget-1.9.7/BWman/ComboBox.html
--- bwidget-1.9.6/BWman/ComboBox.html 2006-09-28 15:46:06.000000000 +0000
+++ bwidget-1.9.7/BWman/ComboBox.html 2013-09-15 17:42:06.000000000 +0000
@@ -145,6 +145,7 @@
?option? ?value option value ...?
pathName get
+pathName getentry
pathName getlistbox
pathName getvalue
pathName icursor
@@ -315,6 +316,13 @@
+- pathName getentry
+
-
+
+Returns the path to the contained entry widget.
+
+
+
- pathName getlistbox
-
diff -Nru bwidget-1.9.6/BWman/MainFrame.html bwidget-1.9.7/BWman/MainFrame.html
--- bwidget-1.9.6/BWman/MainFrame.html 2011-05-25 15:08:16.000000000 +0000
+++ bwidget-1.9.7/BWman/MainFrame.html 2013-09-15 17:42:06.000000000 +0000
@@ -22,21 +22,24 @@
-progressvar (see -variable) |
+
- WIDGET-SPECIFIC OPTIONS
@@ -83,10 +86,10 @@
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.
@@ -108,33 +111,35 @@
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.
@@ -155,7 +160,7 @@
{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}
}
diff -Nru bwidget-1.9.6/ChangeLog bwidget-1.9.7/ChangeLog
--- bwidget-1.9.6/ChangeLog 2012-07-27 11:36:04.000000000 +0000
+++ bwidget-1.9.7/ChangeLog 2013-09-15 17:42:06.000000000 +0000
@@ -1,3 +1,62 @@
+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 ****
diff -Nru bwidget-1.9.6/combobox.tcl bwidget-1.9.7/combobox.tcl
--- bwidget-1.9.6/combobox.tcl 2012-04-02 09:53:41.000000000 +0000
+++ bwidget-1.9.7/combobox.tcl 2013-09-15 17:42:06.000000000 +0000
@@ -10,6 +10,7 @@
# - ComboBox::setvalue
# - ComboBox::getvalue
# - ComboBox::clearvalue
+# - ComboBox::getentrypath
# - ComboBox::_create_popup
# - ComboBox::_mapliste
# - ComboBox::_unmapliste
@@ -451,6 +452,13 @@
}
# ----------------------------------------------------------------------------
+# Command ComboBox::getentry
+# ----------------------------------------------------------------------------
+proc ComboBox::getentry { path } {
+ return $path.e
+}
+
+# ----------------------------------------------------------------------------
# Command ComboBox::_create_popup
# ----------------------------------------------------------------------------
proc ComboBox::_create_popup { path } {
diff -Nru bwidget-1.9.6/debian/changelog bwidget-1.9.7/debian/changelog
--- bwidget-1.9.6/debian/changelog 2013-05-05 07:38:08.000000000 +0000
+++ bwidget-1.9.7/debian/changelog 2013-09-23 06:21:53.000000000 +0000
@@ -1,3 +1,11 @@
+bwidget (1.9.7-1) unstable; urgency=low
+
+ * New upstream release.
+ * Removed unnecessary build dependency on quilt.
+ * Use debian/install files list instead of copying files in debian/rules.
+
+ -- Sergei Golovan Mon, 23 Sep 2013 10:20:06 +0400
+
bwidget (1.9.6-2) unstable; urgency=low
* Build for unstable.
diff -Nru bwidget-1.9.6/debian/control bwidget-1.9.7/debian/control
--- bwidget-1.9.6/debian/control 2013-05-05 07:38:08.000000000 +0000
+++ bwidget-1.9.7/debian/control 2013-09-23 06:21:53.000000000 +0000
@@ -3,7 +3,7 @@
Priority: optional
Maintainer: Debian Tcl/Tk Packagers
Uploaders: Sergei Golovan
-Build-Depends: debhelper (>= 8.0.0), quilt
+Build-Depends: debhelper (>= 8.0.0)
Build-Depends-Indep: tcl-dev
Standards-Version: 3.9.4
Homepage: http://sourceforge.net/projects/tcllib/
diff -Nru bwidget-1.9.6/debian/examples bwidget-1.9.7/debian/examples
--- bwidget-1.9.6/debian/examples 2013-05-05 07:33:04.000000000 +0000
+++ bwidget-1.9.7/debian/examples 2013-09-23 06:21:53.000000000 +0000
@@ -1,2 +1 @@
-demo/*.tcl
-demo/*.xbm
+demo/*
diff -Nru bwidget-1.9.6/debian/install bwidget-1.9.7/debian/install
--- bwidget-1.9.6/debian/install 1970-01-01 00:00:00.000000000 +0000
+++ bwidget-1.9.7/debian/install 2013-09-23 06:21:53.000000000 +0000
@@ -0,0 +1,4 @@
+*.tcl /usr/share/tcltk/bwidget1.9.7
+images /usr/share/tcltk/bwidget1.9.7
+lang /usr/share/tcltk/bwidget1.9.7
+BWman/* /usr/share/doc/bwidget/html
diff -Nru bwidget-1.9.6/debian/rules bwidget-1.9.7/debian/rules
--- bwidget-1.9.6/debian/rules 2013-05-05 07:38:08.000000000 +0000
+++ bwidget-1.9.7/debian/rules 2013-09-23 06:21:53.000000000 +0000
@@ -1,18 +1,10 @@
#!/usr/bin/make -f
-v = 1.9.6
+v = 1.9.7
%:
dh $@
-override_dh_auto_install:
- # $(MAKE) install prefix=`pwd`/debian/bwidget/usr \
- # HTMLDIR=`pwd`/debian/bwidget/usr/share/doc/bwidget/html
- mkdir debian/bwidget/usr/share/tcltk/bwidget$(v)
- cp -R *.tcl lang images debian/bwidget/usr/share/tcltk/bwidget$(v)
- rm -rf debian/bwidget/usr/share/tcltk/bwidget$(v)/images/CVS
- cp BWman/* debian/bwidget/usr/share/doc/bwidget/html
-
override_dh_compress:
dh_compress -X.tcl -X.xbm
@@ -20,8 +12,12 @@
tcltk-depends
dh_installdeb
+override_dh_fixperms:
+ chmod a-x debian/bwidget/usr/share/tcltk/bwidget$(v)/lang/*
+ dh_fixperms
+
get-orig-source:
wget -O bwidget_$(v).orig.tar.gz \
http://prdownloads.sourceforge.net/tcllib/bwidget-$(v).tar.gz
-.PHONY: override_dh_auto_install override_dh_compress override_dh_installdeb get-orig-source
+.PHONY: override_dh_compress override_dh_installdeb override_dh_fixperms get-orig-source
diff -Nru bwidget-1.9.6/init.tcl bwidget-1.9.7/init.tcl
--- bwidget-1.9.6/init.tcl 2010-08-04 14:35:54.000000000 +0000
+++ bwidget-1.9.7/init.tcl 2013-09-15 17:42:06.000000000 +0000
@@ -31,17 +31,18 @@
# Try to load lang file corresponding to current msgcat locale
proc Widget::_opt_lang {} {
- set langfile [file join $::BWIDGET::LIBRARY "lang" "en.rc"]
if {0 != [llength [info commands ::msgcat::mcpreferences]]} {
- foreach lang [::msgcat::mcpreferences] {
- set l [file join $::BWIDGET::LIBRARY "lang" "$lang.rc"]
- if {[file readable $l]} {
- set langfile $l
- break
- }
+ 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
}
}
- option read $langfile
}
Widget::_opt_lang
diff -Nru bwidget-1.9.6/labelentry.tcl bwidget-1.9.7/labelentry.tcl
--- bwidget-1.9.6/labelentry.tcl 2011-02-14 16:56:09.000000000 +0000
+++ bwidget-1.9.7/labelentry.tcl 2013-09-15 17:42:06.000000000 +0000
@@ -58,7 +58,10 @@
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
}
diff -Nru bwidget-1.9.6/mainframe.tcl bwidget-1.9.7/mainframe.tcl
--- bwidget-1.9.6/mainframe.tcl 2011-05-25 15:10:07.000000000 +0000
+++ bwidget-1.9.7/mainframe.tcl 2013-09-15 17:42:06.000000000 +0000
@@ -38,13 +38,13 @@
}
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}
+ {-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}
@@ -203,7 +203,8 @@
# 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 {}
@@ -627,7 +628,16 @@
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
@@ -663,25 +673,39 @@
# 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]
@@ -689,30 +713,94 @@
# 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]
}
diff -Nru bwidget-1.9.6/notebook.tcl bwidget-1.9.7/notebook.tcl
--- bwidget-1.9.6/notebook.tcl 2011-04-26 14:13:24.000000000 +0000
+++ bwidget-1.9.7/notebook.tcl 2013-09-15 17:42:06.000000000 +0000
@@ -1107,12 +1107,22 @@
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 } {
+ 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
}
- set data(realized) 1
}
NoteBook::_redraw $path
diff -Nru bwidget-1.9.6/pkgIndex.tcl bwidget-1.9.7/pkgIndex.tcl
--- bwidget-1.9.6/pkgIndex.tcl 2012-07-27 11:43:26.000000000 +0000
+++ bwidget-1.9.7/pkgIndex.tcl 2013-09-15 17:42:06.000000000 +0000
@@ -1,7 +1,7 @@
if {[catch {package require Tcl}]} return
-package ifneeded BWidget 1.9.6 "\
+package ifneeded BWidget 1.9.7 "\
package require Tk 8.1.1;\
- [list tclPkgSetup $dir BWidget 1.9.6 {
+ [list tclPkgSetup $dir BWidget 1.9.7 {
{arrow.tcl source {ArrowButton ArrowButton::create ArrowButton::use}}
{labelframe.tcl source {LabelFrame LabelFrame::create LabelFrame::use}}
{labelentry.tcl source {LabelEntry LabelEntry::create LabelEntry::use}}
@@ -35,7 +35,6 @@
{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}}
}]; \
diff -Nru bwidget-1.9.6/widget.tcl bwidget-1.9.7/widget.tcl
--- bwidget-1.9.6/widget.tcl 2011-11-14 14:33:29.000000000 +0000
+++ bwidget-1.9.7/widget.tcl 2013-09-15 17:42:06.000000000 +0000
@@ -1100,6 +1100,19 @@
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
@@ -1109,7 +1122,7 @@
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)] } {
@@ -1162,7 +1175,7 @@
# 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]
diff -Nru bwidget-1.9.6/xpm2image.tcl bwidget-1.9.7/xpm2image.tcl
--- bwidget-1.9.6/xpm2image.tcl 2004-09-09 22:17:03.000000000 +0000
+++ bwidget-1.9.7/xpm2image.tcl 2013-09-15 17:42:06.000000000 +0000
@@ -10,16 +10,87 @@
#
# ----------------------------------------------------------------------------
+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
@@ -51,32 +122,7 @@
# 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
}
#
@@ -84,11 +130,25 @@
#
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] } {
@@ -101,6 +161,9 @@
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
}
@@ -112,4 +175,3 @@
#
return $image
}
-