[Tkabber-dev] r737 - in trunk/tkabber: . ifacetk plugins/general plugins/unix

tkabber-svn at jabber.ru tkabber-svn at jabber.ru
Sat Sep 30 17:20:22 MSD 2006


Author: sergei
Date: 2006-09-30 17:20:00 +0400 (Sat, 30 Sep 2006)
New Revision: 737

Modified:
   trunk/tkabber/ChangeLog
   trunk/tkabber/balloon.tcl
   trunk/tkabber/browser.tcl
   trunk/tkabber/disco.tcl
   trunk/tkabber/emoticons.tcl
   trunk/tkabber/ifacetk/systray.tcl
   trunk/tkabber/messages.tcl
   trunk/tkabber/plugins/general/headlines.tcl
   trunk/tkabber/plugins/unix/dockingtray.tcl
   trunk/tkabber/plugins/unix/systray.tcl
   trunk/tkabber/plugins/unix/tktray.tcl
   trunk/tkabber/plugins/unix/wmdock.tcl
   trunk/tkabber/utils.tcl
Log:
	* balloon.tcl: Added function balloon::setup, which is useful
	  for registering common balloons with static or dynamic texts.
	  Slightly changed syntax of balloon::default_balloon procedure.
	  Destroy balloon when mouse moves over it (workaround for
	  sometimes freezing balloons).

	* emoticons.tcl: Used new syntax of balloon::default_balloon.

	* browser.tcl, disco.tcl, ifacetk/systray.tcl, messages.tcl,
	  plugins/general/headlines.tcl, plugins/unix/dockingtray.tcl,
	  plugins/unix/systray.tcl, plugins/unix/tktray.tcl,
	  plugins/unix/wmdock.tcl, utils.tcl: Switched to balloon::setup
	  when defining balloons.


Modified: trunk/tkabber/ChangeLog
===================================================================
--- trunk/tkabber/ChangeLog	2006-09-30 13:19:18 UTC (rev 736)
+++ trunk/tkabber/ChangeLog	2006-09-30 13:20:00 UTC (rev 737)
@@ -1,3 +1,19 @@
+2006-09-30  Sergei Golovan  <sgolovan at nes.ru>
+
+	* balloon.tcl: Added function balloon::setup, which is useful
+	  for registering common balloons with static or dynamic texts.
+	  Slightly changed syntax of balloon::default_balloon procedure.
+	  Destroy balloon when mouse moves over it (workaround for
+	  sometimes freezing balloons).
+
+	* emoticons.tcl: Used new syntax of balloon::default_balloon.
+
+	* browser.tcl, disco.tcl, ifacetk/systray.tcl, messages.tcl,
+	  plugins/general/headlines.tcl, plugins/unix/dockingtray.tcl,
+	  plugins/unix/systray.tcl, plugins/unix/tktray.tcl,
+	  plugins/unix/wmdock.tcl, utils.tcl: Switched to balloon::setup
+	  when defining balloons.
+
 2006-09-29  Sergei Golovan  <sgolovan at nes.ru>
 
 	* custom.tcl: Added new variable type 'options'. GUI for this

Modified: trunk/tkabber/balloon.tcl
===================================================================
--- trunk/tkabber/balloon.tcl	2006-09-30 13:19:18 UTC (rev 736)
+++ trunk/tkabber/balloon.tcl	2006-09-30 13:20:00 UTC (rev 737)
@@ -10,7 +10,10 @@
 
 toplevel .balloon -relief flat -bd 1 -class Balloon
 .balloon configure -background [option get .balloon foreground Balloon]
-    
+
+bind .balloon <Any-Motion> \
+	 [list balloon::default_balloon .balloon leave %X %Y]
+
 pack [message .balloon.text \
 	  -bg [option get .balloon background Balloon] \
 	  -fg [option get .balloon foreground Balloon] \
@@ -153,15 +156,40 @@
     }
 }
 
