[Tkabber-dev] r1655 - in trunk/tkabber: . ifacetk plugins/roster

tkabber-svn at jabber.ru tkabber-svn at jabber.ru
Sat Feb 14 21:55:09 MSK 2009


Author: sergei
Date: 2009-02-14 21:55:08 +0300 (Sat, 14 Feb 2009)
New Revision: 1655

Added:
   trunk/tkabber/plugins/roster/metacontacts.tcl
Modified:
   trunk/tkabber/ChangeLog
   trunk/tkabber/ifacetk/iroster.tcl
Log:
	* plugins/roster/metacontacts.tcl: Added UI for creating, editind and
	  deleting metacontacts.

	* ifacetk/iroster.tcl: Take into account menu items state when joining
	  menus for contacts and metacontacts.


Modified: trunk/tkabber/ChangeLog
===================================================================
--- trunk/tkabber/ChangeLog	2009-02-14 14:33:36 UTC (rev 1654)
+++ trunk/tkabber/ChangeLog	2009-02-14 18:55:08 UTC (rev 1655)
@@ -10,6 +10,12 @@
 	  in all groups of its members. Fixed creating JID popup menu on
 	  metacontacts. Added processing of radiobuttons to popup menus.
 
+	* plugins/roster/metacontacts.tcl: Added UI for creating, editind and
+	  deleting metacontacts.
+
+	* ifacetk/iroster.tcl: Take into account menu items state when joining
+	  menus for contacts and metacontacts.
+
 2009-02-13  Sergei Golovan  <sgolovan at nes.ru>
 
 	* muc.tcl: Move focus and scroll down to 'add new JID' field in MUC

Modified: trunk/tkabber/ifacetk/iroster.tcl
===================================================================
--- trunk/tkabber/ifacetk/iroster.tcl	2009-02-14 14:33:36 UTC (rev 1654)
+++ trunk/tkabber/ifacetk/iroster.tcl	2009-02-14 18:55:08 UTC (rev 1655)
@@ -1816,6 +1816,7 @@
 ###############################################################################
 
 proc roster::get_popup_command_list {m prefix suffix label jids args} {
+    set command_list0 {}
     set command_list1 {}
     set command_list2 {}
     foreach jid $jids {
@@ -1826,15 +1827,19 @@
 	    foreach opt $args {
 		lappend command [$m1 entrycget $idx $opt]
 	    }
+	    lappend command_list0 [list $label $command]
 	    lappend command_list1 [list $jid $command]
 	    lappend command_list2 [list $bjid $command]
 	}
     }
 
+    set command_list0 [lsort -unique $command_list0]
     set command_list2 [lsort -unique $command_list2]
     set command_list3 [lsort -unique -index 0 $command_list2]
 
-    if {[llength $command_list2] != [llength $command_list3]} {
+    if {[llength $command_list0] == 1} {
+	return $command_list0
+    } elseif {[llength $command_list2] != [llength $command_list3]} {
 	return $command_list1
     } else {
 	return $command_list2
@@ -1843,24 +1848,28 @@
 
 proc roster::add_command_submenu {m prefix suffix i label jids} {
     set command_list [get_popup_command_list $m $prefix $suffix $label $jids \
-					     -command]
+					     -command -state]
     if {[llength $command_list] > 1} {
 	set m2 [menu $m.$i -tearoff 0]
 	$m add cascade -label $label -menu $m2
 
 	foreach jid_command $command_list {
 	    lassign $jid_command jid command
-	    $m2 add command -label $jid -command [lindex $command 0]
+	    $m2 add command -label $jid \
+			    -command [lindex $command 0] \
+			    -state [lindex $command 1]
 	}
     } else {
+	lassign [lindex [lindex $command_list 0] 1] command state
 	$m add command -label $label \
-		       -command [lindex [lindex [lindex $command_list 0] 1] 0]
+		       -command $command \
+		       -state $state
     }
 }
 
 proc roster::add_checkbutton_submenu {m prefix suffix i label jids} {
     set command_list [get_popup_command_list $m $prefix $suffix $label $jids \
-					     -variable -command]
+					     -variable -command -state]
 
     if {[llength $command_list] > 1} {
 	set m2 [menu $m.$i -tearoff 0]
@@ -1870,19 +1879,21 @@
 	    lassign $jid_command jid command
 	    $m2 add checkbutton -label $jid \
 				-variable [lindex $command 0] \
-				-command [lindex $command 1]
+				-command [lindex $command 1] \
+				-state [lindex $command 2]
 	}
     } else {
-	lassign [lindex [lindex $command_list 0] 1] var command
+	lassign [lindex [lindex $command_list 0] 1] var command state
 	$m add checkbutton -label $label \
 			   -variable $var \
-			   -command $command
+			   -command $command \
+			   -state $state
     }
 }
 
 proc roster::add_radiobutton_submenu {m prefix suffix i label jids} {
     set command_list [get_popup_command_list $m $prefix $suffix $label $jids \
-					     -value -variable -command]
+					     -value -variable -command -state]
 
     if {[llength $command_list] > 1} {
 	set m2 [menu $m.$i -tearoff 0]
@@ -1893,14 +1904,16 @@
 	    $m2 add radiobutton -label $jid \
 				-value [lindex $command 0] \
 				-variable [lindex $command 1] \
-				-command [lindex $command 2]
+				-command [lindex $command 2] \
+				-state [lindex $command 3]
 	}
     } else {
-	lassign [lindex [lindex $command_list 0] 1] value var command
+	lassign [lindex [lindex $command_list 0] 1] value var command state
 	$m add radiobutton -label $label \
 			   -value $value \
 			   -variable $var \
-			   -command $command
+			   -command $command \
+			   -state $state
     }
 }
 

