1# $Id$
2# Implementation of Remote Controlling Clients (XEP-0146)
3# via Ad-Hoc Commands (XEP-0050) for Tkabber.
4#
5
6namespace eval ::remote {
7    array set commands {}
8    array set sessions {}
9    set prefix "::remote::sessions"
10
11    custom::defgroup {Remote Control} \
12	[::msgcat::mc "Remote control options."] -group Tkabber
13
14    custom::defvar options(enable) 1 \
15	[::msgcat::mc "Enable remote control."] \
16	-type boolean -group {Remote Control}
17
18    custom::defvar options(accept_from_myjid) 1 \
19	[::msgcat::mc "Accept connections from my own JID."] \
20	-type boolean -group {Remote Control}
21
22    custom::defvar options(accept_list) "" \
23	[::msgcat::mc "Accept connections from the listed JIDs."] \
24	-type string -group {Remote Control}
25
26    #custom::defvar options(show_my_resources) 1 \
27    #	[::msgcat::mc "Show my own resources in the roster."] \
28    #	-type boolean -group {Remote Control}
29}
30namespace eval ::remote::sessions {}
31
32############################################
33
34proc ::remote::allow_remote_control {xlib from} {
35    variable options
36
37    if {!$options(enable)} {
38	return 0
39    }
40
41    set from [string tolower $from]
42    set myjid [string tolower \
43		      [::xmpp::jid::stripResource \
44			   [connection_jid $xlib]]]
45    set bare_from [string tolower [::xmpp::jid::stripResource $from]]
46
47    if {$options(accept_from_myjid) && [cequal $myjid $bare_from]} {
48	return 1
49    }
50
51    set accept_list [split [string tolower $options(accept_list)] " "]
52    if {$bare_from != "" && [lsearch -exact $accept_list $bare_from] >= 0} {
53	return 1
54    }
55
56    return 0
57}
58
59############################################
60# Register and announce commands via disco
61
62proc ::remote::register_command {node command name args} {
63    variable commands
64
65    set commands(command,$node) $command
66    set commands(name,$node) $name
67    lappend commands(nodes) $node
68
69    ::disco::register_subnode $node \
70	    [namespace code [list common_command_infoitems_handler $node]] \
71	    $name
72}
73
74proc ::remote::common_command_infoitems_handler {node type xlib from lang} {
75    variable commands
76
77    if {![allow_remote_control $xlib $from]} {
78	return {error cancel not-allowed}
79    }
80
81    if {![string equal $node ""] && [info exists commands(command,$node)]} {
82	if {[string equal $type info]} {
83	    return \
84		[list result [list [list category automation \
85				         type command-node \
86				         name [::trans::trans $lang \
87						    $commands(name,$node)]]] \
88			     [list $::NS(commands)] {}]
89	} else {
90	    return [list result {}]
91	}
92    } else {
93	return {error modify bad-request}
94    }
95}
96
97proc ::remote::commands_list_handler {type xlib from lang} {
98    variable commands
99
100    if {![allow_remote_control $xlib $from]} {
101	return {error cancel not-allowed}
102    }
103
104    set myjid [connection_jid $xlib]
105
106    switch -- $type {
107	items {
108	    set items {}
109	    foreach node $commands(nodes) {
110		lappend items [list jid $myjid \
111				    node $node \
112				    name [::trans::trans $lang \
113						    $commands(name,$node)]]
114	    }
115	    return [list result $items]
116	}
117	info {
118	    return [list result [list [list category automation \
119					    type command-list \
120					    name [::trans::trans $lang \
121							"Remote control"]]] \
122				{} {}]
123	}
124    }
125}
126
127::disco::register_feature $::NS(commands)
128::disco::register_node $::NS(commands) \
129    ::remote::commands_list_handler [::trans::trans "Remote control"]
130
131#######################################
132# Base engine.
133
134proc ::remote::clear_session {session node} {
135    variable commands
136    variable sessions
137
138    if {![info exists commands(command,$node)]} return
139
140    $commands(command,$node) $session cancel {}
141
142    upvar 0 $session state
143    catch {unset sessions($state(xlib),$state(from),$state(node),$state(id))}
144
145    catch {unset $session}
146}
147
148proc ::remote::create_session {node xlib from lang} {
149    variable commands
150    variable sessions
151    variable prefix
152
153    if {![info exists commands(command,$node)]} return
154
155    set id [rand 1000000000]
156    while {[info exists sesssions($xlib,$from,$node,$id)]} {
157	set id [rand 1000000000]
158    }
159
160    set counter 1
161    while {[info exists "${prefix}::${counter}"]} {
162	incr counter
163    }
164
165    set session "${prefix}::${counter}"
166    upvar 0 $session state
167
168    set state(id) $id
169    set state(xlib) $xlib
170    set state(from) $from
171    set state(node) $node
172    set state(lang) $lang
173    set sessions($xlib,$from,$node,$id) $session
174
175    return $session
176}
177
178proc ::remote::command_set_handler {xlib from child args} {
179    variable commands
180    variable sessions
181
182    if {![allow_remote_control $xlib $from]} {
183	return {error cancel not-allowed}
184    }
185
186    ::xmpp::xml::split $child tag xmlns attrs cdata subels
187
188    set node [::xmpp::xml::getAttr $attrs node]
189    set action [::xmpp::xml::getAttr $attrs action]
190    set id [::xmpp::xml::getAttr $attrs sessionid]
191
192    set lang [::xmpp::xml::getAttr $args -lang en]
193
194    if {![info exists commands(command,$node)]} {
195	return {error cancel item-not-found}
196    }
197
198    if {[cequal $id ""]} {
199	# We use lang only when create session.
200	# Probably it would be better to use it after every request.
201	set session [create_session $node $xlib $from $lang]
202    } else {
203	if {![info exists sessions($xlib,$from,$node,$id)]} {
204	    return [get_error modify bad-request bad-sessionid]
205	}
206	set session $sessions($xlib,$from,$node,$id)
207    }
208
209    upvar 0 $session state
210    set id $state(id)
211
212    if {[cequal $action cancel]} {
213	clear_session $session $node
214	return [list result [::xmpp::xml::create command \
215				 -xmlns $::NS(commands) \
216				 -attrs [list sessionid $id \
217					      node $node \
218					      status canceled]]]
219    }
220
221    set result [$commands(command,$node) $session $action $subels]
222
223    set status [lindex $result 0]
224    switch -- $status {
225	error {
226	    set error_type [lindex $result 1]
227	    if {![cequal $error_type "modify"]} {
228		clear_session $session $node
229	    }
230	    return $result
231	}
232	completed {
233	    clear_session $session $node
234	}
235	executing {}
236	default {
237	    clear_session $session $node
238	    return {error wait internal-server-error}
239	}
240    }
241
242    return [list result [::xmpp::xml::create command \
243			     -xmlns $::NS(commands) \
244			     -attrs [list sessionid $id \
245					  node $node \
246					  status $status] \
247			     -subelements [lrange $result 1 end]]]
248}
249
250::xmpp::iq::register set command $::NS(commands) ::remote::command_set_handler
251
252proc ::remote::get_error {type general {specific ""}} {
253    set res [list error $type $general]
254    if {![cequal $specific ""]} {
255	lappend res -application-specific \
256	    [::xmpp::xml::create $specific -xmlns $::NS(commands)]
257    }
258    return $res
259}
260
261
262############################################
263# Common functions for command implementations.
264
265# Scheduler for one-step dialogs and wizards
266proc ::remote::standard_scheduler {steps prefix session action children} {
267    upvar 0 $session state
268
269    if {[cequal $action cancel]} {
270	for {set i 1} {$i <= $steps} {incr i} {
271	    ${prefix}clear_step$i $session
272	}
273	return
274    }
275
276    if {![info exists state(step)] } {
277	# First step
278
279	if {[cequal $action "execute"] || [cequal $action ""]} {
280
281	    set state(step) 1
282	    return [${prefix}get_step$state(step) $session]
283
284	} else {
285	    return [::remote::get_error modify bad-request bad-action]
286	}
287
288    } elseif {($state(step) < $steps) && ($state(step) > 0)} {
289	# Inner step
290	if {[cequal $action "next"] || [cequal $action "execute"] || [cequal $action ""]} {
291
292	    set res [${prefix}set_step$state(step) $session $children]
293	    if {[cequal [lindex $res 0] error]} {
294		return $res
295	    }
296
297	    incr state(step)
298	    return [${prefix}get_step$state(step) $session]
299
300	} elseif {[cequal $action "prev"]} {
301
302	    incr state(step) -1
303	    ${prefix}clear_step$state(step) $session
304
305	    return [${prefix}get_step$state(step) $session]
306
307	} elseif {[cequal $action "complete"]} {
308
309	    set res [${prefix}set_step$state(step) $session $children]
310	    if {[cequal [lindex $res 0] error]} {
311		return $res
312	    }
313
314	    return [${prefix}get_finish $session]
315
316	} else {
317	    return [::remote::get_error modify bad-request bad-action]
318	}
319
320
321    } elseif {$state(step) == $steps} {
322	# Last step
323	if {[cequal $action complete] || [cequal $action execute] || [cequal $action ""]} {
324
325	    set res [${prefix}set_step$state(step) $session $children]
326	    if {[cequal [lindex $res 0] error]} {
327		return $res
328	    }
329
330	    return [${prefix}get_finish $session]
331
332	} elseif {[cequal $action "prev"]} {
333
334	    incr state(step) -1
335	    ${prefix}clear_step$state(step) $session
336
337	    return [${prefix}get_step$state(step) $session]
338
339	} else {
340	    return [::remote::get_error modify bad-request bad-action]
341	}
342
343    } else {
344	return {error wait internal-server-error}
345    }
346}
347
348# Parse form result and returns array with values, check for correct form type
349proc ::remote::standard_parseresult {children_b form_type} {
350    set result {}
351
352    lassign [::xmpp::data::findForm $children_b] type form
353
354    if {![string equal $type submit]} {
355	return [::remote::get_error modify bad-request bad-payload]
356    }
357
358    foreach {tag field} [::xmpp::data::parseSubmit $form] {
359	lassign $field var type label values
360	switch -- $var {
361	    FORM_TYPE {
362		if {![string equal [lindex $values 0] $form_type]} {
363		    return [::remote::get_error modify bad-request bad-payload]
364		}
365	    }
366	    default {
367		lappend result $var $values
368	    }
369	}
370    }
371
372    return $result
373}
374
375############################
376#Change status
377namespace eval ::remote::change_status {}
378
379proc ::remote::change_status::scheduler {session action children} {
380    return [::remote::standard_scheduler 1 "[namespace current]::" \
381					 $session $action $children]
382}
383::remote::register_command "http://jabber.org/protocol/rc#set-status" \
384    ::remote::change_status::scheduler [::trans::trans "Change status"]
385
386# step1:
387# send standard form
388proc ::remote::change_status::get_step1 {session} {
389    global userstatus
390    global textstatus
391    global userpriority
392
393    upvar 0 $session state
394    set lang $state(lang)
395
396    set fields \
397	[concat [::xmpp::data::formField field \
398			-var FORM_TYPE \
399			-type hidden \
400			-value "http://jabber.org/protocol/rc"] \
401		[::xmpp::data::formField title \
402			-value [::trans::trans $lang "Change Status"]] \
403		[::xmpp::data::formField instructions \
404			-value [::trans::trans $lang \
405				    "Choose status, priority, and\
406				     status message"]]]
407
408    set options {}
409    foreach {status statusdesc} \
410	    [list available   [::trans::trans $lang "Available"]      \
411		  chat        [::trans::trans $lang "Free to chat"]   \
412		  away        [::trans::trans $lang "Away"]           \
413		  xa          [::trans::trans $lang "Extended away"]  \
414		  dnd         [::trans::trans $lang "Do not disturb"] \
415		  unavailable [::trans::trans $lang "Unavailable"]] {
416	lappend options $statusdesc $status
417    }
418    set fields \
419	[concat $fields \
420		[::xmpp::data::formField field \
421			-var status \
422			-type list-single \
423			-label [::trans::trans $lang "Status"] \
424			-required 1 \
425			-value $userstatus \
426			-options $options] \
427		[::xmpp::data::formField field \
428			-var status-priority \
429			-type text-single \
430			-label [::trans::trans $lang "Priority"] \
431			-value $userpriority \
432			-required 1] \
433		[::xmpp::data::formField field \
434			-var status-message \
435			-type text-multi \
436			-label [::trans::trans $lang "Message"] \
437			-values [split $textstatus "\n"]]]
438
439    return [list executing [::xmpp::data::form $fields]]
440}
441
442proc ::remote::change_status::set_step1 {session children} {
443    upvar 0 $session state
444
445    set result [remote::standard_parseresult $children \
446					     "http://jabber.org/protocol/rc"]
447
448    if {[cequal [lindex $result 0] error]} {
449	return $result
450    }
451    array set params $result
452
453    if {![info exists params(status)] || \
454	![info exists params(status-priority)] || \
455	![info exists ::statusdesc($params(status))] || \
456	[catch {expr int($params(status-priority))}]} {
457	return [::remote::get_error modify bad-request bad-payload]
458    }
459
460    set state(textstatus) {}
461    catch {
462	set state(textstatus) \
463	    [join $params(status-message) "\n"]
464    }
465
466    set state(userstatus) \
467	[lindex $params(status) 0]
468    set state(userpriority) \
469	[lindex $params(status-priority) 0]
470
471    return {}
472}
473
474proc ::remote::change_status::clear_step1 {session} {}
475
476# finish:
477# change status
478# report
479proc ::remote::change_status::get_finish {session} {
480    global userstatus
481    global textstatus
482    global userpriority
483
484    upvar 0 $session state
485    set lang $state(lang)
486
487    if {$state(userstatus) != "unavailable"} {
488	set textstatus $state(textstatus)
489	set userpriority $state(userpriority)
490	set userstatus $state(userstatus)
491    } else {
492	# Special processing -- disconnect current session.
493	# It is scheduled for idle processing so that the remote-command
494	# processing machinery has a chance to send the result.
495	after idle [list ::logout $state(xlib)]
496    }
497
498    return [list completed [::xmpp::xml::create note \
499				-attrs {type info} \
500				-cdata \
501				    [::trans::trans $lang \
502					 "Status was changed successfully"]]]
503}
504
505
506############################
507# Leave groupchats
508namespace eval ::remote::leave_groupchats {}
509
510proc ::remote::leave_groupchats::scheduler {session action children} {
511    return [::remote::standard_scheduler 1 "[namespace current]::" $session $action $children]
512}
513::remote::register_command "http://jabber.org/protocol/rc#leave-groupchats" \
514    ::remote::leave_groupchats::scheduler [::trans::trans "Leave groupchats"]
515
516# step1:
517# allow users to choose which chats to leave
518proc ::remote::leave_groupchats::get_step1 {session} {
519    upvar 0 $session state
520
521    set options {}
522    set lang $state(lang)
523    set xlib $state(xlib)
524    foreach chatid [lfilter chat::is_groupchat [chat::opened $xlib]] {
525	set jid [chat::get_jid $chatid]
526	if {![cequal [get_jid_presence_info show $xlib $jid] ""]} {
527	    set nick [get_our_groupchat_nick $chatid]
528	    lappend options [format [::trans::trans $lang "%s at %s"] \
529				    $nick $jid] $jid
530	}
531    }
532    if {[llength $options] == 0} {
533	return [list completed [::xmpp::xml::create note \
534				    -attrs {type info} \
535				    -cdata [::trans::trans $lang \
536						 "No groupchats to leave"]]]
537    }
538
539    set fields \
540	[concat [::xmpp::data::formField field \
541			-var FORM_TYPE \
542			-type hidden \
543			-value "http://jabber.org/protocol/rc"] \
544		[::xmpp::data::formField title \
545			-value [::trans::trans $lang "Leave Groupchats"]] \
546		[::xmpp::data::formField instructions \
547			-value [::trans::trans $lang \
548				    "Choose groupchats you want to leave"]] \
549		[::xmpp::data::formField field \
550			-var x-all \
551			-type boolean \
552			-label [::trans::trans $lang "Leave all groupchats"] \
553			-value 0] \
554		[::xmpp::data::formField field \
555			-var groupchats \
556			-type list-multi \
557			-label [::trans::trans $lang "Groupchats"] \
558			-required 1 \
559			-options $options] \
560		[::xmpp::data::formField field \
561			-var x-reason \
562			-type text-single \
563			-label [::trans::trans $lang "Reason"]]]
564
565    return [list executing [::xmpp::data::form $fields]]
566}
567
568proc ::remote::leave_groupchats::set_step1 {session children} {
569    upvar 0 $session state
570
571    set result [remote::standard_parseresult $children \
572					     "http://jabber.org/protocol/rc"]
573    if {[cequal [lindex $result 0] error]} {
574	return $result
575    }
576    array set params $result
577
578    if {![info exists params(groupchats)]} {
579	return [::remote::get_error modify bad-request bad-payload]
580    }
581
582    set state(all) [lindex $params(x-all) 0]
583    set state(groupchats) $params(groupchats)
584    set state(reason) ""
585    catch {
586	set state(reason) [lindex $params(x-reason) 0]
587    }
588    return {}
589
590}
591
592proc ::remote::leave_groupchats::clear_step1 {session} {}
593
594# finish step
595# leave groupchats.
596# report
597proc ::remote::leave_groupchats::get_finish {session} {
598    upvar 0 $session state
599
600    set xlib $state(xlib)
601    set args {}
602    set lang $state(lang)
603
604    if {![string equal $state(reason) ""]} {
605	lappend args -status $state(reason)
606    }
607
608    # "all" workaround, will be removed soon
609    if $state(all) {
610	set state(groupchats) ""
611
612	foreach chatid [lfilter chat::is_groupchat [chat::opened $xlib]] {
613	    set jid [chat::get_jid $chatid]
614	    if {![string equal [get_jid_presence_info show $xlib $jid] ""]} {
615		lappend state(groupchats) $jid
616	    }
617	}
618    }
619
620    foreach jid $state(groupchats) {
621	eval [list send_presence $xlib unavailable -to $jid] $args
622    }
623
624    return [list completed [::xmpp::xml::create note \
625				-attrs {type info} \
626				-cdata [::trans::trans $lang \
627					     "Groupchats were left\
628					      successfully"]]]
629}
630
631################################
632# Forward unread messages
633namespace eval ::remote::forward {
634    array set unread {}
635}
636
637proc ::remote::forward::scheduler {session action children} {
638    return [::remote::standard_scheduler 1 "[namespace current]::" $session $action $children]
639}
640::remote::register_command "http://jabber.org/protocol/rc#forward" \
641    ::remote::forward::scheduler [::trans::trans "Forward unread messages"]
642
643# step1:
644# form with list of unreaded correspondence
645proc ::remote::forward::get_step1 {session} {
646    upvar 0 $session state
647    variable unread
648
649    set options {}
650    set lang $state(lang)
651    set xlib $state(xlib)
652    foreach id [array names unread] {
653	lassign $id type chatid
654	if {![cequal [chat::get_xlib $chatid] $xlib]} continue
655
656	set jid [chat::get_jid $chatid]
657	set rjid [::roster::find_jid $xlib $jid]
658	set name [::roster::itemconfig $xlib $rjid -name]
659	if {$rjid != "" && $name != ""} {
660	    set name [format "%s (%s)" $name $jid]
661	} else {
662	    set name $jid
663	}
664
665	set count [llength $unread($id)]
666
667	switch -- $type {
668	    chat      {set msg [::trans::trans $lang "%s: %s chat message(s)"]}
669	    groupchat {set msg [::trans::trans $lang "%s: %s groupchat message(s)"]}
670	    headline  {set msg [::trans::trans $lang "%s: %s headline message(s)"]}
671	    normal    {set msg [::trans::trans $lang "%s: %s normal message(s)"]}
672	    default   {set msg [::trans::trans $lang "%s: %s unknown message(s)"]}
673	}
674
675	lappend options [format $msg $name $count] $id
676    }
677    if {[llength $options] == 0} {
678	return [list completed [::xmpp::xml::create note \
679				    -attrs {type info} \
680				    -cdata \
681					[::trans::trans $lang \
682					     "There are no unread messages"]]]
683    }
684
685    set fields \
686	[concat [::xmpp::data::formField field \
687    			-var FORM_TYPE \
688			-type hidden \
689    			-value "tkabber:plugins:remote:forward_form"] \
690		[::xmpp::data::formField title \
691			-value [::trans::trans $lang \
692				    "Forward Unread Messages"]] \
693		[::xmpp::data::formField instructions \
694			-value [::trans::trans $lang \
695				    "Choose chats or groupchats from which you\
696				     want to forward messages"]] \
697		[::xmpp::data::formField field \
698			-var all \
699			-type boolean \
700			-label [::trans::trans $lang "Forward all messages"] \
701			-value 0] \
702		[::xmpp::data::formField field \
703			-var chats \
704			-type list-multi \
705			-label [::trans::trans $lang "Forward messages from"] \
706			-required 1 \
707			-options $options]]
708
709    return [list executing [::xmpp::data::form $fields]]
710}
711
712proc ::remote::forward::set_step1 {session children} {
713    upvar 0 $session state
714
715    set result [remote::standard_parseresult $children \
716					     "tkabber:plugins:remote:forward_form"]
717    if {[cequal [lindex $result 0] error]} {
718	return $result
719    }
720    array set params $result
721
722    if {![info exists params(chats)]} {
723	return [::remote::get_error modify bad-request bad-payload]
724    }
725
726    set state(all) [lindex $params(all) 0]
727    set state(chats) $params(chats)
728    return {}
729}
730
731proc ::remote::forward::clear_step1 {session} {}
732
733# finish:
734# forward selected unread messages
735# report
736proc ::remote::forward::get_finish {session} {
737    upvar 0 $session state
738    variable unread
739
740    set xlib $state(xlib)
741    set lang $state(lang)
742    set oto [connection_jid $xlib]
743    set target $state(from)
744
745    # "all" workaround, will be removed soon
746    if $state(all) {
747	set state(chats) {}
748
749	foreach id [array names unread] {
750	    lassign $id type chatid
751	    if {![cequal [chat::get_xlib $chatid] $xlib]} continue
752	    lappend state(chats) $id
753	}
754    }
755
756    foreach id $state(chats) {
757	forward_messages $id $xlib $oto $target
758    }
759
760    return [list completed \
761		 [::xmpp::xml::create note \
762		      -attrs {type info} \
763		      -cdata [::trans::trans $lang \
764				   "Unread messages were forwarded\
765				    successfully"]]]
766}
767
768#############################
769# Forward namespace
770
771# forwards messages
772# leaves marks that they were forwarded.
773# cleanup arrays
774proc ::remote::forward::forward_messages {id xlib oto target} {
775    variable unread
776    variable msgdata
777
778    lassign $id type chatid
779
780    if {![info exists unread($id)]} {
781	return
782    }
783
784    foreach elem $unread($id) {
785
786	switch -- $type {
787	    groupchat -
788	    chat {
789		lassign $elem date ofrom body x
790	    }
791	    normal {
792		lassign $msgdata($elem) date ofrom body x
793	    }
794	}
795
796	lappend x [::xmpp::xml::create addresses \
797		       -xmlns $::NS(xaddress) \
798		       -subelement [::xmpp::xml::create address \
799					   -attrs [list type ofrom \
800						        jid $ofrom]] \
801		       -subelement [::xmpp::xml::create address \
802					   -attrs [list type oto \
803						        jid $oto]]]
804
805	lappend x [::xmpp::delay::create $date]
806
807	::xmpp::sendMessage $xlib $target -body $body \
808					  -type $type \
809					  -xlist $x
810
811	switch -- $type {
812	    normal {
813		set lab \
814		    [Label $elem.forwlab \
815			   -text [::msgcat::mc \
816				      "This message was forwarded to %s" \
817				      $target]]
818		pack $lab -anchor w -fill none -expand no -before $elem.title
819
820		catch {unset msgdata($elem)}
821	    }
822	}
823    }
824
825    catch {unset unread($id)}
826    switch -- $type {
827	groupchat -
828	chat {
829	    after idle \
830		  [list ::chat::add_message $chatid $ofrom info \
831			[::msgcat::mc "All unread messages were forwarded to %s." \
832			     $target] \
833			{}]
834	}
835    }
836}
837
838# store message into the unread if type == chat
839proc ::remote::forward::draw_message_handler {chatid from type body extras} {
840    variable unread
841
842    if {[ifacetk::chat_window_is_active $chatid]} return
843
844    if {![lcontain {chat groupchat} $type]} return
845#    if {![cequal chat $type]} return
846
847    if {$from == ""} {
848	# Don't forward service messages
849	return
850    }
851
852    set date [clock seconds]
853    set message [list $date $from $body $extras]
854    set id [list $type $chatid]
855    lappend unread($id) $message
856
857    return 0
858}
859
860hook::add draw_message_hook ::remote::forward::draw_message_handler 19
861
862# clear list of unread messages with type == chat
863proc ::remote::forward::trace_number_msg {var1 chatid mode} {
864    variable unread
865
866    if {$::ifacetk::number_msg($chatid) == 0} {
867	if {[chat::is_chat $chatid]} {
868	    set type chat
869	} else {
870	    set type groupchat
871	}
872	set id [list $type $chatid]
873	catch {unset unread($id)}
874    }
875
876}
877
878trace variable ::ifacetk::number_msg r ::remote::forward::trace_number_msg
879
880# store message with type == normal
881proc ::remote::forward::message_process_x \
882     {rowvar bodyvar f x xlib from id type replyP} {
883    upvar 2 $rowvar row
884    upvar 2 $bodyvar body
885    variable unread
886    variable msgdata
887
888    if {!$replyP || [cequal $type error]} {
889	return
890    }
891
892    set id [list normal [chat::chatid $xlib $from]]
893
894    if {![info exists unread($id)]} {
895	set unread($id) {}
896    }
897
898    set msgwin [winfo toplevel $f]
899    lappend unread($id) $msgwin
900
901    bind $f <Destroy> \
902	 +[double% [namespace code [list on_msgwin_destroy $msgwin $id]]]
903
904    set date [clock seconds]
905    set msgdata($msgwin) [list $date $from $body $x]
906
907    return
908}
909
910hook::add message_process_x_hook ::remote::forward::message_process_x
911
912# clear message with type == normal if it was closed
913proc ::remote::forward::on_msgwin_destroy {msgwin id} {
914    variable unread
915    variable msgdata
916
917    if {![info exists unread($id)]} return
918
919    if {[set index [lsearch -exact $unread($id) $msgwin]] >= 0} {
920	set unread($id) [lreplace $unread($id) $index $index]
921	catch {unset msgdata($msgwin)}
922    }
923
924    if {[llength $unread($id)] == 0} {
925	catch {unset unread($id)}
926    }
927}
928
929# vim:ts=8:sts=4:sw=4:noet
930