-proc balloon::default_balloon {w action X Y {body ""} args} {
+proc balloon::default_balloon {w action X Y args} {
+    set sw $w
+    set text ""
+    set command ""
+    set newargs $args
+    # $args may contain odd number of members, so a bit uncommon parsing
+    set idx 0
+    foreach {opt val} $args {
+	switch -- $opt {
+	    -text {
+		set text $val
+		set newargs [lreplace $newargs $idx [expr {$idx + 1}]]
+	    }
+	    -command {
+		set command $val
+		set newargs [lreplace $newargs $idx [expr {$idx + 1}]]
+	    }
+	    default {
+		incr idx 2
+	    }
+	}
+    }
 
+    if {$command != ""} {
+	set newargs [lassign [eval $command $newargs] sw text]
+    }
+
     switch -- $action {
         enter {
-            eval balloon::set_text [list $body] $args
+            eval [list balloon::set_text $text] $newargs
         }
 
         motion {
-            balloon::on_mouse_move $w $X $Y
+            balloon::on_mouse_move $sw $X $Y
         }
 
         leave {
@@ -169,3 +197,24 @@
         }
     }
 }
+
+proc balloon::setup {w args} {
+    # Try to bind in Tree widget
+    if {![catch {
+	      $w bindText <Any-Enter> \
+		   [list eval [list [namespace current]::default_balloon $w enter %X %Y] $args]
+	 }]} {
+	$w bindText <Any-Motion> \
+	     [list eval [list [namespace current]::default_balloon $w motion %X %Y] $args]
+	$w bindText <Any-Leave> \
+	     [list balloon::default_balloon $w leave %X %Y]
+    } else {
+	bind $w <Any-Enter> \
+	     [list eval [list [namespace current]::default_balloon $w enter %X %Y] $args]
+	bind $w <Any-Motion> \
+	     [list eval [list [namespace current]::default_balloon $w motion %X %Y] $args]
+	bind $w <Any-Leave> \
+	     [list balloon::default_balloon $w leave %X %Y]
+    }
+}
+

Modified: trunk/tkabber/browser.tcl
===================================================================
--- trunk/tkabber/browser.tcl	2006-09-30 13:19:18 UTC (rev 736)
+++ trunk/tkabber/browser.tcl	2006-09-30 13:20:00 UTC (rev 737)
@@ -74,9 +74,7 @@
     set browser(tree,$bw) $tw
     $tw bindText <Double-ButtonPress-1> [list browser::textaction $bw]
     $tw bindText <ButtonPress-3>        [list browser::textpopup $bw]
-    $tw bindText <Any-Enter>  [list browser::textballoon $bw enter  %X %Y]
-    $tw bindText <Any-Motion> [list browser::textballoon $bw motion %X %Y]
-    $tw bindText <Any-Leave>  [list browser::textballoon $bw leave  %X %Y]
+    balloon::setup $tw -command [list browser::textballoon $bw]
 
     bindscroll $tw.c
 
@@ -615,32 +613,19 @@
     }
 }
 
