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

tkabber-svn at jabber.ru tkabber-svn at jabber.ru
Fri Mar 7 13:28:06 MSK 2008


Author: sergei
Date: 2008-03-07 13:28:05 +0300 (Fri, 07 Mar 2008)
New Revision: 1389

Added:
   trunk/tkabber/plugins/roster/backup.tcl
   trunk/tkabber/plugins/roster/bkup_annotations.tcl
   trunk/tkabber/plugins/roster/bkup_conferences.tcl
Modified:
   trunk/tkabber/ChangeLog
   trunk/tkabber/ifacetk/iroster.tcl
   trunk/tkabber/jabberlib/wrapper.tcl
   trunk/tkabber/plugins/roster/annotations.tcl
   trunk/tkabber/plugins/roster/conferences.tcl
   trunk/tkabber/roster.tcl
Log:
	* ifacetk/iroster.tcl, jabberlib/wrapper.tcl,
	  plugins/roster/annotations.tcl, plugins/roster/backup.tcl,
	  plugins/roster/bkup_annotations.tcl,
	  plugins/roster/bkup_conferences.tcl, plugins/roster/conferences.tcl,
	  roster.tcl: Rewritten roster export. Now it is exported to XML, and
	  export includes roster items, conferences and roster notes (thanks
	  to Konstantin Khomoutov).


Modified: trunk/tkabber/ChangeLog
===================================================================
--- trunk/tkabber/ChangeLog	2008-03-07 09:57:59 UTC (rev 1388)
+++ trunk/tkabber/ChangeLog	2008-03-07 10:28:05 UTC (rev 1389)
@@ -9,6 +9,14 @@
 	* plugins/iq/version.tcl: Implemented reporting Tkabber version in
 	  disco#info replies (XEP-0232).
 
+	* ifacetk/iroster.tcl, jabberlib/wrapper.tcl,
+	  plugins/roster/annotations.tcl, plugins/roster/backup.tcl,
+	  plugins/roster/bkup_annotations.tcl,
+	  plugins/roster/bkup_conferences.tcl, plugins/roster/conferences.tcl,
+	  roster.tcl: Rewritten roster export. Now it is exported to XML, and
+	  export includes roster items, conferences and roster notes (thanks
+	  to Konstantin Khomoutov).
+
 2008-03-06  Sergei Golovan  <sgolovan at nes.ru>
 
 	* disco.tcl: Added new hook disco_node_reply_hook to allow answering

Modified: trunk/tkabber/ifacetk/iroster.tcl
===================================================================
--- trunk/tkabber/ifacetk/iroster.tcl	2008-03-07 09:57:59 UTC (rev 1388)
+++ trunk/tkabber/ifacetk/iroster.tcl	2008-03-07 10:28:05 UTC (rev 1389)
@@ -1907,43 +1907,6 @@
 
 ###############################################################################
 