Added: trunk/tkabber/plugins/roster/metacontacts.tcl
===================================================================
--- trunk/tkabber/plugins/roster/metacontacts.tcl	                        (rev 0)
+++ trunk/tkabber/plugins/roster/metacontacts.tcl	2009-02-14 18:55:08 UTC (rev 1655)
@@ -0,0 +1,356 @@
+# $Id$
+#
+# Storing metacontacts (XEP-0209) support
+#
+
+package require xmpp::roster::metacontacts
+
+namespace eval metacontacts {
+    # variable to store roster contacts
+    array set contacts {}
+
+    hook::add disconnected_hook [namespace current]::free_contacts
+    hook::add connected_hook [namespace current]::request_contacts
+    hook::add roster_jid_popup_menu_hook [namespace current]::roster_menu 72
+}
+
+proc metacontacts::free_contacts {xlib} {
+    variable contacts
+
+    array unset contacts $xlib,*
+}
+
+proc metacontacts::request_contacts {xlib} {
+    variable contacts
+
+    array unset contacts $xlib,*
+    set contacts($xlib,tags) {}
+
+    ::xmpp::roster::metacontacts::retrieve $xlib \
+		-command [namespace code [list process_contacts $xlib]]
+}
+
+proc metacontacts::process_contacts {xlib status contactslist} {
+    variable contacts
+
+    if {$status != "ok"} return
+
+    free_contacts $xlib
+
+    foreach {tag jids} $contactslist {
+	create_contact $xlib $tag $jids
+    }
+}
+
+proc metacontacts::create_contact {xlib tag jids args} {
+    variable contacts
+
+    set merge 0
+    foreach {opt val} $args {
+	switch -- $opt {
+	    -merge { set merge $val }
+	    default {
+		return -code error "Bad option \"$opt\":\
+		    must be -merge"
+	    }
+	}
+    }
+
+    if {!$merge || ![info exists contacts($xlib,jids,$tag)]} {
+	lappend contacts($xlib,tags) $tag
+	set contacts($xlib,tags) [lsort -unique $contacts($xlib,tags)]
+
+	set contacts($xlib,jids,$tag) $jids
+
+	foreach jid $jids {
+	    lappend contacts($xlib,tag,$jid) $tag
+	    set contacts($xlib,tag,$jid) [lsort -unique $contacts($xlib,tag,$jid)]
+	}
+	return 1
+    } else {
+	return 0
+    }
+}
+
+proc metacontacts::get_all_tags {xlib} {
+    variable contacts
+
+    if {[info exists contacts($xlib,tags)]} {
+	return $contacts($xlib,tags)
+    } else {
+	return {}
+    }
+}
+
+proc metacontacts::get_tags {xlib jid} {
+    variable contacts
+
+    if {[info exists contacts($xlib,tag,$jid)]} {
+	return $contacts($xlib,tag,$jid)
+    } else {
+	return {}
+    }
+}
+
+proc metacontacts::get_jids {xlib tag} {
+    variable contacts
+
+    if {[info exists contacts($xlib,jids,$tag)]} {
+	return $contacts($xlib,jids,$tag)
+    } else {
+	return {}
+    }
+}
+
+proc metacontacts::cleanup_and_store_contacts {xlib args} {
+    variable contacts
+
+    set roster_jids [roster::get_jids $xlib]
+
+    foreach idx [array names contacts $xlib,jids,*] {
+	set tag [string range $idx [string length $xlib,jids,] end]
+	set jids {}
+	foreach jid $contacts($idx) {
+	    if {[lsearch -exact $roster_jids $jid] < 0} {
+		catch { unset contacts($xlib,tag,$jid) }
+	    } else {
+		lappend jids $jid
+	    }
+	}
+	set contacts($idx) $jids
+    }
+
+    eval [list store_contacts $xlib] $args
+}
+
+proc metacontacts::serialize_contacts {xlib} {
+    variable contacts
+
+    set contactlist {}
+    foreach idx [array names contacts $xlib,jids,*] {
+	set tag [string range $idx [string length $xlib,jids,] end]
+
+	lappend contactlist $tag $contacts($idx)
+    }
+
+    return $contactlist
+}
+
+proc metacontacts::store_contacts {xlib args} {
+    set command [namespace code [list store_contacts_result $xlib]]
+    foreach {opt val} $args {
+	switch -- $opt {
+	    -command { set command $val }
+	    default {
+		return -code error "Bad option \"$opt\":\
+		    must be -command"
+	    }
+	}
+    }
+
+    ::xmpp::roster::metacontacts::store $xlib [serialize_contacts $xlib] \
+		-command $command
+}
+
+proc metacontacts::store_contacts_result {xlib status xml} {
+
+    if {$status == "ok"} return
+
+    if {[winfo exists .store_contacts_error]} {
+	destroy .store_contacts_error
+    }
+    MessageDlg .store_contacts_error -aspect 50000 -icon error \
+	-message [::msgcat::mc "Storing roster metacontacts failed: %s" \
+			 [error_to_string $xml]] \
+	-type user -buttons ok -default 0 -cancel 0
+}
+
+proc metacontacts::edit {xlib tag {jid ""}} {
+    variable contacts
+
+    if {$tag == ""} {
+	# New metacontact
+	for {set i 0} {1} {incr i} {
+	    if {[lsearch -exact $contacts($xlib,tags) $i] < 0} {
+		set tag $i
+		break
+	    }
+	}
+    }
+
+    set w .metacontact
+
+    if {[winfo exists $w]} {
+	destroy $w
+    }
+
+    Dialog $w -title [::msgcat::mc "Edit Metacontact"] \
+	      -modal none \
+	      -separator 1 \
+	      -anchor e \
+	      -default 0 \
+	      -cancel 1
+
+    $w add -text [::msgcat::mc "Store"] \
+	   -command [namespace code [list edit_enddialog $xlib $w $tag]]
+
+    $w add -text [::msgcat::mc "Cancel"] \
+	   -command [list destroy $w]
+
+    set f [$w getframe]
+
+    set tools [frame $f.tools]
+    pack $tools -side bottom -fill x
+    
+    set sw [ScrolledWindow $w.sw]
+    set lf [listbox $w.fields]
+    pack $sw -side top -expand yes -fill both -in $f -pady 1m -padx 1m
+    $sw setwidget $lf
+
+    bind $lf <3> [namespace code [list select_and_popup_menu %W %x %y]]
+
+    set addentry [entry $tools.addentry]
+    set additem [button $tools.additem \
+		     -text [::msgcat::mc "Add JID"] \
+		     -command \
+		     [namespace code [list add_jid_entry $lf $addentry]]]
+    pack $additem -side right -padx 1m
+    pack $addentry -side left -padx 1m -fill x -expand yes
+
+    if {[info exists contacts($xlib,jids,$tag)]} {
+	eval {$lf insert end} $contacts($xlib,jids,$tag)
+    } elseif {$jid != ""} {
+	$lf insert end $jid
+    }
+
+    DropSite::register $lf -dropcmd [namespace code [list dropcmd]] \
+			   -droptypes {JID}
+    $w draw
+}
+
+proc metacontacts::edit_enddialog {xlib w tag} {
+    variable contacts
+
+    $w itemconfigure 0 -state disabled
+    set jids [$w.fields get 0 end]
+    destroy $w
+
+    create_contact $xlib $tag $jids
+    store_contacts $xlib
+    redraw_roster
+}
+
+proc metacontacts::dropcmd {target source X Y op type data} {
+    add_jid $target [lindex $data 1]
+}
+
+proc metacontacts::select_and_popup_menu {f x y} {
+    set index [$f index @$x,$y]
+    $f selection clear 0 end
+    $f selection set $index
+
+    if {[winfo exists [set m .metacontact_popupmenu]]} {
+	destroy $m
+    }
+
+    menu $m -tearoff 0
+    $m add command -label [::msgcat::mc "Remove from metacontact"] \
+		   -command [list $f delete $index]
+
+    tk_popup $m [winfo pointerx .] [winfo pointery .]
+}
+
+proc metacontacts::add_jid_entry {f entry} {
+    set item [$entry get]
+    $entry delete 0 end
+
+    add_jid $f $item
+}
+
+proc metacontacts::add_jid {f item} {
+    set values [$f get 0 end]
+    if {[lsearch -exact $values $item] < 0} {
+	lappend values $item
+    }
+
+    set index [lsearch -exact $values $item]
+
+    $f delete 0 end
+    eval [list $f insert end] $values
+    $f selection set $index
+}
+
+proc metacontacts::confirm_delete {xlib tag} {
+    variable contacts
+
+    set w .metacontact_delete
+
+    if {[winfo exists $w]} {
+	destroy $w
+    }
+
+    set res [MessageDlg .metacontact_delete \
+			-aspect 50000 \
+			-icon warning \
+			-type user \
+			-buttons {yes no} \
+			-default 1 \
+			-cancel 1 \
+			-message [::msgcat::mc "Are you sure to delete this metacontact?"]]
+
+    if {$res == 0} {
+	if {[set idx [lsearch -exact $contacts($xlib,tags) $tag]] >= 0} {
+	    set contacts($xlib,tags) [lreplace $contacts($xlib,tags) $idx $idx]
+	    unset contacts($xlib,jids,$tag)
+	    foreach idx [array names contacts $xlib,tag,*] {
+		if {[set idx1 [lsearch -exact $contacts($idx) $tag]] >= 0} {
+		    set contacts($idx) [lreplace $contacts($idx) $idx1 $idx1]
+		}
+	    }
+	}
+	store_contacts $xlib
+	redraw_roster
+    }
+}
+
+proc metacontacts::roster_menu {m xlib jid} {
+    variable contacts
+
+    set rjid [roster::find_jid $xlib $jid]
+    if {$rjid == ""} {
+	set tag ""
+	set state disabled
+	set state1 disabled
+	set state2 disabled
+    } else {
+	set state normal
+	if {[info exists contacts($xlib,tag,$rjid)]} {
+	    set tag [lindex $contacts($xlib,tag,$rjid) 0]
+	    set state1 disabled
+	    set state2 normal
+	    set rjid "" ; # It doesn't make sense to split this menu entry
+	} else {
+	    set tag ""
+	    set state1 normal
+	    set state2 disabled
+	}
+    }
+
+    set mm [menu $m.metacontact -tearoff 0]
+
+    $mm add command -label [::msgcat::mc "Create metacontact"] \
+		    -state $state1 \
+		    -command [namespace code [list edit $xlib "" $rjid]]
+    $mm add command -label [::msgcat::mc "Edit metacontact"] \
+		    -state $state2 \
+		    -command [namespace code [list edit $xlib $tag]]
+    $mm add command -label [::msgcat::mc "Delete metacontact..."] \
+		    -state $state2 \
+		    -command [namespace code [list confirm_delete $xlib $tag]]
+
+    $m add cascade -label [::msgcat::mc "Metacontact"] \
+		   -state $state \
+		   -menu $mm
+}
+
+# vim:ts=8:sw=4:sts=4:noet


Property changes on: trunk/tkabber/plugins/roster/metacontacts.tcl
___________________________________________________________________
Added: svn:keywords
   + Author Date Id Revision
Added: svn:eol-style
   + native



More information about the Tkabber-dev mailing list