-proc browser::textballoon {bw action X Y node} {
+proc browser::textballoon {bw node} {
     variable browser
 
     set tw $browser(tree,$bw)
-    set data [$tw itemcget $node -data]
-    set data2 [lassign $data type]
+    set data [lassign [$tw itemcget $node -data] \
+		      type jid category subtype name version]
     if {$type == "jid"} {
-	    lassign $data2 jid category type name version
+	return [list $bw:$node \
+		     [item_balloon_text \
+			  $bw $jid $category $subtype $name $version]]
     } else {
-	return
+	return [list $bw:$node ""]
     }
-
-    switch -- $action {
-	enter {
-	    balloon::set_text \
-		[item_balloon_text $bw $jid $category $type $name $version]
-	}
-	motion {
-	    balloon::on_mouse_move \
-		[item_balloon_text $bw $jid $category $type $name $version] \
-		$X $Y
-	}
-	leave {
-	    balloon::destroy
-	}
-    }
 }
 
 proc browser::draginitcmd {t node top} {

Modified: trunk/tkabber/disco.tcl
===================================================================
--- trunk/tkabber/disco.tcl	2006-09-30 13:19:18 UTC (rev 736)
+++ trunk/tkabber/disco.tcl	2006-09-30 13:20:00 UTC (rev 737)
@@ -533,12 +533,7 @@
 	[list [namespace current]::textaction $w]
     $tw bindText <ButtonPress-3> \
 	[list [namespace current]::textpopup $w]
-    $tw bindText <Any-Enter>  \
-	[list [namespace current]::textballoon $w enter  %X %Y]
-    $tw bindText <Any-Motion> \
-	[list [namespace current]::textballoon $w motion %X %Y]
-    $tw bindText <Any-Leave>  \
-	[list [namespace current]::textballoon $w leave  %X %Y]
+    balloon::setup $tw -command [list [namespace current]::textballoon $w]
     bindscroll $tw.c
 
     # HACK
@@ -1191,38 +1186,24 @@
 }
 
 # TODO
-proc disco::browser::textballoon {bw action X Y node} {
+proc disco::browser::textballoon {bw node} {
     variable disco
     variable browser
 
     set tw $browser(tree,$bw)
 
-    if {[catch { set data [$tw itemcget $node -data] }]} {
-	balloon::destroy
-	return
+    if {[catch {set data [$tw itemcget $node -data]}]} {
+	return [list $bw:$node ""]
     }
 
-    set data2 [lassign $data type]
+    lassign $data type jid category subtype name version
+    puts $type
     if {$type == "jid"} {
-	    lassign $data2 jid category type name version
+	return [list $bw:$node \
+		     [item_balloon_text $jid $category $subtype $name $version]]
     } else {
-	return
+	return [list $bw:$node ""]
     }
-
-    switch -- $action {
-	enter {
-	    balloon::set_text \
-		[item_balloon_text $jid $category $type $name $version]
-	}
-	motion {
-	    balloon::on_mouse_move \
-		[item_balloon_text $jid $category $type $name $version] \
-		$X $Y
-	}
-	leave {
-	    balloon::destroy
-	}
-    }
 }
 
 proc disco::browser::goto {bw jid node} {

Modified: trunk/tkabber/emoticons.tcl
===================================================================
--- trunk/tkabber/emoticons.tcl	2006-09-30 13:19:18 UTC (rev 736)
+++ trunk/tkabber/emoticons.tcl	2006-09-30 13:20:00 UTC (rev 737)
@@ -192,7 +192,8 @@
 		}
 
                 balloon::default_balloon $w enter [set lastX $X] \
-			[set lastY $Y] [set lasttext $text]
+						  [set lastY $Y] \
+						  -text [set lasttext $text]
             }
         }
 
@@ -201,7 +202,7 @@
         }
     }
 
