1# $Id$ 2 3proc rand {num} { 4 return [expr int(floor(rand()*$num))] 5} 6 7proc psuffix {xlib} { 8 return [string map {: #} $xlib] 9} 10 11# my_jid - returns JID for inclusion in queries. If the recipient 12# is from some conference room then JID is a room JID. 13 14proc my_jid {xlib recipient} { 15 set bare_recipient [::xmpp::jid::stripResource $recipient] 16 set chatid [chat::chatid $xlib $bare_recipient] 17 if {[chat::is_groupchat $chatid]} { 18 set myjid [chat::our_jid $chatid] 19 } else { 20 set myjid [connection_jid $xlib] 21 } 22} 23 24proc win_id {prefix key} { 25 global wins 26 27 if {![info exists wins(seq,$prefix)]} { 28 set wins(seq,$prefix) 0 29 } 30 31 if {![info exists wins(key,$prefix,$key)]} { 32 set idx $wins(seq,$prefix) 33 set wins(key,$prefix,$key) ".${prefix}_$idx" 34 incr wins(seq,$prefix) 35 } 36 return $wins(key,$prefix,$key) 37} 38 39 40proc jid_to_tag {jid} { 41 variable jidtag 42 variable tagjid 43 44 if {[info exists jidtag($jid)]} { 45 return $jidtag($jid) 46 } else { 47 regsub -all {[^[:alnum:]]+} $jid {} prefix 48 set tag $prefix[rand 1000000000] 49 while {[info exists tagjid($tag)]} { 50 set tag $prefix[rand 1000000000] 51 } 52 53 set jidtag($jid) $tag 54 set tagjid($tag) $jid 55 56 return $tag 57 } 58} 59 60proc tag_to_jid {tag} { 61 variable tagjid 62 63 if {[info exists tagjid($tag)]} { 64 return $tagjid($tag) 65 } else { 66 error "Unknown tag $tag" 67 } 68} 69 70proc double% {str} { 71 return [string map {% %%} $str] 72} 73 74proc error_type_condition {errmsg} { 75 return [list [::xmpp::stanzaerror::type $errmsg] \ 76 [::xmpp::stanzaerror::condition $errmsg]] 77} 78 79proc error_to_string {errmsg} { 80 return [::xmpp::stanzaerror::message $errmsg] 81} 82 83proc get_group_nick {xlib jid} { 84 global defaultnick 85 86 if {[catch {set nick [connection_user $xlib]}]} { 87 set nick "" 88 } 89 set tmp_pattern * 90 foreach pattern [array names defaultnick] { 91 if {[string equal $pattern $jid]} { 92 return $defaultnick($pattern) 93 } elseif {([string match $pattern $jid]) && ([string match $tmp_pattern $pattern])} { 94 set nick $defaultnick($pattern) 95 set tmp_pattern $pattern 96 } 97 } 98 return $nick 99} 100 101proc check_message {nick body} { 102 set personal 0 103 104 hook::run check_personal_message_hook personal $nick $body 105 106 return $personal 107} 108 109proc personal_message_fallback {vpersonal nick body} { 110 upvar 2 $vpersonal personal 111 112 set prefixes {"" "2"} 113 set suffixes {":" any " " any "" end} 114 115 foreach pref $prefixes { 116 foreach {suff pos} $suffixes { 117 set str "$pref$nick$suff" 118 if {[cequal $body $str] || \ 119 ([cequal [crange $body 0 [expr {[clength $str] - 1}]] $str] && \ 120 [cequal $pos any])} { 121 set l [clength $pref] 122 set personal 1 123 return 124 } 125 } 126 } 127} 128 129hook::add check_personal_message_hook personal_message_fallback 100 130 131proc format_time {t} { 132 if {[cequal $t ""]} { 133 return 134 } 135 136 set sec [expr {$t % 60}] 137 set secs [expr {($sec==1)?"[::msgcat::mc second]":"[::msgcat::mc seconds]"}] 138 set t [expr {$t / 60}] 139 set min [expr {$t % 60}] 140 set mins [expr {($min==1)?"[::msgcat::mc minute]":"[::msgcat::mc minutes]"}] 141 set t [expr {$t / 60}] 142 set hour [expr {$t % 24}] 143 set hours [expr {($hour==1)?"[::msgcat::mc hour]":"[::msgcat::mc hours]"}] 144 set day [expr {$t / 24}] 145 set days [expr {($day==1)?"[::msgcat::mc day]":"[::msgcat::mc days]"}] 146 147 set flag 0 148 set message "" 149 if {$day != 0} { 150 set flag 1 151 set message "$day $days" 152 } 153 if {$flag || ($hour != 0)} { 154 set flag 1 155 set message [concat $message "$hour $hours"] 156 } 157 if {$flag || ($min != 0)} { 158 set message [concat $message "$min $mins"] 159 } 160 161 return [concat $message "$sec $secs"] 162} 163 164proc NonmodalMessageDlg {path args} { 165 set icon "none" 166 set title "" 167 set message "" 168 set opts {} 169 set mopts {} 170 foreach {option value} $args { 171 switch -- $option { 172 -icon { 173 set icon $value 174 } 175 -title { 176 set title $value 177 } 178 -aspect { 179 lappend mopts $option $value 180 } 181 -message { 182 lappend mopts -text $value 183 } 184 default { 185 lappend opts $option $value 186 } 187 } 188 } 189 190 if {$icon == "none"} { 191 set image "" 192 } else { 193 set image [Bitmap::get $icon] 194 } 195 196 if {$title == ""} { 197 set frame [frame $path -class MessageDlg] 198 set title [option get $frame "${icon}Title" MessageDlg] 199 destroy $frame 200 if { $title == "" } { 201 set title "Message" 202 } 203 } 204 205 eval [list Dialog::create $path -image $image -modal none -title $title \ 206 -side bottom -anchor c -default 0 -cancel 0] $opts 207 Dialog::add $path -text [::msgcat::mc "OK"] -name ok -command "destroy $path" 208 209 set frame [Dialog::getframe $path] 210 eval [list message $frame.msg -relief flat \ 211 -borderwidth 0 -highlightthickness 0] \ 212 $mopts 213 pack $frame.msg -side left -padx 3m -pady 1m -fill x -expand yes 214 215 Dialog::draw $path 216} 217 218proc bindscroll {w {w1 ""}} { 219 220 if {![string equal $w1 ""]} { 221 set w1 [double% $w1] 222 } else { 223 set w1 [double% $w] 224 } 225 226 bind $w <<ScrollUp>> \ 227 "if {\[lindex \[$w1 yview\] 0\] > 0} { 228 $w1 yview scroll -5 units 229 }" 230 bind $w <<ScrollDown>> \ 231 "if {\[lindex \[$w1 yview\] 1\] < 1} { 232 $w1 yview scroll 5 units 233 }" 234 bind $w <<ScrollLeft>> \ 235 "if {\[lindex \[$w1 xview\] 0\] > 0} { 236 $w1 xview scroll -10 units 237 }" 238 bind $w <<ScrollRight>> \ 239 "if {\[lindex \[$w1 xview\] 1\] < 1} { 240 $w1 xview scroll 10 units 241 }" 242} 243 244########################################################################### 245 246if {[info tclversion] >= 8.4} { 247 # Tk 8.4 or newer 248 249 proc Spinbox {path from to incr textvar args} { 250 return [eval [list spinbox $path \ 251 -from $from \ 252 -to $to \ 253 -increment $incr \ 254 -buttoncursor left_ptr \ 255 -textvariable $textvar] \ 256 $args] 257 } 258 259 proc textUndoable {path args} { 260 eval {text $path -undo 1} $args 261 bind $path <Key-space> +[list %W edit separator] 262 bind $path <<ContextMenu>> [list text_context_menu %W %X %Y %x %y] 263 hook::run text_on_create_hook $path 264 return $path 265 } 266 267 # There is an evil bug in Tk, which does not allow inserting symbols 268 # using XIM if more than one bound script uses %A. 269 # See http://sourceforge.net/tracker/index.php?func=detail&aid=1373712&group_id=12997&atid=112997 270 # Workaround overwrites existiong binding and uses hook to 271 # simulate event with %A substituted. 272 # Usage example see in plugins/unix/ispell.tcl. 273 proc text_on_keypress {path sym} { 274 tk::TextInsert $path $sym 275 hook::run text_on_keypress_hook $path $sym 276 } 277 278 bind Text <Key> {text_on_keypress %W %A} 279} else { 280 # Tk 8.3 281 282 proc Spinbox {path from to incr textvar args} { 283 return [eval [list SpinBox $path \ 284 -range [list $from $to $incr] \ 285 -textvariable $textvar] \ 286 $args] 287 } 288 289 proc textUndoable {path args} { 290 eval {text $path} $args 291 bind $path <<ContextMenu>> [list text_context_menu %W %X %Y %x %y] 292 hook::run text_on_create_hook $path 293 return $path 294 } 295 296 proc text_on_keypress {path sym} { 297 tkTextInsert $path $sym 298 hook::run text_on_keypress_hook $path $sym 299 } 300 301 bind Text <Key> {text_on_keypress %W %A} 302} 303 304proc text_context_menu {W X Y x y} { 305 set m .input_popup 306 if {[winfo exists $m]} { 307 destroy $m 308 } 309 310 menu $m -tearoff 0 311 hook::run textinput_popup_menu_hook $m $W $x $y 312 313 tk_popup $m $X $Y 314 315} 316 317proc text_add_copypaste_to_menu {m w x y} { 318 $m add command -label [::msgcat::mc "Cut"] -command [list event generate $w <<Cut>>] -accelerator Ctrl-X 319 $m add command -label [::msgcat::mc "Copy"] -command [list event generate $w <<Copy>>] -accelerator Ctrl-C 320 $m add command -label [::msgcat::mc "Paste"] -command [list event generate $w <<Paste>>] -accelerator Ctrl-V 321} 322 323hook::add textinput_popup_menu_hook text_add_copypaste_to_menu 30 324 325########################################################################### 326 327proc focus_next {path fr} { 328 focus [Widget::focusNext $path] 329 set widget [focus] 330 if {[string first $fr $widget] == 0} { 331 $fr see $widget 332 } 333} 334 335proc focus_prev {path fr} { 336 focus [Widget::focusPrev $path] 337 $fr see [focus] 338} 339 340proc CbDialog {path title buttons var lnames lballoons args} { 341 upvar #0 $var result 342 array set names $lnames 343 array set balloons $lballoons 344 345 set modal none 346 set radio 0 347 foreach {opt val} $args { 348 switch -- $opt { 349 -type { set radio [cequal $val radio] } 350 -modal { set modal $val } 351 } 352 } 353 354 set len [llength $buttons] 355 356 Dialog $path -title $title \ 357 -modal $modal -separator 1 -anchor e -default 0 \ 358 -cancel [expr {[llength $buttons]/2 - 1}] 359 360 foreach {but com} $buttons { 361 $path add -text $but -command $com 362 } 363 364 set sw [ScrolledWindow [$path getframe].sw] 365 set sf [ScrollableFrame $sw.sf -constrainedwidth yes] 366 pack $sw -expand yes -fill both 367 $sw setwidget $sf 368 set sff [$sf getframe] 369 370 bind $path <Key-Up> [list focus_prev %W [double% $sf]] 371 bind $path <Key-Down> [list focus_next %W [double% $sf]] 372 bind $path <Key-Tab> [list focus_next %W [double% $sf]] 373 bind $path <Shift-Tab> [list focus_prev %W [double% $sf]] 374 bind $path <<PrevWindow>> [list focus_prev %W [double% $sf]] 375 bindscroll $sff $sf 376 377 if {!$radio} { 378 catch { array unset result } 379 } 380 381 set temp {} 382 foreach idx [array names names] { 383 lappend temp [list $idx $names($idx)] 384 } 385 386 set i 0 387 foreach idxt [lsort -dictionary -index 1 $temp] { 388 set idx [lindex $idxt 0] 389 if {$radio} { 390 set cb [radiobutton $sff.cb$i -variable $var \ 391 -text $names($idx) -value $idx] 392 if {$i == 0} { 393 set result $idx 394 } 395 396 } else { 397 set result($idx) 0 398 set cb [checkbutton $sff.cb$i -variable ${var}($idx) \ 399 -text $names($idx)] 400 } 401 bind $cb <Return> [list [double% $path] invoke 0] 402 bind $cb <Return> +break 403 bind $cb <1> [list focus %W] 404 bindscroll $cb $sf 405 if {[info exists balloons($idx)]} { 406 balloon::setup $cb -text $balloons($idx) 407 } 408 pack $cb -anchor w 409 incr i 410 } 411 412 $path draw $sff.cb0 413} 414 415proc OptionMenu {path args} { 416 set m [eval [list ::tk_optionMenu $path] $args] 417 418 set bd [option get $path borderWidth ""] 419 if {$bd != ""} { 420 $path configure -bd $bd 421 } 422 return $m 423} 424 425# Forces (string) $x to be interpreted as integer. 426# Useful to deal with strings representing decimal integers and 427# containing leading zeroes (so, normaly they would be interpreted 428# by Tcl as octal integers). 429# Contributed on c.l.t. by Kevin Kenny, see http://wiki.tcl.tk/498 430proc force_integer {x} { 431 set count [scan $x %d%s n rest] 432 if { $count <= 0 || ( $count == 2 && ![string is space $rest] ) } { 433 return -code error "not an integer: $x" 434 } 435 436 return $n 437} 438 439# Excludes element $what from the list named $listVar: 440proc lexclude {listVar what} { 441 upvar 1 $listVar list 442 443 set at [lsearch $list $what] 444 445 if {$at >= 0} { 446 set list [lreplace $list $at $at] 447 } 448} 449 450# Takes one or more lists and returns one list with only unique 451# members from all of the passed lists: 452proc lfuse {args} { 453 lsort -unique [lconcat $args] 454} 455 456# Takes a list of lists and flattens them into one list. 457# NOTE that it takes ONE argument, which should be a list. 458proc lconcat {L} { 459 foreach S $L { foreach E $S { lappend out $E } } 460 set out 461} 462 463# List intersection. 464# For a number of lists, return only those elements 465# that are present in all lists. 466# (Richard Suchenwirth, from http://wiki.tcl.tk/43) 467proc lintersect {args} { 468 set res {} 469 foreach element [lindex $args 0] { 470 set found 1 471 foreach list [lrange $args 1 end] { 472 if {[lsearch -exact $list $element] < 0} { 473 set found 0 474 break 475 } 476 } 477 if {$found} {lappend res $element} 478 } 479 set res 480} 481 482proc lmap {command list} { 483 set newlist {} 484 foreach elem $list { 485 lappend newlist [eval $command [list $elem]] 486 } 487 return $newlist 488} 489 490proc lfilter {command list} { 491 set newlist {} 492 foreach elem $list { 493 if {[eval $command [list $elem]]} { 494 lappend newlist $elem 495 } 496 } 497 return $newlist 498} 499 500# Removes $nth element from the list contained in a 501# variable named $listVar in the caller's scope, 502# then returns the value of the removed element. 503proc lpop {listVar {nth 0}} { 504 upvar 1 $listVar L 505 set v [lindex $L $nth] 506 set L [lreplace $L $nth $nth] 507 set v 508} 509 510# Returns a fully-qualified name of the command that has invoked 511# the caller of this procedure. 512# To put is simple: if ::one::bar has invoked ::two::foo, the 513# ::two::foo proc can use [caller] to know that its caller 514# is ::one::bar 515# If the caller of this proc has no caller (i.e. it was called 516# on level 0), this proc returns empty string. 517# You can specify 2, 3, etc as the argument to get info about 518# the caller of the caller and so on (think of [uplevel]). 519 520proc caller {{level 1}} { 521 incr level 522 if {[catch {info level -$level} prc]} { 523 return "" 524 } else { 525 return [namespace which -command [lindex $prc 0]] 526 } 527} 528 529# Splits a string given in $s at each occurence of 530# substring given in $by. 531# $sep contains a Unicode character used to replace 532# found substrings before actual splitting; 533# this character MUST NOT occur in $s. 534proc msplit {s by {sep \u0000}} { 535 split [string map [list $by $sep] $s] $sep 536} 537 538################################################################## 539 540proc reverse_scroll {w} { 541 set command [$w cget -yscrollcommand] 542 $w configure -yscrollcommand [list store_scroll $w $command] 543 bind $w <Configure> {move_scroll %W} 544 bind $w <Destroy> {+clean_scroll %W} 545} 546 547proc store_scroll {w command lo hi} { 548 set ::lo($w) $lo 549 set ::hi($w) $hi 550 eval $command {$lo $hi} 551} 552 553proc move_scroll {w} { 554 if {![info exists ::lo($w)] || ![info exists ::hi($w)]} return 555 foreach {lo hi} [$w yview] break 556 if {$::hi($w) < 1.0} { 557 $w yview moveto [expr {$::hi($w) - ($hi - $lo)}] 558 } else { 559 $w yview moveto 1.0 560 } 561} 562 563proc clean_scroll {w} { 564 catch {unset ::lo($w)} 565 catch {unset ::hi($w)} 566} 567 568################################################################## 569 570proc epath {} { 571 global EPathNum 572 if {![info exists EPathNum]} { 573 set EPathNum 0 574 } else { 575 incr EPathNum 576 } 577 return .errorpath$EPathNum 578} 579 580################################################################## 581 582proc get_conf {w option} { 583 return [lindex [$w configure $option] 4] 584} 585 586################################################################## 587 588proc render_url {path url title args} { 589 set t [eval [list text $path \ 590 -cursor left_ptr \ 591 -height 1 \ 592 -width 10 \ 593 -bd 0 \ 594 -highlightthickness 0 \ 595 -takefocus 0 \ 596 -wrap none] $args] 597 ::richtext::config $t -using url 598 ::plugins::urls::render_url $t text $url {} -title $title 599 $t delete {end - 1 char} 600 $t configure -state disabled 601 return $t 602} 603 604################################################################## 605 606proc ecursor_entry {entry} { 607 $entry icursor end 608 return $entry 609} 610 611################################################################## 612 613proc update_combo_list {list entry num} { 614 615 set ind [lsearch -exact $list $entry] 616 if {$ind >= 0} { 617 set newlist [linsert [lreplace $list $ind $ind] 0 $entry] 618 } else { 619 set newlist [linsert $list 0 $entry] 620 } 621 if {[llength $newlist] > $num} { 622 return [lreplace $newlist end end] 623 } else { 624 return $newlist 625 } 626} 627 628################################################################## 629 630proc wmstate {window args} { 631 switch -- [llength $args] { 632 0 { 633 set state [wm state $window] 634 if {[string equal $state normal]} { 635 if {![catch {wm attributes $window -zoomed} res]} { 636 if {$res} { 637 set state zoomed 638 } 639 } 640 } 641 return $state 642 } 643 1 { 644 set state [lindex $args 0] 645 switch -- $state { 646 zoomed { 647 if {[catch {wm state $window zoomed}]} { 648 wm state $window normal 649 catch {wm attributes $window -zoomed 1} 650 } 651 } 652 default { 653 wm state $window $state 654 catch {wm attributes $window -zoomed 0} 655 } 656 } 657 return $state 658 } 659 } 660} 661 662# vim:ts=8:sw=4:sts=4:noet 663