# $Id: utils.tcl 1477 2008-07-16 17:04:45Z sergei $

proc rand {num} {
    return [expr round(rand()*$num)]
}

proc user_from_jid {jid} {
    set user $jid
    regexp {(.*@.*)/.*} $jid temp user

    return $user
}

proc node_and_server_from_jid {jid} {
    set nas $jid
    regexp {([^/]*)/.*} $jid temp nas

    return $nas
}

proc server_from_jid {jid} {
    set serv $jid
    regexp {([^/]*)/.*} $jid temp serv
    regexp {[^@]*@(.*)} $serv temp serv

    return $serv
}

proc resource_from_jid {jid} {
    set resource ""
    regexp {[^/]*/(.*)} $jid temp resource

    return $resource
}

proc node_from_jid {jid} {
    set node ""
    regexp {^([^@/]*)@.*} $jid temp node

    return $node
}


proc tolower_node_and_domain {jid} {
    
    set nas [string tolower [node_and_server_from_jid $jid]]
    set resource [resource_from_jid $jid]

    if {![cequal $resource ""]} {
	return $nas/$resource
    } else {
	return $nas
    }
    
}

# my_jid - returns JID for inclusion in queries. If the recipient
# is from some conference room then JID is a room JID.

proc my_jid {connid recipient} {
    set bare_recipient [node_and_server_from_jid $recipient]
    set chatid [chat::chatid $connid $bare_recipient]
    if {[chat::is_groupchat $chatid]} {
	set myjid [chat::our_jid $chatid]
    } else {
	set myjid [jlib::connection_jid $connid]
    }
}

proc win_id {prefix key} {
    global wins

    if {![info exists wins(seq,$prefix)]} {
	set wins(seq,$prefix) 0
    }

    if {![info exists wins(key,$prefix,$key)]} {
	set idx $wins(seq,$prefix)
	set wins(key,$prefix,$key) ".${prefix}_$idx"
	incr wins(seq,$prefix)
    }
    return $wins(key,$prefix,$key)
}


proc jid_to_tag {jid} {
    variable jidtag
    variable tagjid
    
    if {[info exists jidtag($jid)]} {
	return $jidtag($jid)
    } else {
	regsub -all {[^[:alnum:]]+} $jid {} prefix
	set tag $prefix[rand 1000000000]
	while {[info exists tagjid($tag)]} {
	    set tag $prefix[rand 1000000000]
	}

	set jidtag($jid) $tag
	set tagjid($tag) $jid

	return $tag
    }
}

proc tag_to_jid {tag} {
    variable tagjid

    if {[info exists tagjid($tag)]} {
	return $tagjid($tag)
    } else {
	error "Unknown tag $tag"
    }
}

proc double% {str} {
    return [string map {% %%} $str]
}

proc error_type_condition {errmsg} {
    return [lrange [stanzaerror::error_to_list $errmsg] 0 1]
}

proc error_to_string {errmsg} {
    return [lindex [stanzaerror::error_to_list $errmsg] 2]
}

proc get_group_nick {jid fallback} {
    global defaultnick

    set nick $fallback
    set tmp_pattern *
    foreach pattern [array names defaultnick] {
	if {[string equal $pattern $jid]} {
	    return $defaultnick($pattern)
	} elseif {([string match $pattern $jid]) && ([string match $tmp_pattern $pattern])} {
	    set nick $defaultnick($pattern)
	    set tmp_pattern $pattern
	}
    }
    return $nick
}

proc check_message {nick body} {
    set personal 0

    hook::run check_personal_message_hook personal $nick $body

    return $personal
}

proc personal_message_fallback {vpersonal nick body} {
    upvar 2 $vpersonal personal

    set prefixes {"" "2"}
    set suffixes {":" any " " any "" end}

    foreach pref $prefixes {
	foreach {suff pos} $suffixes {
	    set str "$pref$nick$suff"
	    if {[cequal $body $str] || \
		    ([cequal [crange $body 0 [expr {[clength $str] - 1}]] $str] && \
		    [cequal $pos any])} {
		set l [clength $pref]
		set personal 1
		return
	    }
	}
    }
}

hook::add check_personal_message_hook personal_message_fallback 100