-    balloon::default_balloon $w $action $X $Y $text
+    balloon::default_balloon $w $action $X $Y -text $text
 }
 
 proc emoteicons::insert {iw text} {

Modified: trunk/tkabber/ifacetk/systray.tcl
===================================================================
--- trunk/tkabber/ifacetk/systray.tcl	2006-09-30 13:19:18 UTC (rev 736)
+++ trunk/tkabber/ifacetk/systray.tcl	2006-09-30 13:20:00 UTC (rev 737)
@@ -350,8 +350,8 @@
 
 ##########################################################################
 
-proc systray::wrap_balloon {icon ev x y} {
-    ::balloon::default_balloon $icon $ev $x $y [balloon_text]
+proc systray::balloon {icon} {
+    return [list $icon [balloon_text]]
 }
 
 ##########################################################################

Modified: trunk/tkabber/messages.tcl
===================================================================
--- trunk/tkabber/messages.tcl	2006-09-30 13:19:18 UTC (rev 736)
+++ trunk/tkabber/messages.tcl	2006-09-30 13:20:00 UTC (rev 737)
@@ -259,11 +259,7 @@
     set cb [button $f.user$row -text $url \
                 -command [list ft::http::recv_file_dialog \
 			      $from [list $url] $desc]]
-    bind $cb <Any-Enter>  [list balloon::default_balloon $cb enter  %X %Y \
-                                $desc]
-    bind $cb <Any-Motion> [list balloon::default_balloon $cb motion %X %Y \
-                                $desc]
-    bind $cb <Any-Leave>  [list balloon::default_balloon $cb leave  %X %Y]
+    balloon::setup $cb -text $desc
     grid $f.luser$row -row $row -column 0 -sticky e
     grid $f.user$row  -row $row -column 1 -sticky ew
 

Modified: trunk/tkabber/plugins/general/headlines.tcl
===================================================================
--- trunk/tkabber/plugins/general/headlines.tcl	2006-09-30 13:19:18 UTC (rev 736)
+++ trunk/tkabber/plugins/general/headlines.tcl	2006-09-30 13:20:00 UTC (rev 737)
@@ -176,12 +176,7 @@
                 [list [namespace current]::select_popup $hw]
         $tw bindText <Double-ButtonPress-1> \
                 [list [namespace current]::action browse $hw]
-        $tw bindText <Any-Enter>  \
-                [list [namespace current]::balloon $hw enter  %X %Y]
-        $tw bindText <Any-Motion> \
-                [list [namespace current]::balloon $hw motion %X %Y]
-        $tw bindText <Any-Leave>  \
-                [list [namespace current]::balloon $hw leave  %X %Y]
+	balloon::setup $tw -command [list [namespace current]::balloon $hw]
 
         # HACK
         bind $tw.c <Return> \
@@ -569,9 +564,9 @@
     }
 }
 
-proc headlines::balloon {hw action X Y node} {
-    if {[catch { array set props [$hw.tree itemcget $node -data] }]} {
-        return
+proc headlines::balloon {hw node} {
+    if {[catch {array set props [$hw.tree itemcget $node -data]}]} {
+        return [list $hw:$node ""]
     }
 
     set width [expr {[winfo width $hw.tree] * 0.8}]
@@ -582,13 +577,11 @@
     switch -- $props(type) {
         article {
             if {![cequal $props(body) ""]} {
-                balloon::default_balloon $hw:$node $action $X $Y $props(body) -width $width
+                return [list $hw:$node $props(body) -width $width]
             }
         }
-
-        default {
-        }
     }
+    return [list $hw:$node ""]
 }
 
 proc headlines::save {} {

Modified: trunk/tkabber/plugins/unix/dockingtray.tcl
===================================================================
--- trunk/tkabber/plugins/unix/dockingtray.tcl	2006-09-30 13:19:18 UTC (rev 736)
+++ trunk/tkabber/plugins/unix/dockingtray.tcl	2006-09-30 13:20:00 UTC (rev 737)
@@ -72,10 +72,7 @@
 
     bind $mb <ButtonRelease-1> ifacetk::systray::toggle_state
     bind $mb <ButtonRelease-3> [list tk_popup $m %X %Y]
-
-    bind $icon <Any-Enter>  [list ifacetk::systray::wrap_balloon $icon enter  %X %Y]
-    bind $icon <Any-Motion> [list ifacetk::systray::wrap_balloon $icon motion %X %Y]
-    bind $icon <Any-Leave>  [list ifacetk::systray::wrap_balloon $icon leave  %X %Y]
+    balloon::setup $icon -command [list ifacetk::systray::balloon $icon]
 }
 
 ##########################################################################

Modified: trunk/tkabber/plugins/unix/systray.tcl
===================================================================
--- trunk/tkabber/plugins/unix/systray.tcl	2006-09-30 13:19:18 UTC (rev 736)
+++ trunk/tkabber/plugins/unix/systray.tcl	2006-09-30 13:20:00 UTC (rev 737)
@@ -72,10 +72,7 @@
 
     bind $icon <ButtonRelease-1> ifacetk::systray::toggle_state
     bind $icon <ButtonRelease-3> [list tk_popup $m %X %Y]
-
-    bind $icon <Any-Enter>  [list ifacetk::systray::wrap_balloon $icon enter  %X %Y]
-    bind $icon <Any-Motion> [list ifacetk::systray::wrap_balloon $icon motion %X %Y]
-    bind $icon <Any-Leave>  [list ifacetk::systray::wrap_balloon $icon leave  %X %Y]
+    balloon::setup $icon -command [list ifacetk::systray::balloon $icon]
 }
 
 ##########################################################################

Modified: trunk/tkabber/plugins/unix/tktray.tcl
===================================================================
--- trunk/tkabber/plugins/unix/tktray.tcl	2006-09-30 13:19:18 UTC (rev 736)
+++ trunk/tkabber/plugins/unix/tktray.tcl	2006-09-30 13:20:00 UTC (rev 737)
@@ -66,13 +66,7 @@
 
     bind $icon <ButtonRelease-1> ifacetk::systray::toggle_state
     bind $icon <ButtonRelease-3> [list tk_popup $m %X %Y]
-
-    bind $icon <Any-Enter>  \
-	 [list ifacetk::systray::wrap_balloon $icon enter  %X %Y]
-    bind $icon <Any-Motion> \
-	 [list ifacetk::systray::wrap_balloon $icon motion %X %Y]
-    bind $icon <Any-Leave>  \
-	 [list ifacetk::systray::wrap_balloon $icon leave  %X %Y]
+    balloon::setup $icon -command [list ifacetk::systray::balloon $icon]
 }
 
 ##########################################################################

