arcadia 0.13.0 → 0.13.1

data/tcl/{bwidget-1.9.6 → bwidget-1.9.7}/init.tcl

@@ -31,17 +31,18 @@ Widget::_opt_defaults
 
 # 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
 

data/tcl/{bwidget-1.9.6 → bwidget-1.9.7}/labelentry.tcl

@@ -58,7 +58,10 @@ proc LabelEntry::create { path args } {
 
     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
 }
 
 

data/tcl/{bwidget-1.9.6 → bwidget-1.9.7}/mainframe.tcl

@@ -38,13 +38,13 @@ namespace eval MainFrame {
     }
 
     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 @@ proc MainFrame::configure { path args } {
 
     # 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 @@ proc MainFrame::_create_entries { path menu menuopts entries } {
         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 @@ proc MainFrame::_parse_name { menuname } {
 # 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 @@ proc MainFrame::_parse_accelerator { desc } {
 	# 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 "<Key-$key>"
+	    set accel "$upc"
+	    set events [list "<Key-$key>"]
+	    if {$fKey} {
+		set blockEvents [list "<Shift-Key-$key>"]
+	    }
+	}
+	Shift {
+	    # Used only with Function keys.
+	    set accel "Shift+$upc"
+	    set events [list "<Shift-Key-$key>"]
+	}
+	Cmd {
+	    set accel "Cmd+$upc"
+
+	    if {    [string equal [tk windowingsystem] "aqua"] &&
+		   ([string first AppKit [winfo server .]] == -1)
+	    } {
+		# Carbon
+	        set events [list "<Command-Key-$key>" \
+	                    "<Lock-Command-Key-$upc>" ]
+		set blockEvents [list "<Lock-Shift-Command-Key-$upc>"]
+		# 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 "<Command-Key-$key>"]
+	        # A binding to "<Lock-Command-Key-$upc>" must not be included
+	        # here - both events fire if "Lock" is set.
+		set blockEvents [list "<Shift-Command-Key-$key>"]
+	    }
+	}
+	ShiftCmd {
+	    if {    [string equal [tk windowingsystem] "aqua"] &&
+		    ([string first AppKit [winfo server .]] == -1)
+	    } {
+		# Carbon
+		set accel "Shift+Cmd+$upc"
+		set events [list "<Shift-Command-Key-$upc>" \
+			    "<Lock-Shift-Command-Key-$upc>"]
+		# 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 "<Shift-Command-Key-$key>"]
+		# A binding to "<Lock-Shift-Command-Key-$key>" must not be
+		# included here - both events fire if "Lock" is set.
+		# Tk/Cocoa fails to recognize
+		# <Lock-Shift-Command-Key-$key> as a "more specialized" binding
+		# than <Shift-Command-Key-$key>.
+		# Perversely, Tk/Carbon (above) makes the opposite error.
+	    }
 	}
 	Ctrl {
-	    set accel "Ctrl+[string toupper $key]"
-	    set event "<Control-Key-$key>"
+	    set accel "Ctrl+$upc"
+	    set events [list "<Control-Key-$key>"]
 	}
 	Alt {
-	    set accel "Alt+[string toupper $key]"
-	    set event "<Alt-Key-$key>"
+	    set accel "Alt+$upc"
+	    set events [list "<Alt-Key-$key>"]
 	}
 	CtrlAlt {
-	    set accel "Ctrl+Alt+[string toupper $key]"
-	    set event "<Control-Alt-Key-$key>"
+	    set accel "Ctrl+Alt+$upc"
+	    set events [list "<Control-Alt-Key-$key>"]
 	}
 	default {
 	    return -code error "invalid accelerator code $seq"
 	}
     }
-    return [list $accel $event]
+
+    return [list $accel $events $blockEvents]
 }

data/tcl/{bwidget-1.9.6 → bwidget-1.9.7}/notebook.tcl

@@ -1107,12 +1107,22 @@ 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 } {
+	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

data/tcl/{bwidget-1.9.6 → bwidget-1.9.7}/pkgIndex.tcl

@@ -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 @@ package ifneeded BWidget 1.9.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}}
 }]; \

data/tcl/{bwidget-1.9.6 → bwidget-1.9.7}/widget.tcl

@@ -1100,6 +1100,19 @@ proc Widget::_configure_option { option altopt } {
     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 @@ proc Widget::_get_tkwidget_options { tkwidget } {
     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 @@ 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]

data/tcl/{bwidget-1.9.6 → bwidget-1.9.7}/xpm2image.tcl

@@ -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 @@ proc xpm-to-image { file } {
     # 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 @@ proc xpm-to-image { file } {
     #
     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 @@ proc xpm-to-image { file } {
             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 @@ proc xpm-to-image { file } {
     #
     return $image
 }
-