proc format_time {t} {
	if {[cequal $t ""]} {
	    return
	}

	set sec [expr {$t % 60}]
	set secs [expr {($sec==1)?"[::msgcat::mc second]":"[::msgcat::mc seconds]"}]
	set t [expr {$t / 60}]
	set min [expr {$t % 60}]
	set mins [expr {($min==1)?"[::msgcat::mc minute]":"[::msgcat::mc minutes]"}]
	set t [expr {$t / 60}]
	set hour [expr {$t % 24}]
	set hours [expr {($hour==1)?"[::msgcat::mc hour]":"[::msgcat::mc hours]"}]
	set day [expr {$t / 24}]
	set days [expr {($day==1)?"[::msgcat::mc day]":"[::msgcat::mc days]"}]

	set flag 0
	set message ""
	if {$day != 0} {
		set flag 1
		set message "$day $days"
	}
	if {$flag || ($hour != 0)} {
		set flag 1
		set message [concat $message "$hour $hours"]
	}
	if {$flag || ($min != 0)} {
		set message [concat $message "$min $mins"]
	}

	return [concat $message "$sec $secs"]
}

proc NonmodalMessageDlg {path args} {
    set icon "none"
    set title ""
    set message ""
    set opts {}
    set mopts {}
    foreach {option value} $args {
	switch -- $option {
	    -icon {
		set icon $value
	    }
	    -title {
		set title $value
	    }
	    -aspect {
		lappend mopts $option $value
	    }
	    -message {
		lappend mopts -text $value
	    }
	    default {
		lappend opts $option $value
	    }
	}
    }

    if {$icon == "none"} {
	set image ""
    } else {
	set image [Bitmap::get $icon]
    }

    if {$title == ""} {
	set frame [frame $path -class MessageDlg]
	set title [option get $frame "${icon}Title" MessageDlg]
	destroy $frame
	if { $title == "" } {
	    set title "Message"
	}
    }

    eval [list Dialog::create $path -image $image -modal none -title $title \
	       -side bottom -anchor c -default 0 -cancel 0] $opts
    Dialog::add $path -text [::msgcat::mc "OK"] -name ok -command "destroy $path"

    set frame [Dialog::getframe $path]
    eval [list message $frame.msg -relief flat \
	       -borderwidth 0 -highlightthickness 0] \
	 $mopts
    pack  $frame.msg -side left -padx 3m -pady 1m -fill x -expand yes
    
    Dialog::draw $path
}

proc bindscroll {w {w1 ""}} {

    if {[cequal $w1 ""]} {
	set w1 $w
    }
    bind $w <<ScrollUp>> \
	"if {\[lindex \[$w1 yview\] 0\] > 0} {
	    $w1 yview scroll -5 units
	 }"
    bind $w <<ScrollDown>> \
	"if {\[lindex \[$w1 yview\] 1\] < 1} {
	    $w1 yview scroll 5 units
	 }"
    bind $w <<ScrollLeft>> \
	"if {\[lindex \[$w1 xview\] 0\] > 0} {
	    $w1 xview scroll -10 units
	 }"
    bind $w <<ScrollRight>> \
	"if {\[lindex \[$w1 xview\] 1\] < 1} {
	    $w1 xview scroll 10 units
	 }"
}

###########################################################################

if {[info tclversion] >= 8.4} {
    # Tk 8.4 or newer

    proc Spinbox {path from to incr textvar args} {
	return [eval [list spinbox $path \
				   -from $from \
				   -to $to \
				   -increment $incr \
				   -buttoncursor left_ptr \
				   -textvariable $textvar] \
		     $args]
    }

    proc textUndoable {path args} {
	eval {text $path -undo 1} $args
	bind $path <Key-space> +[list %W edit separator]
	hook::run text_on_create_hook $path
	return $path
    }

    # There is an evil bug in Tk, which does not allow inserting symbols
    # using XIM if more than one bound script uses %A.
    # See http://sourceforge.net/tracker/index.php?func=detail&aid=1373712&group_id=12997&atid=112997
    # Workaround overwrites existiong binding and uses hook to
    # simulate event with %A substituted.
    # Usage example see in plugins/unix/ispell.tcl.
    proc text_on_keypress {path sym} {
	tk::TextInsert $path $sym
	hook::run text_on_keypress_hook $path $sym
    }

    bind Text <Key> {text_on_keypress %W %A}
} else {
    # Tk 8.3
    
    proc Spinbox {path from to incr textvar args} {
	return [eval [list SpinBox $path \
				   -range [list $from $to $incr] \
				   -textvariable $textvar] \
			   $args]
    }

    proc textUndoable {path args} {
	eval {text $path} $args
	hook::run text_on_create_hook $path
	return $path
    }

    proc text_on_keypress {path sym} {
	tkTextInsert $path $sym
	hook::run text_on_keypress_hook $path $sym
    }

    bind Text <Key> {text_on_keypress %W %A}
}