-proc roster::setup_import_export_menus {args} {
-    set emenu [.mainframe getmenu export_roster]
-    set imenu [.mainframe getmenu import_roster]
-
-    if {[winfo exists $emenu]} {
-	destroy $emenu
-    }
-    menu $emenu -tearoff 0
-
-    if {[winfo exists $imenu]} {
-	destroy $imenu
-    }
-    menu $imenu -tearoff 0
-
-    if {[jlib::connections] == {}} {
-	.mainframe setmenustate export_roster disabled
-	.mainframe setmenustate import_roster disabled
-    } else {
-	.mainframe setmenustate export_roster normal
-	.mainframe setmenustate import_roster normal
-    }
-
-    foreach c [jlib::connections] {
-	set jid [jlib::connection_jid $c]
-	set label [format [::msgcat::mc "Roster of %s"] $jid]
-	set ecommand [list roster::export_to_file $c]
-	set icommand [list roster::import_from_file $c]
-	$emenu add command -label $label -command $ecommand
-	$imenu add command -label $label -command $icommand
-    }
-}
-hook::add connected_hook [namespace current]::roster::setup_import_export_menus
-hook::add disconnected_hook [namespace current]::roster::setup_import_export_menus
-hook::add finload_hook [namespace current]::roster::setup_import_export_menus
-
-###############################################################################
-
 proc roster::add_group_custom_presence_menu {m connid name} {
     set mm [menu $m.custom_presence -tearoff 0]
 

Modified: trunk/tkabber/jabberlib/wrapper.tcl
===================================================================
--- trunk/tkabber/jabberlib/wrapper.tcl	2008-03-07 09:57:59 UTC (rev 1388)
+++ trunk/tkabber/jabberlib/wrapper.tcl	2008-03-07 10:28:05 UTC (rev 1389)
@@ -223,7 +223,22 @@
 #
 # This procedure converts (and returns) $xmldata to raw-XML
 #
-proc wrapper:createxml {xmldata {xmlns jabber:client}} {
+proc wrapper:createxml {xmldata args} {
+    set xmlns jabber:client
+    set prettyprint 0
+    set level 0
+    foreach {opt val} $args {
+	switch -- $opt {
+	    -xmlns { set xmlns $val }
+	    -level { set level $val }
+	    -prettyprint { set prettyprint $val }
+	    default {
+		return -code error "Bad option \"$opt\":\
+		    must be one of -xmlns, -level or -prettyprint"
+	    }
+	}
+    }
+
     set retext ""
 
     set tagname [lindex $xmldata 0]
@@ -231,6 +246,9 @@
     set subtags [lindex $xmldata 2]
     set chdata  [lindex $xmldata 3]
 
+    if {$prettyprint && ($level > 0)} {
+	append retext [string repeat \t $level]
+    }
     append retext "<$tagname"
     foreach {attr value} $vars {
 	if {$attr == "xmlns"} {
@@ -242,20 +260,33 @@
 	}
 	append retext " $attr='[wrapper:xmlcrypt $value]'"
     }
-    if {$chdata == "" && [llength $subtags] == 0} {
+
+    set no_chdata [expr {$chdata == ""}]
+
+    if {$no_chdata && [llength $subtags] == 0} {
 	append retext "/>"
+	if {$prettyprint} { append retext \n }
 	return $retext
-    } else {
-	append retext ">"
     }
 
-    append retext [wrapper:xmlcrypt $chdata]
+    append retext ">"
 
+    if {!$no_chdata} {
+	append retext [wrapper:xmlcrypt $chdata]
+    } elseif {$prettyprint} {
+	append retext \n
+    }
+
     foreach subdata $subtags {
-	append retext [wrapper:createxml $subdata $xmlns]
+	append retext [wrapper:createxml $subdata -xmlns $xmlns \
+	    -prettyprint $prettyprint -level [expr {$level + 1}]]
     }
 
+    if {$prettyprint && $no_chdata && ($level > 0)} {
+	append retext [string repeat \t $level]
+    }
     append retext "</$tagname>"
+    if {$prettyprint && ($level > 0)} { append retext \n }
 
     return $retext
 }
@@ -390,3 +421,4 @@
     return "</stream:stream>"
 }
 
+# vim:ts=8:sw=4:sts=4:noet

Modified: trunk/tkabber/plugins/roster/annotations.tcl
===================================================================
--- trunk/tkabber/plugins/roster/annotations.tcl	2008-03-07 09:57:59 UTC (rev 1388)
+++ trunk/tkabber/plugins/roster/annotations.tcl	2008-03-07 10:28:05 UTC (rev 1389)
@@ -35,30 +35,55 @@
 
     if {$res != "OK"} return
 
-    array set notes {}
+    free_notes $connid
 
-    foreach ch $child {
-	jlib::wrapper:splitxml $ch tag1 vars1 isempty1 cdata1 children1
+    foreach xmldata $child {
+	jlib::wrapper:splitxml $xmldata tag vars isempty cdata children
 
-	if {[jlib::wrapper:getattr $vars1 xmlns] == $::NS(rosternotes)} {
-	    foreach note $children1 {
-		jlib::wrapper:splitxml $note ntag nvars nisempty ncdata nchildren
+	if {[jlib::wrapper:getattr $vars xmlns] == $::NS(rosternotes)} {
+	    foreach note $children {
+		create_note $connid $note
+	    }
+	}
+    }
+}
 
-		set jid [jlib::wrapper:getattr $nvars jid]
-		set cdate [jlib::wrapper:getattr $nvars cdate]
-		set mdate [jlib::wrapper:getattr $nvars mdate]
-		set notes($connid,jid,$jid) $jid
-		if {![catch { scan_time $cdate } cdate]} {
-		    set notes($connid,cdate,$jid) $cdate
-		}
-		if {![catch { scan_time $mdate } mdate]} {
-		    set notes($connid,mdate,$jid) $mdate
-		}
-		set notes($connid,note,$jid) $ncdata
-	    
+proc annotations::create_note {connid xmldata args} {
+    variable notes
+
+    set merge 0
+    foreach {opt val} $args {
+	switch -- $opt {
+	    -merge { set merge $val }
+	    default {
+		return -code error "Bad option \"$opt\":\
+		    must be -merge"
 	    }
 	}
     }
+
+    jlib::wrapper:splitxml $xmldata tag vars isempty cdata children
+
+    set jid [jlib::wrapper:getattr $vars jid]
+    set cdate [jlib::wrapper:getattr $vars cdate]
+    set mdate [jlib::wrapper:getattr $vars mdate]
+
+    if {![catch { scan_time $cdate } cdate]} {
+	set cdate [clock seconds]
+    }
+    if {![catch { scan_time $mdate } mdate]} {
+	set cdate [clock seconds]
+    }
+
+    if {!$merge || [more_recent $connid $jid $cdate $mdate]} {
+	set notes($connid,jid,$jid)   $jid
+	set notes($connid,cdate,$jid) $cdate
+	set notes($connid,mdate,$jid) $mdate
+	set notes($connid,note,$jid)  $cdata
+	return 1
+    } else {
+	return 0
+    }
 }
 
 proc annotations::scan_time {timestamp} {
@@ -69,9 +94,23 @@
     }
 }
 
-proc annotations::cleanup_and_store_notes {connid} {
+proc annotations::more_recent {connid jid cdate mdate} {
     variable notes
 
+    if {![info exists notes($connid,jid,$jid)]} {
+	return 1
+    } elseif {[info exists notes($connid,mdate,$jid)]} {
+	return [expr {$mdate > $notes($connid,mdate,$jid)}]
+    } elseif {[info exists notes($connid,cdate,$jid)]} {
+	return [expr {$cdate > $notes($connid,cdate,$jid)}]
+    } else {
+	return 1
+    }
+}
+
+proc annotations::cleanup_and_store_notes {connid args} {
+    variable notes
+
     set roster_jids {}
     foreach rjid [roster::get_jids $connid] {
 	lappend roster_jids [node_and_server_from_jid $rjid]
@@ -89,10 +128,10 @@
 	}
     }
 
-    store_notes $connid
+    eval [list store_notes $connid] $args
 }
 
-proc annotations::store_notes {connid} {
+proc annotations::serialize_notes {connid} {
     variable notes
 
     set notelist {}
@@ -119,10 +158,25 @@
 	}
     }
 
-    private::store [list [jlib::wrapper:createtag storage \
-			      -vars [list xmlns $::NS(rosternotes)] \
-			      -subtags $notelist]] \
-	-command [list [namespace current]::store_notes_result $connid] \
+    jlib::wrapper:createtag storage \
+	-vars [list xmlns $::NS(rosternotes)] \
+	-subtags $notelist
+}
+
+proc annotations::store_notes {connid args} {
+    set command [list [namespace current]::store_notes_result $connid]
+    foreach {opt val} $args {
+	switch -- $opt {
+	    -command { set command $val }
+	    default {
+		return -code error "Bad option \"$opt\":\
+		    must be -command"
+	    }
+	}
+    }
+
+    private::store [list [serialize_notes $connid]] \
+	-command $command \
 	-connection $connid
 }
 
@@ -301,3 +355,4 @@
 
 hook::add userinfo_hook [namespace current]::annotations::note_page 40
 
+# vim:ts=8:sw=4:sts=4:noet

Added: trunk/tkabber/plugins/roster/backup.tcl
===================================================================
--- trunk/tkabber/plugins/roster/backup.tcl	                        (rev 0)
+++ trunk/tkabber/plugins/roster/backup.tcl	2008-03-07 10:28:05 UTC (rev 1389)
@@ -0,0 +1,277 @@
+# $Id$
+# Export/import of the roster items using an XML file.
+# This code provides basic framework for handling roster backup
+# files and it's able to serialize/deserialize regular roster contacts.
+# Hooks provided to facilitate implementations of storing/restoring
+# other kinds of data logically pertaining to the roster
+# such as conference bookmarks, annotations, etc.
+
+namespace eval rosterbackup {
+    global NS
+    set NS(rosterbackup) http://tkabber.jabber.ru/contactlist
+
+    hook::add connected_hook \
+	[namespace current]::setup_import_export_menus
+    hook::add disconnected_hook \
+	[namespace current]::setup_import_export_menus
+    hook::add finload_hook \
+	[namespace current]::setup_import_export_menus
+
+    hook::add serialize_roster_hook \
+	[namespace current]::serialize_roster_contacts
+    hook::add deserialize_roster_hook \
+	[namespace current]::deserialize_roster_contacts
+}
+
+###############################################################################
+
+proc rosterbackup::setup_import_export_menus {args} {
+    set emenu [.mainframe getmenu export_roster]
+    set imenu [.mainframe getmenu import_roster]
+
+    if {[winfo exists $emenu]} {
+	destroy $emenu
+    }
+    menu $emenu -tearoff 0
+
+    if {[winfo exists $imenu]} {
+	destroy $imenu
+    }
+    menu $imenu -tearoff 0
+
+    if {[jlib::connections] == {}} {
+	.mainframe setmenustate export_roster disabled
+	.mainframe setmenustate import_roster disabled
+    } else {
+	.mainframe setmenustate export_roster normal
+	.mainframe setmenustate import_roster normal
+    }
+
+    foreach c [jlib::connections] {
+	set jid [jlib::connection_jid $c]
+	set label [format [::msgcat::mc "Roster of %s"] $jid]
+	set ecommand [list [namespace current]::export_to_file $c]
+	set icommand [list [namespace current]::import_from_file $c]
+	$emenu add command -label $label -command $ecommand
+	$imenu add command -label $label -command $icommand
+    }
+}
+
+###############################################################################
+
+proc rosterbackup::export_to_file {connid} {
+    set filename [tk_getSaveFile \
+		      -initialdir $::configdir \
+		      -initialfile [jlib::connection_user $connid]-roster.xml \
+		      -filetypes [list \
+				      [list [::msgcat::mc "Roster Files"] \
+					   .xml] \
+				      [list [::msgcat::mc "All Files"] *]]]
+    if {$filename == ""} return
+
+    set fd [open $filename w]
+    fconfigure $fd -encoding utf-8
+
+    puts $fd {<?xml version="1.0" encoding="UTF-8"?>}
+    puts $fd [serialize_roster $connid]
+
+    close $fd
+}
+
+###############################################################################
+
+proc rosterbackup::serialize_roster {connid} {
+    global NS
+
+    set subtags [list]
+    hook::run serialize_roster_hook $connid #[info level] subtags
+
+    jlib::wrapper:createxml [jlib::wrapper:createtag contactlist \
+	    -vars [list xmlns $NS(rosterbackup)] -subtags $subtags] \
+	-prettyprint 1
+}
+
+###############################################################################
+
+proc rosterbackup::serialize_roster_contacts {connid level varName} {
+    upvar $level $varName subtags
+
+    set items [list]
+    foreach jid [::roster::get_jids $connid] {
+	set category [::roster::itemconfig $connid $jid -category]
+	switch -- $category {
+	    user -
+	    gateway {
+		lappend items [::roster::item_to_xml $connid $jid]
+	    }
+	}
+    }
+
+    lappend subtags [jlib::wrapper:createtag roster \
+	-vars {xmlns jabber:iq:roster} \
+	-subtags $items]
+}
+
+###############################################################################
+
+proc rosterbackup::import_from_file {connid} {
+    set filename [tk_getOpenFile \
+		      -initialdir $::configdir \
+		      -initialfile [jlib::connection_user $connid]-roster.xml \
+		      -filetypes [list \
+				      [list [::msgcat::mc "Roster Files"] \
+					   .xml] \
+				      [list [::msgcat::mc "All Files"] *]]]
+    if {$filename == ""} return
+
+    set fd [open $filename r]
+    fconfigure $fd -encoding utf-8
+    set xml [string trimleft [read $fd] [format %c 0xFEFF]] ;# strip BOM, if any
+    close $fd
+
+    deserialize_roster $connid $xml
+}
+
+###############################################################################
+
+proc rosterbackup::deserialize_roster {connid data} {
+    hook::run roster_deserializing_hook $connid
+
+    set parser [jlib::wrapper:new "#" "#" \
+	[list [namespace current]::parse_roster_xml $connid]]
+    jlib::wrapper:elementstart $parser stream:stream {} {}
+    jlib::wrapper:parser $parser parse $data
+    jlib::wrapper:parser $parser configure -final 0
+    jlib::wrapper:free $parser
+
+    hook::run roster_deserialized_hook $connid
+}
+
+###############################################################################
+
+proc rosterbackup::parse_roster_xml {connid data} {
+    global NS
+
+    jlib::wrapper:splitxml $data tag vars isempty cdata children
+
+    if {![string equal $tag contactlist]} {
+	return -code error "Bad root element \"$tag\":\
+	    must be contactlist"
+    }
+    set xmlns [jlib::wrapper:getattr $vars xmlns]
+    if {![string equal $xmlns $NS(rosterbackup)]} {
+	return -code error "Bad root element namespace \"$xmlns\":\
+	    must be \"$NS(rosterbackup)\""
+    }
+
+    set tuples [list]
+    hook::run deserialize_roster_hook $connid $children #[info level] tuples
+
+    if {[llength $tuples] > 0} {
+	set scripts [list]
+	foreach tuple [lsort -integer -index 0 $tuples] {
+	    lappend scripts [lindex $tuple 1]
+	}
+	[namespace current]::run_deserialization_scripts $scripts
+    }
+}
+
+###############################################################################
+
+proc rosterbackup::run_deserialization_scripts {scripts} {
+    if {[llength $scripts] == 0} return
+
+    uplevel #0 [linsert [lindex $scripts 0] end \
+	[list [lindex [info level 0] 0] [lrange $scripts 1 end]]]
+}
+
+###############################################################################
+
+proc rosterbackup::deserialize_roster_contacts {connid data level varName} {
+    global NS
+    upvar $level $varName handlers
+
+    array set existing {}
+    foreach jid [::roster::get_jids $connid] {
+	set existing($jid) {}
+    }
+
+    upvar 0 sent($connid,jids) jids
+    set jids [list]
+    set subtags [list]
+
+    foreach item $data {
+	jlib::wrapper:splitxml $item tag vars isempty cdata children
+
+	if {![string equal $tag roster]} continue
+	set xmlns [jlib::wrapper:getattr $vars xmlns]
+	if {![string equal $xmlns $NS(roster)]} {
+	    return -code error "Bad roster element namespace \"$xmlns\":\
+		must be \"$NS(roster)\""
+	}
+
+	foreach child $children {
+	    set jid [get_item_jid $child]
+	    if {![info exists existing($jid)]} {
+		lappend jids $jid
+		lappend subtags $child
+	    }
+	}
+    }
+
+    if {[llength $subtags] > 0} {
+	lappend handlers [list 50 [namespace code [list \
+	    send_contacts $connid $subtags]]]
+    }
+
+    lappend handlers [list 1000 [namespace code [list \
+	show_restore_completion_dialog $connid]]]
+}
+
+###############################################################################
+
+proc rosterbackup::get_item_jid {data} {
+    jlib::wrapper:splitxml $data ? vars ? ? ?
+    jlib::wrapper:getattr $vars jid
+}
+
+###############################################################################
+
+proc rosterbackup::send_contacts {connid contacts continuation} {
+    global NS
+
+    jlib::send_iq set \
+	[jlib::wrapper:createtag query \
+	     -vars [list xmlns $NS(roster)] \
+	     -subtags $contacts] \
+	-connection $connid \
+	-command [namespace code [list process_send_result $continuation]]
+}
+
+###############################################################################
+
+proc rosterbackup::process_send_result {continuation result xmldata} {
+    switch -- $result {
+	OK {
+	    eval $continuation
+	}
+	default {
+	    # TODO check whether do we need to handle TIMEOUT specially
+	    tk_messageBox -icon error -parent . \
+		-title [::msgcat::mc "Error"] \
+		-message [::msgcat::mc "Error restoring roster contacts: %s" \
+		    [error_to_string $xmldata]]
+	}
+    }
+}
+
+###############################################################################
+
+proc rosterbackup::show_restore_completion_dialog {connid continuation} {
+    tk_messageBox -icon info -parent . \
+	-title [::msgcat::mc "Information"] \
+	-message [::msgcat::mc "Roster restoration completed"]
+    eval $continuation
+}
+
+# vim:ts=8:sw=4:sts=4:noet

Added: trunk/tkabber/plugins/roster/bkup_annotations.tcl
===================================================================
--- trunk/tkabber/plugins/roster/bkup_annotations.tcl	                        (rev 0)
+++ trunk/tkabber/plugins/roster/bkup_annotations.tcl	2008-03-07 10:28:05 UTC (rev 1389)
@@ -0,0 +1,95 @@
+# $Id$
+# Support for backup/restore of "annotations" (XEP-0145)
+# for roster items.
+# Depends on: annotations.tcl, backup.tcl
+
+namespace eval annobackup {
+    # Should probably go after the roster contacts, so we set prio to 60:
+    hook::add serialize_roster_hook \
+	[namespace current]::serialize_annotations 60
+    hook::add deserialize_roster_hook \
+	[namespace current]::deserialize_annotations 60
+}
+
+###############################################################################
+
+proc annobackup::serialize_annotations {connid level varName} {
+    upvar $level $varName subtags
+    global NS
+
+    set xmldata [::plugins::annotations::serialize_notes $connid]
+
+    lappend subtags [jlib::wrapper:createtag privstorage \
+	-vars {xmlns jabber:iq:private} \
+	-subtags [list $xmldata]]
+}
+
+###############################################################################
+
+proc annobackup::deserialize_annotations {connid data level varName} {
+    global NS
+    upvar $level $varName handlers
+
+    set notes [list]
+    foreach item $data {
+	jlib::wrapper:splitxml $item tag vars isempty cdata children
+	if {![string equal $tag privstorage]} continue
+	set xmlns [jlib::wrapper:getattr $vars xmlns]
+	if {![string equal $xmlns $NS(private)]} {
+	    return -code error "Bad roster element namespace \"$xmlns\":\
+		must be \"$NS(private)\""
+	}
+
+	foreach storage $children {
+	    jlib::wrapper:splitxml $storage ctag cvars cisempty ccdata cchildren
+	    if {![string equal $ctag storage]} continue
+	    set xmlns [jlib::wrapper:getattr $cvars xmlns]
+	    if {![string equal $xmlns $NS(rosternotes)]} continue
+	    
+	    set notes [concat $notes $cchildren]
+	}
+    }
+
+    if {[llength $notes] > 0} {
+	lappend handlers [list 60 [namespace code [list \
+	    send_notes $connid $notes]]]
+    }
+}
+
+###############################################################################
+
+proc annobackup::send_notes {connid notes continuation} {
+    set updated 0
+
+    foreach item $notes {
+	set added [::plugins::annotations::create_note \
+		$connid $item -merge yes]
+	set updated [expr {$updated || $added}]
+    }
+
+    if {$updated} {
+	::plugins::annotations::cleanup_and_store_notes $connid \
+	    -command [namespace code [list process_sending_result $continuation]]
+    } else {
+	eval $continuation
+    }
+}
+
+###############################################################################
+
+proc annobackup::process_sending_result {continuation result xmldata} {
+    switch -- $result {
+	OK {
+	    eval $continuation
+	}
+	default {
+	    # TODO check whether do we need to handle TIMEOUT specially
+	    tk_messageBox -icon error -parent . \
+		-title [::msgcat::mc "Error"] \
+		-message [::msgcat::mc "Error restoring annotations: %s" \
+		    [error_to_string $xmldata]]
+	}
+    }
+}
+
+# vim:ts=8:sw=4:sts=4:noet

Added: trunk/tkabber/plugins/roster/bkup_conferences.tcl
===================================================================
--- trunk/tkabber/plugins/roster/bkup_conferences.tcl	                        (rev 0)
+++ trunk/tkabber/plugins/roster/bkup_conferences.tcl	2008-03-07 10:28:05 UTC (rev 1389)
@@ -0,0 +1,106 @@
+# $Id$
+# Support for backup/restore of "roster bookmarks" to MUC rooms (XEP-0048, v1.0)
+# Depends on: conferences.tcl, backup.tcl
+
+namespace eval mucbackup {
+    # Should probably go after the roster contacts, so we set prio to 70:
+    hook::add serialize_roster_hook \
+	[namespace current]::serialize_muc_bookmarks 70
+    hook::add deserialize_roster_hook \
+	[namespace current]::deserialize_muc_bookmarks 70
+}
+
+###############################################################################
+
+proc mucbackup::serialize_muc_bookmarks {connid level varName} {
+    upvar $level $varName subtags
+    global NS
+
+    foreach xmldata [::plugins::conferences::serialize_bookmarks $connid] {
+	lappend subtags [jlib::wrapper:createtag privstorage \
+	    -vars [list xmlns $NS(private)] \
+	    -subtags [list $xmldata]]
+    }
+}
+
+###############################################################################
+
+proc mucbackup::deserialize_muc_bookmarks {connid data level varName} {
+    global NS
+    upvar $level $varName handlers
+
+    set bookmarks [list]
+    set bmgroups  [list]
+    foreach item $data {
+	jlib::wrapper:splitxml $item tag vars isempty cdata children
+	if {![string equal $tag privstorage]} continue
+	set xmlns [jlib::wrapper:getattr $vars xmlns]
+	if {![string equal $xmlns $NS(private)]} {
+	    return -code error "Bad roster element namespace \"$xmlns\":\
+		must be \"$NS(private)\""
+	}
+
+	foreach storage $children {
+	    jlib::wrapper:splitxml $storage ctag cvars cisempty ccdata cchildren
+	    if {![string equal $ctag storage]} continue
+	    set xmlns [jlib::wrapper:getattr $cvars xmlns]
+	    switch -- $xmlns \
+		$NS(bookmarks) {
+		    set bookmarks [concat $bookmarks $cchildren]
+		} \
+		$NS(tkabber:groups) {
+		    set bmgroups [concat $bmgroups $cchildren]
+		}
+	}
+    }
+
+    if {[llength $bookmarks] > 0 && [llength $bmgroups] > 0} {
+	lappend handlers [list 70 [namespace code [list \
+	    merge_muc_bookmarks $connid $bookmarks $bmgroups]]]
+    }
+}
+
+###############################################################################
+
+proc mucbackup::merge_muc_bookmarks {connid bookmarks bmgroups continuation} {
+    variable updated 0
+
+    foreach item $bookmarks {
+	set added [::plugins::conferences::create_muc_bookmark \
+		$connid $item -merge yes]
+	set updated [expr {$updated || $added}]
+    }
+
+    foreach item $bmgroups {
+	set added [::plugins::conferences::create_muc_bmgroup \
+		$connid $item -merge yes]
+	set updated [expr {$updated || $added}]
+    }
+
+    if {$updated} {
+	::plugins::conferences::store_bookmarks $connid \
+	    -command [namespace code [list process_merging_result $continuation]]
+	::plugins::conferences::push_bookmarks_to_roster $connid
+    } else {
+	eval $continuation
+    }
+}
+
+###############################################################################
+
+proc mucbackup::process_merging_result {continuation result xmldata} {
+    switch -- $result {
+	OK {
+	    eval $continuation
+	}
+	default {
+	    # TODO check whether TIMEOUT should be processed separately
+	    tk_messageBox -icon error -parent . \
+		-title [::msgcat::mc "Error"] \
+		-message [::msgcat::mc "Error restoring conference bookmarks: %s" \
+		    [error_to_string $xmldata]]
+	}
+    }
+}
+
+# vim:ts=8:sw=4:sts=4:noet

Modified: trunk/tkabber/plugins/roster/conferences.tcl
===================================================================
--- trunk/tkabber/plugins/roster/conferences.tcl	2008-03-07 09:57:59 UTC (rev 1388)
+++ trunk/tkabber/plugins/roster/conferences.tcl	2008-03-07 10:28:05 UTC (rev 1389)
@@ -77,6 +77,7 @@
 proc conferences::process_bookmarks {connid res child} {
     variable bookmarks
     variable responds
+    global NS
 
     if {$res != "OK"} return
 
@@ -85,61 +86,120 @@
     foreach ch $child {
 	jlib::wrapper:splitxml $ch tag1 vars1 isempty1 cdata1 children1
 
-	if {[jlib::wrapper:getattr $vars1 xmlns] == $::NS(bookmarks)} {
-	    foreach bookmark $children1 {
-		jlib::wrapper:splitxml $bookmark btag bvars bisempty bcdata bchildren
+	switch -- [jlib::wrapper:getattr $vars1 xmlns] \
+	    $NS(bookmarks) {
+		foreach bookmark $children1 {
+		    create_muc_bookmark $connid $bookmark
+		}
+	    } \
+	    $NS(tkabber:groups) {
+		foreach bookmark $children1 {
+		    create_muc_bmgroup $connid $bookmark
+		}
+	    }
+    }
 
-		if {$btag != "conference"} continue
+    if {$responds($connid) < 2} return
 
-		set jid [string tolower [jlib::wrapper:getattr $bvars jid]]
-		set bookmarks($connid,jid,$jid) $jid
+    push_bookmarks_to_roster $connid
+    after idle [list [namespace current]::autojoin_groups $connid]
+}
 
-		set bookmarks($connid,name,$jid) [jlib::wrapper:getattr $bvars name]
-		set bookmarks($connid,nick,$jid) ""
-		set bookmarks($connid,password,$jid) ""
-		if {![info exists bookmarks($connid,groups,$jid)]} {
-		    set bookmarks($connid,groups,$jid) {}
-		}
+proc conferences::create_muc_bookmark {connid xmldata args} {
+    variable bookmarks
 
-		set autojoin [jlib::wrapper:getattr $bvars autojoin]
-		switch -- $autojoin {
-		    1 -
-		    true { set bookmarks($connid,autojoin,$jid) 1 }
-		    default { set bookmarks($connid,autojoin,$jid) 0 }
-		}
-		
-		foreach bch $bchildren {
-		    jlib::wrapper:splitxml \
-			$bch tag2 vars2 isempty2 cdata2 children2
-		    switch -- $tag2 {
-			nick { set bookmarks($connid,nick,$jid) $cdata2 }
-			password { set bookmarks($connid,password,$jid) $cdata2 }
-		    }
-		}
+    set merge 0
+    foreach {opt val} $args {
+	switch -- $opt {
+	    -merge { set merge $val }
+	    default {
+		return -code error "Bad option \"$opt\":\
+		    must be -merge"
 	    }
-	} elseif {[jlib::wrapper:getattr $vars1 xmlns] == $::NS(tkabber:groups)} {
-	    foreach bookmark $children1 {
-		jlib::wrapper:splitxml $bookmark btag bvars bisempty bcdata bchildren
+	}
+    }
 
-		if {$btag != "conference"} continue
+    jlib::wrapper:splitxml $xmldata btag bvars bisempty bcdata bchildren
 
-		set jid [string tolower [jlib::wrapper:getattr $bvars jid]]
+    if {![string equal $btag conference]} { return 0 }
 
-		set groups {}
-		foreach bch $bchildren {
-		    jlib::wrapper:splitxml \
-			$bch tag2 vars2 isempty2 cdata2 children2
-		    switch -- $tag2 {
-			group { lappend groups $cdata2 }
-		    }
-		}
-		set bookmarks($connid,groups,$jid) $groups
+    set jid [string tolower [jlib::wrapper:getattr $bvars jid]]
+
+    if {$merge && [info exists bookmarks($connid,jid,$jid)]} {
+	return 0
+    } else {
+	set bookmarks($connid,jid,$jid) $jid
+
+	set bookmarks($connid,name,$jid) [jlib::wrapper:getattr $bvars name]
+	set bookmarks($connid,nick,$jid) ""
+	set bookmarks($connid,password,$jid) ""
+	if {![info exists bookmarks($connid,groups,$jid)]} {
+	    set bookmarks($connid,groups,$jid) {}
+	    set bookmarks($connid,hasgroups,$jid) 0
+	} else {
+	    set bookmarks($connid,hasgroups,$jid) 1
+	}
+
+	set autojoin [jlib::wrapper:getattr $bvars autojoin]
+	switch -- $autojoin {
+	    1 -
+	    true { set bookmarks($connid,autojoin,$jid) 1 }
+	    default { set bookmarks($connid,autojoin,$jid) 0 }
+	}
+	
+	foreach bch $bchildren {
+	    jlib::wrapper:splitxml \
+		$bch tag2 vars2 isempty2 cdata2 children2
+	    switch -- $tag2 {
+		nick { set bookmarks($connid,nick,$jid) $cdata2 }
+		password { set bookmarks($connid,password,$jid) $cdata2 }
 	    }
 	}
+	return 1
     }
+}
 
-    if {$responds($connid) < 2} return
+proc conferences::create_muc_bmgroup {connid xmldata args} {
+    variable bookmarks
 
+    set merge 0
+    foreach {opt val} $args {
+	switch -- $opt {
+	    -merge { set merge $val }
+	    default {
+		return -code error "Bad option \"$opt\":\
+		    must be -merge"
+	    }
+	}
+    }
+
+    jlib::wrapper:splitxml $xmldata btag bvars bisempty bcdata bchildren
+
+    if {![string equal $btag conference]} return
+
+    set jid [string tolower [jlib::wrapper:getattr $bvars jid]]
+
+    set groups [list]
+    foreach bch $bchildren {
+	jlib::wrapper:splitxml $bch tag2 vars2 isempty2 cdata2 children2
+	if {[string equal $tag2 group]} {
+	    lappend groups $cdata2
+	}
+    }
+
+    if {$merge && [info exists bookmarks($connid,jid,$jid)]
+		&& $bookmarks($connid,hasgroups,$jid)} {
+	return 0
+    } else {
+	set bookmarks($connid,groups,$jid) $groups
+	set bookmarks($connid,hasgroups,$jid) 1
+	return 1
+    }
+}
+
+proc conferences::push_bookmarks_to_roster {connid} {
+    variable bookmarks
+
     foreach idx [array names bookmarks $connid,jid,*] {
 	set jid $bookmarks($idx)
 	client:roster_push $connid $jid $bookmarks($connid,name,$jid) \
@@ -147,7 +207,6 @@
 			   bookmark ""
 	roster::override_category_and_subtype $connid $jid conference ""
     }
-    after idle [list [namespace current]::autojoin_groups $connid]
 }
 
 ###############################################################################
@@ -155,7 +214,7 @@
 #   Store bookmarks
 #
 
-proc conferences::store_bookmarks {connid} {
+proc conferences::serialize_bookmarks {connid} {
     variable bookmarks
 
     set bookmarklist {}
@@ -189,17 +248,31 @@
 			       -subtags $groups]
     }
 
-    private::store [list [jlib::wrapper:createtag storage \
-			      -vars [list xmlns $::NS(bookmarks)] \
-			      -subtags $bookmarklist]] \
-	-command [list [namespace current]::store_bookmarks_result $connid] \
-	-connection $connid
+    list [jlib::wrapper:createtag storage \
+	    -vars [list xmlns $::NS(bookmarks)] \
+	    -subtags $bookmarklist] \
+	[jlib::wrapper:createtag storage \
+	    -vars [list xmlns $::NS(tkabber:groups)] \
+	    -subtags $grouplist]
+}
 
-    private::store [list [jlib::wrapper:createtag storage \
-			      -vars [list xmlns $::NS(tkabber:groups)] \
-			      -subtags $grouplist]] \
-	-command [list [namespace current]::store_bookmarks_result $connid] \
-	-connection $connid
+proc conferences::store_bookmarks {connid args} {
+    set command [list [namespace current]::store_bookmarks_result $connid]
+    foreach {opt val} $args {
+	switch -- $opt {
+	    -command { set command $val }
+	    default {
+		return -code error "Bad option \"$opt\":\
+		    must be -command"
+	    }
+	}
+    }
+
+    foreach item [serialize_bookmarks $connid] {
+	private::store [list $item] \
+	    -command $command \
+	    -connection $connid
+    }
 }
 
 proc conferences::store_bookmarks_result {connid res child} {
@@ -438,6 +511,7 @@
     set bookmarks($connid,password,$jid) $password
     set bookmarks($connid,autojoin,$jid) $autojoin
     set bookmarks($connid,groups,$jid) $groups
+    set bookmarks($connid,hasgroups,$jid) 1
 
     # TODO should we remove $jid from the roster if it is here?
     client:roster_push $connid $jid $name $groups bookmark ""
@@ -534,6 +608,7 @@
     catch { unset bookmarks($connid,password,$jid) }
     catch { unset bookmarks($connid,autojoin,$jid) }
     catch { unset bookmarks($connid,groups,$jid) }
+    catch { unset bookmarks($connid,hasgroups,$jid) }
 
     store_bookmarks $connid
 
@@ -865,5 +940,4 @@
 hook::add disco_node_menu_hook \
 	  [namespace current]::conferences::disco_node_menu_setup 50
 
-###############################################################################
-
+# vim:ts=8:sw=4:sts=4:noet

Modified: trunk/tkabber/roster.tcl
===================================================================
--- trunk/tkabber/roster.tcl	2008-03-07 09:57:59 UTC (rev 1388)
+++ trunk/tkabber/roster.tcl	2008-03-07 10:28:05 UTC (rev 1389)
@@ -194,12 +194,20 @@
 	    -name     {set param name}
 	    -subsc    {set param subsc}
 	    -ask      {set param ask}
-	    -category {set param category}
-	    -subtype  {set param subtype}
+	    -category {
+		return [lindex [get_category_and_subtype $connid $jid] 0]
+	    }
+	    -subtype  {
+		return [lindex [get_category_and_subtype $connid $jid] 1]
+	    }
 	    -isuser   {
 		return [cequal [lindex [get_category_and_subtype $connid $jid] 0] "user"]
 	    }
-	    default   {return -code error "Illegal option"}
+	    default   {
+		return -code error "Bad option \"$attr\":\
+		    must be one of: -group, -name, -subsc, -ask,\
+		    -category, -subtype or -isuser"
+	    }
 	}
 	if {[info exists roster($param,$connid,$jid)]} {
 	    return $roster($param,$connid,$jid)
@@ -213,8 +221,14 @@
 		-name     {set param name}
 		-subsc    {set param subsc}
 		-ask      {set param ask}
-		-category {set param category}
-		-subtype  {set param subtype}
+		-category {
+		    override_category $connid $jid $val
+		    continue
+		}
+		-subtype  {
+		    override_subtype $connid $jid $val
+		    continue
+		}
 		default   {return -code error "Illegal option"}
 	    }
 	    set roster($param,$connid,$jid) $val
@@ -292,6 +306,23 @@
 	[list $category $subtype]
 }
 
+proc roster::override_category {connid jid category} {
+    variable roster
+
+    set roster(overridden_category_and_subtype,$connid,$jid) \
+	[list $category \
+	    [lindex $roster(overridden_category_and_subtype,$connid,$jid) 1]]
+}
+
+proc roster::override_subtype {connid jid subtype} {
+    variable roster
+
+    set roster(overridden_category_and_subtype,$connid,$jid) \
+	[list \
+	    [lindex $roster(overridden_category_and_subtype,$connid,$jid) 0] \
+	    $subtype]
+}
+
 proc roster::get_category_and_subtype {connid jid} {
     variable roster
 
@@ -401,7 +432,6 @@
     array unset roster name,*
     array unset roster subsc,*
     array unset roster ask,*
-    array unset roster category,*
     array unset roster subtype,*
     array unset roster cached_category_and_subtype,*
     array unset roster overridden_category_and_subtype,*
@@ -416,7 +446,6 @@
     array unset roster name,$connid,*
     array unset roster subsc,$connid,*
     array unset roster ask,$connid,*
-    array unset roster category,$connid,*
     array unset roster subtype,$connid,*
     array unset roster cached_category_and_subtype,$connid,*
     array unset roster overridden_category_and_subtype,$connid,*



More information about the Tkabber-dev mailing list