Possible fix for tkticket 3049518 - Generate <<TkWorldChanged>> event.

4 files changed, 162 insertions, 3 deletions

diff --git a/doc/event.n b/doc/event.n
index 9ab48e5..786dcc6 100644
--- a/doc/event.n
+++ b/doc/event.n
@@ -343,6 +343,15 @@ This is sent to all widgets when the ttk theme changed. The ttk
 widgets listen to this event and redisplay themselves when it fires.
 The legacy widgets ignore this event.
 .TP
+\fB<<TkWorldChanged>>\fR
+.
+For font changes, this event is sent to widgets holding a reference to
+a modified font. The user_data field (%d) will have the value
+"FontChanged".  For other system wide changes, this event will be sent
+to widgets potentially effected by the change, and the user_data field
+will indicate the cause of the change.  NOTE: all tk and ttk widgets
+already handle this event internally.
+.TP
 \fB<<TraverseIn>>\fR
 This is sent to a widget when the focus enters the widget because of a
 user-driven
diff --git a/generic/tkFont.c b/generic/tkFont.c
index 9c157db..d3ef712 100644
--- a/generic/tkFont.c
+++ b/generic/tkFont.c
@@ -897,7 +897,8 @@ RecomputeWidgets(
 {
     Tk_ClassWorldChangedProc *proc =
 	    Tk_GetClassProc(winPtr->classProcsPtr, worldChangedProc);
-
+    TkWindow *tkwinPtr;
+    
     if (proc != NULL) {
 	proc(winPtr->instanceData);
     }
@@ -921,9 +922,16 @@ RecomputeWidgets(
      * of the code below.
      */
 
-    for (winPtr=winPtr->childList ; winPtr!=NULL ; winPtr=winPtr->nextPtr) {
-	RecomputeWidgets(winPtr);
+    for (tkwinPtr=winPtr->childList ; tkwinPtr!=NULL ; tkwinPtr=tkwinPtr->nextPtr) {
+	RecomputeWidgets(tkwinPtr);
     }
+    
+    /* 
+     * Broadcast font change virtually for mega-widget layout managers.
+     * Do this after the font change has been propagated to core widgets. 
+    */
+    TkSendVirtualEvent((Tk_Window)winPtr, "TkWorldChanged",
+		       Tcl_NewStringObj("FontChanged",-1));
 }
 
 /*
diff --git a/generic/tkUtil.c b/generic/tkUtil.c
index 375bb83..3cc8dbf 100644
--- a/generic/tkUtil.c
+++ b/generic/tkUtil.c
@@ -1186,6 +1186,7 @@ TkSendVirtualEvent(
     event.general.xany.display = Tk_Display(target);
     event.virt.name = Tk_GetUid(eventName);
     event.virt.user_data = detail;
+    if (detail) Tcl_IncrRefCount(detail); // Event code will DecrRefCount
 
     Tk_QueueWindowEvent(&event.general, TCL_QUEUE_TAIL);
 }
diff --git a/tests/font.test b/tests/font.test
index 5af2dbb..dd6f539 100644
--- a/tests/font.test
+++ b/tests/font.test
@@ -2408,6 +2408,147 @@ test font-47.1 {Bug f214b8ad5b} -body {
     interp delete two
 } -result {}
 
+test font-47.2 {Bug 3049518 - Canvas} -body {
+    if {"MyFont" ni [font names]} {
+	font create MyFont -family "Liberation Sans" -size 13
+    }
+    set text Hello!
+    destroy .t.c
+    set c [canvas .t.c]
+    set textid [$c create text 20 20 -font MyFont -text $text -anchor nw]
+    set twidth [font measure MyFont $text]
+    set theight [font metrics MyFont -linespace]
+    set circid [$c create polygon \
+		    15                    15 \
+		    [expr {15 + $twidth}] 15 \
+		    [expr {15 + $twidth}] [expr {15 + $theight}] \
+		    15                    [expr {15 + $theight}] \
+		    -width 1 -joinstyle round -smooth true -fill {} -outline blue]
+    pack $c -fill both -expand 1 -side top
+    tkwait visibility $c
+    
+    # Lamda test functions
+    set circle_text {{w user_data text circ} {
+	if {[winfo class $w] ne "Canvas"} {
+	    puts "Wrong widget type: $w"
+	    return
+	}
+	if {$user_data ne "FontChanged"} {
+	    return
+	}
+	lappend ::results called-$w
+	lassign [$w bbox $text] x0 y0 x1 y1
+	set offset 5
+	set coord [lmap expr {
+			      $x0-5 $y0-5   $x1+5 $y0-5
+			      $x1+5 $y1+5   $x0-5 $y1+5
+			  } {expr $expr}]
+	if {[catch {$w coord $circ $coord} err]} {
+	    puts Error:$err
+	}
+    }}
+    set waitfor {{tag {time 333}} {after $time incr ::wait4; vwait ::wait4}}
+    set enclosed {{can id} {$can find enclosed {*}[$can bbox $id]}}
+
+    set results {}
+    apply $circle_text $c FontChanged $textid $circid
+    bind $c <<TkWorldChanged>> [list apply $circle_text %W %d $textid $circid]
+    apply $waitfor 1
+
+    # Begin test:
+    set results {}
+    lappend results [apply $enclosed $c $circid]
+    font configure MyFont -size 26
+    apply $waitfor 2
+    lappend results [apply $enclosed $c $circid]
+    font configure MyFont -size 9
+    apply $waitfor 3
+    lappend results [apply $enclosed $c $circid]
+    apply $waitfor 4
+    font configure MyFont -size 12
+    apply $waitfor 5
+    lappend results [apply $enclosed $c $circid]
+} -cleanup {
+    destroy $c
+    unset -nocomplain ::results
+} -result {{1 2} called-.t.c {1 2} called-.t.c {1 2} called-.t.c {1 2}}
+
+test font-47.3 {Bug 3049518 - Label} -body {
+    if {"MyFont" ni [font names]} {
+	font create MyFont -family "Liberation Sans" -size 13
+    }
+    set text "Label Test"
+    destroy .t.l
+
+    set make-img {{size} {
+	set img [image create photo -width $size -height $size]
+	$img blank
+	set max [expr {$size - 1}]
+	for {set x 0} {$x < $size} {incr x} {
+	    $img put red -to $x $x
+	    $img put black -to 0 $x
+	    $img put black -to $x 0
+	    $img put black -to $max $x
+	    $img put black -to $x $max
+	}
+	return $img
+    }}
+    
+    set testWorldChanged {{w user_data} {
+	global make-img
+	if {$user_data ne "FontChanged"} {
+	    return
+	}
+	if {![winfo exists $w] || [winfo class $w] ne "Label"} {
+	    return
+	}
+	if {[$w cget -image] ne ""} {
+	    image delete [$w cget -image]
+	}
+	set size [font metrics [$w cget -font] -linespace]
+	set img [apply ${make-img} $size]
+	$w configure -image $img
+    }}
+
+    set waitfor {{tag {time 500}} {
+	after $time incr ::wait4
+	vwait ::wait4
+    }}
+
+    set check {{w} {
+	global results
+	set f [$w cget -font]
+	set i [$w cget -image]
+	set fs [font metrics $f -linespace]
+	set ish [image height $i]
+	set isw [image width $i]
+	lappend results [list [expr {$fs == $ish ? 1 : [list $fs $ish]}] [expr {$fs == $isw ? 1 : [list $fs $isw]}]]
+    }}
+
+    set size [font metrics MyFont -linespace]
+    set img [apply ${make-img} $size]
+    set l [label .t.l -compound left -image $img -text $text -font MyFont]
+    pack $l -side top -fill both -expand 1
+    bind $l <<TkWorldChanged>> [list apply $testWorldChanged %W %d]
+    set ::results {}
+
+    apply $waitfor 0
+    apply $check $l
+    font configure MyFont -size 26
+    apply $waitfor 1
+    apply $check $l
+    font configure MyFont -size 9
+    apply $waitfor 2
+    apply $check $l
+    font configure MyFont -size 13
+    apply $waitfor 3
+    apply $check $l
+    set results
+} -cleanup {
+    destroy $l
+    unset -nocomplain ::results
+} -result {{1 1} {1 1} {1 1} {1 1}}
+
 # cleanup
 cleanupTests
 return