###########################################################################

proc focus_next {path fr} {
    focus [Widget::focusNext $path]
    set widget [focus]
    if {[string first $fr $widget] == 0} {
	$fr see $widget
    }
}

proc focus_prev {path fr} {
    focus [Widget::focusPrev $path]
    $fr see [focus]
}

proc CbDialog {path title buttons var lnames lballoons args} {
    upvar #0 $var result
    array set names $lnames
    array set balloons $lballoons

    set modal none
    set radio 0
    foreach {opt val} $args {
	switch -- $opt {
	    -type { set radio [cequal $val radio] }
	    -modal { set modal $val }
	}
    }

    set len [llength $buttons]

    Dialog $path -title $title \
        -modal $modal -separator 1 -anchor e -default 0 \
	-cancel [expr {[llength $buttons]/2 - 1}]

    foreach {but com} $buttons {
	$path add -text $but -command $com
    }

    set sw [ScrolledWindow [$path getframe].sw]
    set sf [ScrollableFrame $sw.sf -constrainedwidth yes]
    pack $sw -expand yes -fill both
    $sw setwidget $sf
    set sff [$sf getframe]

    bind $path <Key-Up> [list focus_prev %W $sf]
    bind $path <Key-Down> [list focus_next %W $sf]
    bind $path <Key-Tab> [list focus_next %W $sf]
    bind $path <Shift-Tab> [list focus_prev %W $sf]
    bind $path <<PrevWindow>> [list focus_prev %W $sf]
    bindscroll $sff $sf

    if {!$radio} {
	catch { array unset result }
    }

    set temp {}
    foreach idx [array names names] {
	lappend temp [list $idx $names($idx)]
    }

    set i 0
    foreach idxt [lsort -dictionary -index 1 $temp] {
	set idx [lindex $idxt 0]
	if {$radio} {
	    set cb [radiobutton $sff.cb$i -variable $var \
	                -text $names($idx) -value $idx]
	    if {$i == 0} {
		set result $idx
	    }

	} else {
	    set result($idx) 0
	    set cb [checkbutton $sff.cb$i -variable ${var}($idx) \
		-text $names($idx)]
	}
	bind $cb <Return> [list $path invoke 0]
	bind $cb <Return> +break
	bind $cb <1> [list focus %W]
	bindscroll $cb $sf
	if {[info exists balloons($idx)]} {
	    balloon::setup $cb -text $balloons($idx)
	}
	pack $cb -anchor w
	incr i
    }
    
    $path draw $sff.cb0
}

proc OptionMenu {path args} {
    set m [eval [list ::tk_optionMenu $path] $args]

    set bd [option get $path borderWidth ""]
    if {$bd != ""} {
	$path configure -bd $bd
    }
    return $m
}

# Forces (string) $x to be interpreted as integer.
# Useful to deal with strings representing decimal interegs and
# containing leading zeroes (so, normaly they would be interpreted
# by Tcl as octal integers).
# Contributed on c.l.t. by Kevin Kenny, see http://wiki.tcl.tk/498
proc force_integer {x} {
    set count [scan $x %d%s n rest]
    if { $count <= 0 || ( $count == 2 && ![string is space $rest] ) } {
	return -code error "not an integer: $x"
    }

    return $n
}

# Excludes element $what from the list named $listVar:
proc lexclude {listVar what} {
    upvar 1 $listVar list
	
    set at [lsearch $list $what]

    if {$at >= 0} {
	set list [lreplace $list $at $at]
    }
}

