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