Modified: trunk/tkabber/plugins/unix/wmdock.tcl
===================================================================
--- trunk/tkabber/plugins/unix/wmdock.tcl	2006-09-30 13:19:18 UTC (rev 736)
+++ trunk/tkabber/plugins/unix/wmdock.tcl	2006-09-30 13:20:00 UTC (rev 737)
@@ -109,12 +109,10 @@
     }
 }
 
-proc ::wmdock::dock_balloon {ev x y} {
+proc ::wmdock::balloon {} {
     variable balloon_msg
 
-    if {![winfo exists .icon]} return
-
-    balloon::default_balloon .icon $ev $x $y $balloon_msg
+    return [list .icon $balloon_msg]
 }
 
 proc ::wmdock::create_dock {} {
@@ -134,10 +132,7 @@
     pack .icon.c
     
     bind .icon <3> ::wmdock::showhide
-    
-    bind .icon <Any-Enter>  [list ::wmdock::dock_balloon enter %X %Y]
-    bind .icon <Any-Motion> [list ::wmdock::dock_balloon motion %X %Y]
-    bind .icon <Any-Leave>  [list balloon::default_balloon .icon leave  %X %Y]
+    balloon::setup .icon -command [list ::wmdock::balloon]
 }
 
 hook::add postload_hook ::wmdock::create_dock 80

Modified: trunk/tkabber/utils.tcl
===================================================================
--- trunk/tkabber/utils.tcl	2006-09-30 13:19:18 UTC (rev 736)
+++ trunk/tkabber/utils.tcl	2006-09-30 13:20:00 UTC (rev 737)
@@ -349,11 +349,7 @@
 	bind $cb <1> [list focus %W]
 	bindscroll $cb $sf
 	if {[info exists balloons($idx)]} {
-	    bind $cb <Any-Enter>  [list balloon::default_balloon $cb enter  %X %Y \
-				       $balloons($idx)]
-	    bind $cb <Any-Motion> [list balloon::default_balloon $cb motion %X %Y \
-				       $balloons($idx)]
-	    bind $cb <Any-Leave>  [list balloon::default_balloon $cb leave  %X %Y]
+	    balloon::setup $cb -text $balloons($idx)
 	}
 	pack $cb -anchor w
 	incr i



More information about the Tkabber-dev mailing list