Index: jabber/UserInfo.tcl =================================================================== --- jabber/UserInfo.tcl (revision 2754) +++ jabber/UserInfo.tcl (working copy) @@ -23,18 +23,27 @@ package provide UserInfo 1.0 package require VCard +package require TracedText namespace eval ::UserInfo:: { # Add all event hooks. ::hooks::register menuUserInfoFilePostHook ::UserInfo::FileMenuPostHook ::hooks::register onMenuVCardExport ::UserInfo::OnMenuExportHook + ::hooks::register logoutHook ::UserInfo::NotesLogoutHook variable uid + array set rosternotes {} set ::config(userinfo,disco) 0 } +proc ::UserInfo::NotesLogoutHook {} { + variable rosternotes + + array set rosternotes {} +} + proc ::UserInfo::GetJIDList {jidL} { foreach jid $jidL { Get $jid @@ -450,9 +459,64 @@ Free $token } +proc ::UserInfo::NotesSendGetCB {token type queryElem args} { + variable rosternotes + upvar ${token}::priv priv + + incr priv(ncount) -1 + if {$priv(ncount) <= 0} { + $priv(warrow) stop + } + + + if {$type eq "error"} { + ::UI::MessageBox -type ok -icon error -title [mc "Error"] \ + -message "Failed to obtain personal notes: [lindex $queryElem 1]" + destroy $dlg + } else { + # Extract the relevant Note element + array set rosternotes [NotesExtractFromElem $queryElem] + } + set jid2 $priv(jid2) + if {[info exists rosternotes($jid2)]} { + set priv(strnote) $rosternotes($jid2) + } else { + set priv(strnote) "" + } + return [array get rosternotes] + +} + +proc ::UserInfo::NotesExtractFromElem {queryElem} { + variable rosternotes + array set rosternotes {} + set storageElem \ + [wrapper::getfirstchild $queryElem "storage" "storage:rosternotes"] + set notesElems [wrapper::getchildswithtag $storageElem "note"] + foreach elem $notesElems { + array unset notesarr + array set notesarr [list name "" jid ""] + array set notesarr [wrapper::getattrlist $elem] + set note [list $notesarr(jid)] + if {[info exists notesarr(cdate)]} { + lappend note -cdate $notesarr(cdate) + } + if {[info exists notesarr(mdate)]} { + lappend note -cdate $notesarr(mdate) + } + set noteData [wrapper::getcdata $elem] + if {$noteData ne ""} { + set rosternotes($notesarr(jid)) $noteData + } + } + return [array get rosternotes] +} + + proc ::UserInfo::NotesPage {token} { global this upvar ${token}::priv priv + variable rosternotes set wnb $priv(wnb) @@ -473,8 +537,8 @@ set wtext $wpage.t set wysc $wpage.s ttk::scrollbar $wysc -orient vertical -command [list $wtext yview] - text $wtext -wrap word -width 40 -height 12 -bd 1 -relief sunken \ - -yscrollcommand [list ::UI::ScrollSet $wysc \ + TracedText::TracedText $wtext -wrap word -width 40 -height 12 -bd 1 -textvariable ${token}::priv\(strnote) \ + -relief sunken -yscrollcommand [list ::UI::ScrollSet $wysc \ [list pack $wysc -side right -fill y]] pack $wysc -side right -fill y @@ -482,12 +546,10 @@ set priv(wnotes) $wtext - if {[file exists $this(notesFile)]} { - source $this(notesFile) - set jid2 $priv(jid2) - if {[info exists notes($jid2)]} { - $wtext insert end $notes($jid2) - } + ::jlib::annotations::send_get "rosternotes" [list [namespace current]::NotesSendGetCB $token] + set $wtext priv(strnote) + if {[info exists rosternotes($priv(jid2))]} { + $wtext insert end $rosternotes($priv(jid2)) } } @@ -549,6 +611,7 @@ proc ::UserInfo::SaveNotes {token} { global this + variable rosternotes upvar ${token}::priv priv if {[file exists $this(notesFile)]} { @@ -557,20 +620,13 @@ set str [string trim [$priv(wnotes) get 1.0 end]] set jid2 $priv(jid2) set notes($jid2) $str - - # Work on a temporary file and switch later. - set tmp $this(notesFile).tmp - if {![catch {open $tmp w} fd]} { - #fconfigure $fd -encoding utf-8 - puts $fd "# Notes file" - puts $fd "# The data written at: [clock format [clock seconds]]\n#" - foreach {jid str} [array get notes] { - puts $fd [list set notes($jid) $notes($jid)] - } - close $fd - catch {file rename -force $tmp $this(notesFile)} + set rosternotes($jid2) $str + set rosternoteslist {} + foreach {jid str} [array get rosternotes] { + lappend rosternoteslist [list "note" [list jid $jid] 0 $str] } -} + ::jlib::annotations::send_set "rosternotes" $rosternoteslist +} proc ::UserInfo::GetTokenFrom {key pattern} { foreach ns [namespace children [namespace current]] { Index: jabber/GroupChat.tcl =================================================================== --- jabber/GroupChat.tcl (revision 2754) +++ jabber/GroupChat.tcl (working copy) @@ -28,6 +28,7 @@ package require UI::WSearch package require colorutils package require mstack +package require jlib::annotations package provide GroupChat 1.0 @@ -3326,7 +3327,7 @@ proc ::GroupChat::BookmarkLoginHook {} { - BookmarkSendGet [namespace current]::BookmarkExtractFromCB + ::jlib::annotations::send_get "bookmarks" [namespace current]::BookmarkExtractFromCB } proc ::GroupChat::BookmarkLogoutHook {} { @@ -3438,24 +3439,9 @@ -attrlist $attrs -subtags $confChilds] lappend confElems $confElem } - set storageElem [wrapper::createtag "storage" \ - -attrlist [list xmlns "storage:bookmarks"] -subtags $confElems] - set queryElem [wrapper::createtag "query" \ - -attrlist [list xmlns "jabber:iq:private"] -subtags [list $storageElem]] - - ::Jabber::Jlib send_iq set [list $queryElem] + ::jlib::annotations::send_set "bookmarks" $confElems } -proc ::GroupChat::BookmarkSendGet {callback} { - - set storageElem [wrapper::createtag "storage" \ - -attrlist [list xmlns storage:bookmarks]] - set queryElem [wrapper::createtag "query" \ - -attrlist [list xmlns "jabber:iq:private"] -subtags [list $storageElem]] - - ::Jabber::Jlib send_iq get [list $queryElem] -command $callback -} - proc ::GroupChat::OnMenuBookmark {} { if {[llength [grab current]]} { return } if {[::JUI::GetConnectState] eq "connectfin"} { @@ -3489,7 +3475,7 @@ $dlg state disabled $dlg wait - BookmarkSendGet [namespace current]::BookmarkSendGetCB + ::jlib::annotations::send_get "bookmarks" [namespace current]::BookmarkSendGetCB } proc ::GroupChat::BookmarkSendGetCB {type queryElem args} { Index: contrib/TracedText.tcl =================================================================== --- contrib/TracedText.tcl (revision 0) +++ contrib/TracedText.tcl (revision 0) @@ -0,0 +1,278 @@ +#---------------------------------------------------------------------- + # + # TracedText.tcl -- + # + # Package that implements a change to the text widget that + # allows a -textvariable option to be specified at creation + # time. + # + #---------------------------------------------------------------------- + + # Copyright (c) 1999, by Kevin B. Kenny. All rights reserved. + + package provide TracedText 1.0 + + namespace eval TracedText { + + namespace export TracedText + + # The traced text widgets have a binding that + # cleans up internal storage. Establish it here so that + # the widget creation procedure just has to fiddle binding + # tags. + + bind TracedText [namespace code {cleanup %W}] + } + + #---------------------------------------------------------------------- + # + # TracedText::TracedText -- + # + # Create a text widget that supports a -textvariable flag + # + # Parameters: + # w -- Path name of the widget + # args -- Option-value pairs + # + # Results: + # Returns the path name of the newly-created widget. + # + # Side effects: + # The widget is created. If a -textvariable option is + # supplied, the widget command is renamed, and an alias + # is installed in the global namespace. The alias command + # intercepts the 'insert' and 'delete' subcommands and + # updates the text variable. In addition, a trace is + # established on the text variable to keep the text + # variable up to date. + # + # Options: + # The TracedText command accepts all the options of a text + # widget, plus a -textvariable option that gives the name + # of a variable or array element in the global namespace + # that will contain the same content as the widget itself. + # + # Limitations: + # The code does not work entirely correctly in the presence + # of embedded images. The -textvariable option cannot be + # set via 'configure' or interrogated via 'cget'. + # + #---------------------------------------------------------------------- + + proc TracedText::TracedText { w args } { + + variable textvar + + # Extract the special '-textvariable' option. + + set textArgs {} + foreach { option value } $args { + switch -exact -- $option { + -textvariable { + set textvar($w) $value + } + default { + lappend textArgs $option $value + } + } + } + + # Create the widget + eval [list text $w] $textArgs + + # Rename the widget command to an alias in the "TracedText" + # namespace. Create a new command that looks just like the + # widget command but goes off to the "widgetCmd" procedure. + + if {[info exists textvar($w)]} { + + rename $w alias$w + proc ::$w args { + + # p is the name of this procedure, which may or + # may not have a :: qualifier. + + set p [lindex [info level 0] 0] + + # w is the name of the traced text widget. + + set w [namespace tail $p] + + # Go to the TracedText::widgetCmd procedure to + # process the command. + + return [eval [list TracedText::widgetCmd $w] $args] + + } + + # Adjust the bind tags so that the binding will fire. + + bindtags $w [linsert [bindtags $w] 1 TracedText] + + # If the variable exists, update the widget content. + # Otherwise, create the variable. + + # the original had a upvar \#0 here + upvar 1 $textvar($w) theVariable + if { [info exists theVariable] } { + alias$w insert 1.0 $theVariable + } else { + set theVariable {} + } + + # Put a trace on the text variable so that we can update + # the widget if it changes. + + trace variable theVariable w \ + [namespace code [list traceCallback $w]] + + } + + return $w + } + + #---------------------------------------------------------------------- + # + # TracedText::widgetCmd -- + # + # Widget command for a text widget with a textvariable. + # + # Parameters: + # w -- Path name of the widget + # args -- Arguments to the widget command + # + # Results: + # Returns whatever the text widget does in response to the + # widget command. + # + # Side effects: + # In addition to whatever side effects the text widget + # has in response to the widget command, the 'insert' and + # 'delete' widget commands cause the text variable of the + # widget to be updated. + # + #---------------------------------------------------------------------- + + proc TracedText::widgetCmd {w args} { + + # Execute the widget command + + set retval [eval [list alias$w] $args] + + # After the widget command returns, set the text variable if + # the command was 'insert' or 'delete.' + + switch -exact [lindex $args 0] { + del - + dele - + delet - + delete - + ins - + inse - + inser - + insert { + + variable textvar + variable busy + + # The 'busy' variable keeps the traceCallback + # procedure from attempting to reload the widget + # content. + + upvar \#0 $textvar($w) content + set busy($w) {} + set content [$w get 1.0 end] + unset busy($w) + + } + } + + return $retval + + } + + #---------------------------------------------------------------------- + # + # TracedText::traceCallback -- + # + # Trace callback entered when the text variable of a text widget + # is changed. + # + # Parameters: + # w -- Path name of the widget + # name1 -- Name of the text variable in the calling namespace. + # name2 -- Subscript name of the text variable, if any. + # op -- Traced variable operation (always "w") + # + # Results: + # None. + # + # Side effects: + # If the variable was being changed in response to an 'insert' + # or 'delete' command on the widget, the procedure does nothing. + # Otherwise, it deletes the entire content of the widget and + # replaces it with the new contents of the variable; it does this + # even if the widget is disabled. + # + #---------------------------------------------------------------------- + +proc TracedText::traceCallback { w name1 name2 op } { + + variable busy + + if { ! [info exists busy($w)] } { + + variable textvar + # Retrieve the changed content of the textvariable + upvar 2 $name1 theVariable + if { [array exists theVariable] } { + set content $theVariable($name2) + } else { + set content $theVariable + } + + # Enable the widget temporarily, and adjust its content. + + set state [alias$w cget -state] + alias$w configure -state normal + alias$w delete 1.0 end + alias$w insert 1.0 $content + alias$w configure -state $state + + } + return +} + + #---------------------------------------------------------------------- + # + # TracedText::cleanup -- + # + # Clean up after destroyoing a text widget with a textvariable. + # + # Parameters: + # w -- Path name of the destroyed widget. + # + # Results: + # None. + # + # Side effects: + # The variables and traces that belong to the widget are deleted, + # as is the procedure that aliases the widget command. + # + #---------------------------------------------------------------------- + +proc TracedText::cleanup { w } { + + variable textvar + + upvar #0 $textvar($w) theVariable + trace vdelete theVariable w \ + [namespace code [list traceCallback $w]] + unset textvar($w) + rename ::$w {} + + return + +} + + Index: contrib/pkgIndex.tcl =================================================================== --- contrib/pkgIndex.tcl (revision 2754) +++ contrib/pkgIndex.tcl (working copy) @@ -48,6 +48,7 @@ package ifneeded tinyfileutils 1.0 [list source [file join $dir tinyfileutils.tcl]] package ifneeded tinyhttpd 1.0 [list source [file join $dir tinyhttpd.tcl]] package ifneeded TkInteractor 1.0 [list source [file join $dir TkInteractorPackage.tcl]] +package ifneeded TracedText 1.0 [list source [file join $dir TracedText.tcl]] package ifneeded tree 1.0 [list source [file join $dir tree.tcl]] package ifneeded TreeCtrlDnD 0.1 [list source [file join $dir TreeCtrlDnD.tcl]] package ifneeded treeutil 1.0 [list source [file join $dir treeutil.tcl]] Index: jabberlib/pkgIndex.tcl =================================================================== --- jabberlib/pkgIndex.tcl (revision 2754) +++ jabberlib/pkgIndex.tcl (working copy) @@ -20,6 +20,7 @@ package ifneeded tinydom 0.2 [list source [file join $dir tinydom.tcl]] package ifneeded wrapper 1.2 [list source [file join $dir wrapper.tcl]] +package ifneeded jlib::annotations 0.1 [list source [file join $dir annotations.tcl]] package ifneeded jlib::avatar 0.1 [list source [file join $dir avatar.tcl]] package ifneeded jlib::bind 0.1 [list source [file join $dir bind.tcl]] package ifneeded jlib::bytestreams 0.4 [list source [file join $dir bytestreams.tcl]] @@ -33,6 +34,7 @@ package ifneeded jlib::jingle 0.1 [list source [file join $dir jingle.tcl]] package ifneeded jlib::muc 0.3 [list source [file join $dir muc.tcl]] package ifneeded jlib::pep 0.3 [list source [file join $dir pep.tcl]] +package ifneeded jlib::private 0.1 [list source [file join $dir private.tcl]] package ifneeded jlib::pubsub 0.2 [list source [file join $dir pubsub.tcl]] package ifneeded jlib::roster 1.0 [list source [file join $dir roster.tcl]] package ifneeded jlib::si 0.1 [list source [file join $dir si.tcl]] Index: jabberlib/private.tcl =================================================================== --- jabberlib/private.tcl (revision 0) +++ jabberlib/private.tcl (revision 0) @@ -0,0 +1,119 @@ +# private.tcl -- +# +# This file is part of the jabberlib. +# It handles private XML storage/retrieval, as described in XEP-0049 +# +# Copyright (c) 2009 Sebastian Reitenbach +# +# This file is distributed under BSD style license. +# +# $Id$ +# +############################# USAGE ############################################ +# +# NAME +# private - convenience command library for the private XML +# storage extension. +# +# SYNOPSIS +# jlib::private::init jlibName ?-opt value ...? +# +# INSTANCE COMMANDS +# jlibname private send_get subtags callbackProc +# jlibname private send_set subtags +# +################################################################################ + +package require jlib + +package provide jlib::private 0.1 + +namespace eval jlib::private { + # Note: jlib::ensamble_register is last in this file! +} + +# jlib::private::init -- +# +# Creates a new instance of a private object. +# +# Arguments: +# jlibname: name of existing jabberlib instance +# args: +# +# Results: +# namespaced instance command + +proc jlib::private::init {jlibname args} { + variable xmlns + set xmlns(private) "jabber:iq:private" + + return +} + +# jlib::private::cmdproc -- +# +# Just dispatches the command to the right procedure. +# +# Arguments: +# jlibname: name of existing jabberlib instance +# cmd: +# args: all args to the cmd procedure. +# +# Results: +# none. + +proc jlib::private::cmdproc {jlibname cmd args} { + + # Which command? Just dispatch the command to the right procedure. + return [eval {$cmd $jlibname} $args] +} + +# jlib::private::send_get -- +# +# It implements the 'jabber:iq:private' get method. +# +# Arguments: +# subtags: list of elements to retrieve +# cmd: client command to be executed at the iq "result" element. +# +# Results: +# none. + +proc jlib::private::send_get {subtags cmd} { + variable xmlns + + set attrlist [list xmlns $xmlns(private)] + set xmllist [wrapper::createtag "query" -attrlist $attrlist \ + -subtags [list $subtags]] + jlib::send_iq ::jlib::jlib1 "get" [list $xmllist] -command $cmd + return +} + +# jlib::private::send_set -- +# +# It implements the 'jabber:iq:private' set method. +# +# Arguments: +# subtags: list of elements to store +# +# Results: +# none. + +proc jlib::private::send_set {subtags} { + variable xmlns + + set attrlist [list xmlns $xmlns(private)] + set xmllist [wrapper::createtag "query" -attrlist $attrlist \ + -subtags [list $subtags]] + jlib::send_iq ::jlib::jlib1 "set" [list $xmllist] + return +} + +# We have to do it here since need the initProc before doing this. + +namespace eval jlib::private { + + jlib::ensamble_register private \ + [namespace current]::init \ + [namespace current]::cmdproc +} Index: jabberlib/annotations.tcl =================================================================== --- jabberlib/annotations.tcl (revision 0) +++ jabberlib/annotations.tcl (revision 0) @@ -0,0 +1,129 @@ +# annotations.tcl -- +# +# This file is part of the jabberlib. +# It handles annotations about roster items and other entities, +# as described in XEP-0145 +# +# Copyright (c) 2009 Sebastian Reitenbach +# +# This file is distributed under BSD style license. +# +# $Id$ +# +############################# USAGE ############################################ +# +# NAME +# annotations - convenience command library for the annotations +# storage extension. +# +# SYNOPSIS +# jlib::annotations::init jlibName ?-opt value ...? +# +# INSTANCE COMMANDS +# jlibname annotations send_get storagens callbackProc +# jlibname annotations send_set storagens subtags +# +################################################################################ + +package require jlib::private + +package provide jlib::annotations 0.1 + +namespace eval jlib::annotations { + + # Rosternotes stored as {{jid Notes} ...} + variable rosternotes {} + variable xmlns + set xmlns(rosternotes) "storage:rosternotes" + set xmlns(coccinella) "storage:coccinella" + set xmlns(bookmarks) "storage:bookmarks" + + # Note: jlib::ensamble_register is last in this file! +} + +# jlib::annotations::init -- +# +# Creates a new instance of a annotations object. +# +# Arguments: +# jlibname: name of existing jabberlib instance +# args: +# +# Results: +# namespaced instance command + +proc jlib::annotations::init {jlibname args} { + + return +} + +# jlib::annotations::cmdproc -- +# +# Just dispatches the command to the right procedure. +# +# Arguments: +# jlibname: name of existing jabberlib instance +# cmd: +# args: all args to the cmd procedure. +# +# Results: +# none. + +proc jlib::annotations::cmdproc {jlibname cmd args} { + + # Which command? Just dispatch the command to the right procedure. + return [eval {$cmd $jlibname} $args] +} + +# jlib::annotations::send_get -- +# +# It implements the get method of stored data, for +# for the given storage namespace. +# +# Arguments: +# storagens: retrieve data in given storage xmlns, e.g. rosternotes +# cmd: client command to be executed at the iq "result" element. +# +# Results: +# none. + +proc jlib::annotations::send_get {storagens cmd} { + variable xmlns + + set attrlist [list xmlns $xmlns($storagens)] + set storageElem [wrapper::createtag "storage" -attrlist $attrlist] + + ::jlib::private::send_get $storageElem $cmd +} + +# jlib::annotations::send_set -- +# +# It implements the set method of stored data, for +# the given storage namespace. +# +# Arguments: +# storagens: send data in given storage xmlns, e.g. rosternotes +# subtags: the data to be stored +# +# Results: +# none. + +proc jlib::annotations::send_set {storagens subtags} { + variable xmlns + + ::Debug 4 "jlib::annotations::send_set: storagens=$storagens subtags=$subtags" + set attrlist [list xmlns $xmlns($storagens)] + set storageElem [wrapper::createtag "storage" -attrlist $attrlist \ + -subtags $subtags] + + ::jlib::private::send_set $storageElem +} + +# We have to do it here since need the initProc before doing this. + +namespace eval jlib::private { + + jlib::ensamble_register private \ + [namespace current]::init \ + [namespace current]::cmdproc +}