# Takes one or more lists and returns one list with only unique
# members from all of the passed lists:
proc lfuse {args} {
    lsort -unique [lconcat $args]
}

# Takes a list of lists and flattens them into one list.
# NOTE that it takes ONE argument, which should be a list.
proc lconcat {L} {
    foreach S $L { foreach E $S { lappend out $E } }
    set out
}

# List intersection.
# For a number of lists, return only those elements
# that are present in all lists.
# (Richard Suchenwirth, from http://wiki.tcl.tk/43)
proc lintersect {args} {
    set res {}
    foreach element [lindex $args 0] {
	set found 1
	foreach list [lrange $args 1 end] {
	    if {[lsearch -exact $list $element] < 0} {
		set found 0
		break
	    }
	}
	if {$found} {lappend res $element}
    }
    set res
}

proc lmap {command list} {
    set newlist {}
    foreach elem $list {
	lappend newlist [eval $command [list $elem]]
    }
    return $newlist
}

proc lfilter {command list} {
    set newlist {}
    foreach elem $list {
	if {[eval $command [list $elem]]} {
	    lappend newlist $elem
	}
    }
    return $newlist
}

# Removes $nth element from the list contained in a
# variable named $listVar in the caller's scope,
# then returns the value of the removed element.
proc lpop {listVar {nth 0}} {
    upvar 1 $listVar L
    set v [lindex $L $nth]
    set L [lreplace $L $nth $nth]
    set v
}

# Returns a fully-qualified name of the command that has invoked
# the caller of this procedure.
# To put is simple: if ::one::bar has invoked ::two::foo, the
# ::two::foo proc can use [caller] to know that its caller
# is ::one::bar
# If the caller of this proc has no caller (i.e. it was called
# on level 0), this proc returns empty string.
# You can specify 2, 3, etc as the argument to get info about
# the caller of the caller and so on (think of [uplevel]).

proc caller {{level 1}} {
    incr level
    if {[catch {info level -$level} prc]} {
	return ""
    } else {
	return [namespace which -command [lindex $prc 0]]
    }
}

# Splits a string given in $s at each occurence of
# substring given in $by.
# $sep contains a Unicode character used to replace
# found substrings before actual splitting;
# this character MUST NOT occur in $s.
proc msplit {s by {sep \u001F}} {
    split [string map [list $by $sep] $s] $sep
}

##################################################################

proc reverse_scroll {w} {
    set command [$w cget -yscrollcommand]
    $w configure -yscrollcommand [list store_scroll $w $command]
    bind $w <Configure> {move_scroll %W}
    bind $w <Destroy> {+clean_scroll %W}
}

proc store_scroll {w command lo hi} {
    set ::lo($w) $lo
    set ::hi($w) $hi
    eval $command {$lo $hi}
}

proc move_scroll {w} {
    if {![info exists ::lo($w)] || ![info exists ::hi($w)]} return
    foreach {lo hi} [$w yview] break
    if {$hi < 1.0} {
	$w yview moveto [expr {$lo + ($::hi($w) - $::lo($w)) - ($hi - $lo)}]
    } else {
	$w see end
    }
}

proc clean_scroll {w} {
    catch {unset ::lo($w)}
    catch {unset ::hi($w)}
}

##################################################################

proc epath {} {
    global EPathNum
    if {![info exists EPathNum]} {
	set EPathNum 0
    } else {
	incr EPathNum
    }
    return .errorpath$EPathNum
}

##################################################################

proc get_conf {w option} {
    return [lindex [$w configure $option] 4]
}

##################################################################

proc render_url {path url title args} {
    set t [eval [list text $path \
	       -cursor left_ptr \
	       -height 1 \
	       -width 10 \
	       -bd 0 \
	       -highlightthickness 0 \
	       -takefocus 0 \
	       -wrap none] $args]
    ::richtext::config $t -using url
    ::plugins::urls::render_url $t text $url {} -title $title
    $t delete {end - 1 char}
    $t configure -state disabled
    return $t
}

# vim:ts=8:sw=4:sts=4:noet