1# $Id$ 2# 3# Obsolete jabberd 1.4 mod_filter (which has been never documented in XEP) support. 4# 5 6 7namespace eval filters { 8 set condtags {unavailable from resource subject body show type} 9 set acttags {settype forward reply offline continue} 10 11 12 set fromtag(unavailable) [::msgcat::mc "I'm not online"] 13 set fromtag(from) [::msgcat::mc "the message is from"] 14 set fromtag(resource) [::msgcat::mc "the message is sent to"] 15 set fromtag(subject) [::msgcat::mc "the subject is"] 16 set fromtag(body) [::msgcat::mc "the body is"] 17 set fromtag(show) [::msgcat::mc "my status is"] 18 set fromtag(type) [::msgcat::mc "the message type is"] 19 set fromtag(settype) [::msgcat::mc "change message type to"] 20 set fromtag(forward) [::msgcat::mc "forward message to"] 21 set fromtag(reply) [::msgcat::mc "reply with"] 22 set fromtag(offline) [::msgcat::mc "store this message offline"] 23 set fromtag(continue) [::msgcat::mc "continue processing rules"] 24 25 set totag($fromtag(unavailable)) unavailable 26 set totag($fromtag(from)) from 27 set totag($fromtag(resource)) resource 28 set totag($fromtag(subject)) subject 29 set totag($fromtag(body)) body 30 set totag($fromtag(show)) show 31 set totag($fromtag(type)) type 32 set totag($fromtag(settype)) settype 33 set totag($fromtag(forward)) forward 34 set totag($fromtag(reply)) reply 35 set totag($fromtag(offline)) offline 36 set totag($fromtag(continue)) continue 37 38 set rulecondmenu [list $fromtag(unavailable) $fromtag(from) \ 39 $fromtag(resource) $fromtag(subject) $fromtag(body) \ 40 $fromtag(show) $fromtag(type)] 41 42 set ruleactmenu [list $fromtag(settype) $fromtag(forward) $fromtag(reply) \ 43 $fromtag(offline) $fromtag(continue)] 44 45 set m [menu .rulecondmenu -tearoff 0] 46 $m add command -label $fromtag(unavailable) 47 $m add command -label $fromtag(from) 48 $m add command -label $fromtag(resource) 49 $m add command -label $fromtag(subject) 50 $m add command -label $fromtag(body) 51 $m add command -label $fromtag(show) 52 $m add command -label $fromtag(type) 53 54 set m [menu .ruleactmenu -tearoff 0] 55 $m add command -label $fromtag(settype) 56 $m add command -label $fromtag(forward) 57 $m add command -label $fromtag(reply) 58 $m add command -label $fromtag(offline) 59 $m add command -label $fromtag(continue) 60 61 custom::defgroup Privacy [::msgcat::mc "Blocking communication options."] -group Tkabber 62 63 custom::defvar options(enable) 0 \ 64 [::msgcat::mc "Enable jabberd 1.4 mod_filter support (obsolete)."] \ 65 -type boolean -group Privacy \ 66 -command [namespace code setup_menu] 67} 68 69proc filters::setup_menu {args} { 70 variable options 71 72 set mlabel [::msgcat::mc "Edit message filters"] 73 74 set m [.mainframe getmenu privacy] 75 catch { set idx [$m index $mlabel] } 76 77 if {$options(enable) && ![info exists idx]} { 78 $m add separator 79 $m add command -label $mlabel -command [namespace code open] 80 return 81 } 82 83 if {!$options(enable) && [info exists idx]} { 84 $m delete [expr {$idx - 1}] $idx 85 return 86 } 87} 88 89hook::add finload_hook [namespace current]::filters::setup_menu 90 91proc filters::open {} { 92 variable rf 93 94 if {[winfo exists .filters]} { 95 .filters draw 96 return 97 } 98 99 set xlib [lindex [connections] 0] 100 101 ::xmpp::sendIQ $xlib get \ 102 -query [::xmpp::xml::create item -xmlns jabber:iq:filter] \ 103 -command [list filters::recv] 104} 105 106 107proc filters::recv {res child} { 108 variable rf 109 variable rule 110 variable rulelist 111 112 debugmsg filters "$res $child" 113 114 if {![string equal $res ok]} { 115 MessageDlg .filters_err -aspect 50000 -icon error \ 116 -message [::msgcat::mc "Requesting filter rules: %s" \ 117 [error_to_string $child]] \ 118 -type user -buttons ok -default 0 -cancel 0 119 return 120 } 121 122 123 Dialog .filters -title [::msgcat::mc "Filters"] -separator 1 -anchor e \ 124 -modal none \ 125 -default 0 -cancel 1 126 127 set f [.filters getframe] 128 129 set bf [frame $f.bf] 130 pack $bf -side right -anchor n 131 132 set bb [ButtonBox $bf.bb -orient vertical -spacing 0] 133 $bb add -text [::msgcat::mc "Add"] -command {filters::add} 134 $bb add -text [::msgcat::mc "Edit"] -command {filters::edit} 135 $bb add -text [::msgcat::mc "Remove"] -command {filters::remove} 136 $bb add -text [::msgcat::mc "Move up"] -command {filters::move -1} 137 $bb add -text [::msgcat::mc "Move down"] -command {filters::move 1} 138 pack $bb -side top 139 140 set sw [ScrolledWindow $f.sw] 141 set rf [listbox $sw.rules] 142 pack $sw -expand yes -fill both 143 $sw setwidget $rf 144 145 set ok [.filters add -text [::msgcat::mc "OK"] \ 146 -command {filters::commit}] 147 .filters add -text [::msgcat::mc "Cancel"] -command {destroy .filters} 148 149 $rf delete 0 end 150 array unset rule 151 set rulelist {} 152 153 ::xmpp::xml::split $child tag xmlns attrs cdata subels 154 155 if {[string equal $xmlns jabber:iq:filter]} { 156 foreach child $subels { 157 process_rule $child 158 } 159 } 160 $rf activate 0 161 162 .filters draw 163} 164 165proc filters::process_rule {child} { 166 variable rf 167 variable rulelist 168 169 ::xmpp::xml::split $child tag xmlns attrs cdata subels 170 171 set rname [::xmpp::xml::getAttr $attrs name] 172 $rf insert end $rname 173 lappend rulelist $rname 174 175 foreach data $subels { 176 process_rule_data $rname $data 177 } 178} 179 180proc filters::process_rule_data {name child} { 181 variable rule 182 183 ::xmpp::xml::split $child tag xmlns attrs cdata subels 184 185 lappend rule($name) $tag $cdata 186 debugmsg filters [array get rule] 187} 188 189proc filters::edit {} { 190 variable rf 191 192 set name [$rf get active] 193 debugmsg filters $name 194 if {$name != ""} { 195 open_edit $name 196 } 197} 198 199 200proc filters::open_edit {rname} { 201 variable rule 202 variable tmp 203 204 set w [win_id rule $rname] 205 206 if {[winfo exists $w]} { 207 focus -force $w 208 return 209 } 210 211 Dialog $w -title [::msgcat::mc "Edit rule"] -separator 1 -anchor e -modal none \ 212 -default 0 -cancel 1 213 214 set f [$w getframe] 215 216 label $f.lrname -text [::msgcat::mc "Rule Name:"] 217 entry $f.rname -textvariable filters::tmp($rname,name) 218 set tmp($rname,name) $rname 219 220 grid $f.lrname -row 0 -column 0 -sticky e 221 grid $f.rname -row 0 -column 1 -sticky ew 222 223 set cond [TitleFrame $f.cond -text [::msgcat::mc "Condition"] -borderwidth 2 -relief groove] 224 set fc [$cond getframe] 225 226 button $fc.add -text [::msgcat::mc "Add"] 227 pack $fc.add -side right -anchor n 228 229 set swc [ScrolledWindow $fc.sw -relief sunken -borderwidth $::tk_borderwidth] 230 pack $swc -expand yes -fill both 231 set sfc [ScrollableFrame $swc.f -height 100] 232 $swc setwidget $sfc 233 234 grid $cond -row 1 -column 0 -sticky news -columnspan 2 235 236 set act [TitleFrame $f.act -text [::msgcat::mc "Action"] -borderwidth 2 -relief groove] 237 set fa [$act getframe] 238 239 button $fa.add -text [::msgcat::mc "Add"] 240 pack $fa.add -side right -anchor n 241 242 set swa [ScrolledWindow $fa.sw -relief sunken -borderwidth $::tk_borderwidth] 243 pack $swa -expand yes -fill both 244 set sfa [ScrollableFrame $swa.f -height 100] 245 $swa setwidget $sfa 246 247 grid $act -row 2 -column 0 -sticky news -columnspan 2 248 249 250 grid columnconfig $f 1 -weight 1 -minsize 0 251 grid rowconfig $f 1 -weight 1 252 grid rowconfig $f 2 -weight 1 253 254 set fcond [$sfc getframe] 255 set fact [$sfa getframe] 256 257 $w add -text [::msgcat::mc "OK"] -command [list filters::accept_rule $w $rname $fcond $fact] 258 $w add -text [::msgcat::mc "Cancel"] -command [list destroy $w] 259 260 variable ruleactmenu 261 variable rulecondmenu 262 $fc.add configure \ 263 -command [list filters::insert_item \ 264 $fcond unavailable "" $rulecondmenu] 265 $fa.add configure \ 266 -command [list filters::insert_item $fact settype "" $ruleactmenu] 267 268 fill_rule $rname $fcond $fact 269 270 $w draw 271} 272 273 274proc filters::fill_rule {rname fcond fact} { 275 variable rule 276 variable condtags 277 variable acttags 278 variable ruleactmenu 279 variable rulecondmenu 280 variable items 281 282 set items($fcond) {} 283 set items($fact) {} 284 foreach {tag value} $rule($rname) { 285 if {[lcontain $condtags $tag]} { 286 debugmsg filters "C $tag $value" 287 insert_item $fcond $tag $value $rulecondmenu 288 } elseif {[lcontain $acttags $tag]} { 289 debugmsg filters "A $tag $value" 290 insert_item $fact $tag $value $ruleactmenu 291 } 292 } 293} 294 295 296 297proc filters::insert_item {f tag val menu} { 298 variable items 299 variable fromtag 300 301 if {[llength $items($f)]} { 302 set n [expr {[lindex $items($f) [expr {[llength $items($f)] - 1}]] + 1}] 303 } else { 304 set n 0 305 } 306 307 # TODO: hiding entry for some tags 308 eval [list OptionMenu $f.mb$n $f.mb$n.var] $menu 309 global $f.mb$n.var 310 set $f.mb$n.var $fromtag($tag) 311 entry $f.e$n 312 $f.e$n insert 0 $val 313 Separator $f.sep$n -orient vertical 314 button $f.remove$n -text [::msgcat::mc "Remove"] -command [list filters::remove_item $f $n] 315 316 grid $f.mb$n -row $n -column 0 -sticky ew 317 grid $f.e$n -row $n -column 1 -sticky ew 318 grid $f.sep$n -row $n -column 2 -sticky ew 319 grid $f.remove$n -row $n -column 3 -sticky ew 320 321 322 lappend items($f) $n 323 debugmsg filters $items($f) 324} 325 326proc filters::remove_item {f n} { 327 variable items 328 329 set idx [lsearch -exact $items($f) $n] 330 set items($f) [lreplace $items($f) $idx $idx] 331 332 eval destroy [grid slaves $f -row $n] 333 334 debugmsg filters $items($f) 335} 336 337proc filters::accept_rule {w rname fcond fact} { 338 variable items 339 variable totag 340 variable rule 341 variable tmp 342 variable rf 343 variable rulelist 344 345 set newname $tmp($rname,name) 346 if {$newname == ""} { 347 MessageDlg .rname_err -aspect 50000 -icon error \ 348 -message [::msgcat::mc "Empty rule name"] -type user \ 349 -buttons ok -default 0 -cancel 0 350 return 351 } 352 if {$rname != $newname && [lcontain $rulelist $newname]} { 353 MessageDlg .rname_err -aspect 50000 -icon error \ 354 -message [::msgcat::mc "Rule name already exists"] -type user \ 355 -buttons ok -default 0 -cancel 0 356 return 357 } 358 359 360 set rule($newname) {} 361 foreach n $items($fcond) { 362 set tag $totag([set ::$fcond.mb$n.var]) 363 set val [$fcond.e$n get] 364 debugmsg filters "$tag $val" 365 lappend rule($newname) $tag $val 366 } 367 368 foreach n $items($fact) { 369 set tag $totag([set ::$fact.mb$n.var]) 370 set val [$fact.e$n get] 371 debugmsg filters "$tag $val" 372 lappend rule($newname) $tag $val 373 } 374 375 debugmsg filters [array get rule] 376 377 set idx [lsearch -exact $rulelist $rname] 378 set rulelist [lreplace $rulelist $idx $idx $newname] 379 380 $rf delete 0 end 381 foreach r $rulelist { 382 $rf insert end $r 383 } 384 385 386 set items($fcond) {} 387 set items($fact) {} 388 destroy $w 389} 390 391proc filters::add {} { 392 variable rule 393 set rule() {} 394 open_edit "" 395} 396 397proc filters::remove {} { 398 variable rf 399 variable rulelist 400 401 set name [$rf get active] 402 debugmsg filters $name 403 if {$name != ""} { 404 set idx [lsearch -exact $rulelist $name] 405 set rulelist [lreplace $rulelist $idx $idx] 406 $rf delete active 407 debugmsg filters $rulelist 408 } 409} 410 411proc filters::commit {} { 412 variable rulelist 413 variable rule 414 415 set result {} 416 foreach rname $rulelist { 417 set rtags {} 418 foreach {tag val} $rule($rname) { 419 lappend rtags [::xmpp::xml::create $tag -cdata $val] 420 } 421 422 lappend result [::xmpp::xml::create rule \ 423 -attrs [list name $rname] \ 424 -subelements $rtags] 425 } 426 427 debugmsg filters $result 428 429 set xlib [lindex [connections] 0] 430 431 ::xmpp::sendIQ $xlib set \ 432 -query [::xmpp::xml::create item \ 433 -xmlns jabber:iq:filter \ 434 -subelements $result] 435 436 destroy .filters 437} 438 439proc filters::move {shift} { 440 variable rulelist 441 variable rf 442 443 set name [$rf get active] 444 set idx [lsearch -exact $rulelist $name] 445 set rulelist [lreplace $rulelist $idx $idx] 446 set newidx [expr {$idx + $shift}] 447 set rulelist [linsert $rulelist $newidx $name] 448 449 debugmsg filters $rulelist 450 451 $rf delete 0 end 452 foreach r $rulelist { 453 $rf insert end $r 454 } 455 456 $rf activate $newidx 457 $rf selection set $newidx 458 459 #set newidx [expr [$rf index active] - 1] 460 #$rf move active $newidx 461} 462