Tkabber

2002-08-09  Alexey Shchepin  <alexey@sevcom.net>

	* search.tcl: Now users can be added from search results

	* joingrdialog.tcl: Conference-v2 support
	* joingrdialog.tcl (join_group_dialog): Added checkbutton for
	selecting conference protocol

	* roster.tcl: Now items can be draged from browser to roster
	* browser.tcl: Likewise

	* messages.tcl: Processing of jabber:x:roster, jabber:x:oob &
	jabber:x:conference (not completed)

	* tkabber.tcl (debugmsg): New function for showing debug messages
	* browser.tcl: Replaced "puts" to "debugmsg" calls
	* chats.tcl: Likewise
	* filetransfer.tcl: Likewise
	* filters.tcl: Likewise
	* iq.tcl: Likewise
	* joingrdialog.tcl: Likewise
	* plugins.tcl: Likewise
	* presence.tcl: Likewise
	* roster.tcl: Likewise
	* search.tcl: Likewise
	* userinfo.tcl: Likewise

2002-08-08  Alexey Shchepin  <alexey@sevcom.net>

	* joingrdialog.tcl: Conference-v2 support (not completed)

	* login.tcl (show_login_dialog): Set focus by default on "Login"
	button

    pack $bw.navigate.entry -side left -expand yes -fill x
    pack $bw.navigate.browse -side left
    pack $bw.navigate -fill x


    set sw [ScrolledWindow $bw.sw]

    set tw [Tree $bw.tree -deltax 16 -deltay 18 -dragenabled 1 \
		-draginitcmd browser::draginitcmd]
    $sw setwidget $tw

    pack $sw -side top -expand yes -fill both
    set browser(tree,$bw) $tw
    $tw bindText <Double-ButtonPress-1> [list browser::textaction $bw]
    $tw bindText <Any-Enter>  [list browser::textballoon $bw enter  %X %Y]
    $tw bindText <Any-Motion> [list browser::textballoon $bw motion %X %Y]

	    [jlib::wrapper:createtag item \
		 -vars {xmlns jabber:iq:browse}] \
	    -to $jid -command [list browser::recv $bw $jid]
    }
}

proc browser::recv {bw jid res child} {
    debugmsg browser "$res $child"

    if {![cequal $res OK]} {
	return
    }

    if {[winfo exists $bw]} {
	browser::process $bw $jid $child 0
    }
}

proc browser::process {bw from item level} {
    variable browser

    jlib::wrapper:splitxml $item tag vars isempty chdata children

    
    switch -- $tag {
	ns {
	    debugmsg browser "$level; ns $chdata"
	    if {![cequal $chdata ""]} {
		return [browser::add_ns_line $bw $from $level $chdata]
	    }
	    return
	}
	item {
	    set category [jlib::wrapper:getattr $vars service]

	set jid $from
    }

    set type [jlib::wrapper:getattr $vars type]
    set name [jlib::wrapper:getattr $vars name]
    set version [jlib::wrapper:getattr $vars version]

    debugmsg browser "$level; $jid; $category; $type; $name; $version"
    add_item_line $bw $level $jid $category $type $name $version $from

    set tw $browser(tree,$bw)
    set childs {}

    foreach child $children {
	lappend childs [browser::process $bw $jid $child [expr $level+1]]	
    }

    set curchilds [$tw nodes $jid]

    if {$level == 0} {
	foreach c $curchilds {
	    if {![lcontain $childs $c]} {
		$tw delete $c
	    }
	}
	update idletasks
    }
    debugmsg browser [list $childs $curchilds]

    return $jid
}




image create photo unknown_pixmap -file [fullpath pixmaps unknown.gif]
image create photo service_jabber -file [fullpath pixmaps service-jabber.gif]
image create photo br_group       -file [fullpath jajc-bitmaps group_on.gif]
image create photo br_user        -file [fullpath jajc-bitmaps user.gif]
image create photo br_jud         -file [fullpath jajc-bitmaps jud.gif]
image create photo ""













proc browser::item_icon {category type} {
    switch -- $category {
	service {
	    switch -- $type {
		jud {return br_jud}
		default {return ""}
	    }

    set desc [item_desc $jid $name]

    if {[$tw exists $jid]} {
	if {[$tw parent $jid] != $parent && [$tw exists $parent] && \
		$parent != $jid} {
	    $tw move $parent $jid end
	    debugmsg browser "MOVE: $parent $jid"
	}
	if {[$tw itemcget $jid -data] != \
		[list jid $jid $category $type $name $version]} {
	    debugmsg browser RECONF
	    $tw itemconfigure $jid -text $desc \
		-data [list jid $jid $category $type $name $version]
	}
    } elseif {[$tw exists $parent]} {
	$tw insert end $parent $jid -text $desc -open 1 -image $icon \
	    -font $font \
	    -data [list jid $jid $category $type $name $version]

	    -fill $config(nscolor)
    }

    return $id
}

proc browser::ns_binding {jid ns} {
    debugmsg browser "$jid $ns"

    switch -- $ns {
	jabber:iq:conference {
	    global gr_nick
	    join_group $jid $gr_nick
	}
	jabber:iq:search {

    variable browser

    set browser(hist,$bw) [lreplace $browser(hist,$bw) 0 \
			       [expr $browser(histpos,$bw) - 1]]

    lvarpush browser(hist,$bw) $jid
    set browser(histpos,$bw) 0
    debugmsg browser $browser(hist,$bw)


}



proc browser::parse_items {from item} {
    variable browser

    debugmsg browser "BR: $item"

    jlib::wrapper:splitxml $item tag vars isempty chdata children

    
    switch -- $tag {
	ns {
	    return

	set jid $from
    }

    set type [jlib::wrapper:getattr $vars type]
    set name [jlib::wrapper:getattr $vars name]
    set version [jlib::wrapper:getattr $vars version]

    debugmsg browser "$jid; $category; $type; $name; $version"

    set browser(name,$jid) $name
    set browser(category,$jid) $category
    set browser(type,$jid) $type

    browser::handler $from $jid

		     $category $type $name $version] \
		$X $Y
	}
	leave {balloon::destroy}
    }
}

proc browser::draginitcmd {t node top} {
    set data [$t itemcget $node -data]
    set data2 [lassign $data type]

    if {$type == "jid"} {
	if {[set img [$t itemcget $node -image]] != ""} {
	    pack [label $top.l -image $img -padx 0 -pady 0]
	}
	
	return [list JID {copy} $data2]
    } else {
	return {}
    }
}

    # FIX
    regsub -all \\. $name | allowed_name 
    return $w.chat_$allowed_name
}

proc client:message {from type subject body err thread priority x} {
    debugmsg chats "MESSAGE: $from; $type; $subject; $body; $err;\
$thread; $priority; $x"

    chat::process_message $from $type $subject $body $err $thread $priority $x
}

proc chat::process_message {from type subject body err thread priority x} {
    global font
    variable opened


    set from [tolower_node_and_domain $from]

    set chatid $from
    switch -- $type {
	normal {
	    message::show_dlg $from $subject $body $thread $priority $x
	    return
	}
	chat {
	}
	groupchat {
	    #regexp {(.*)/.*} $from temp chatid
	    set chatid [node_and_server_from_jid $from]

	    if {![cequal $subject ""]} {
		set_subject $chatid $subject
	    }
	}
	error {
	    #set body "Error [lindex $err 0]: [lindex $err 1]\n$body"
	    set body "Error [lindex $err 0]: [lindex $err 1]"
	}
	default {
	    debugmsg chats "MESSAGE: UNSUPPORTED message type '$type'"
	}
    }


    chat::open_window $chatid $type

    chat::add_message $chatid $from $type $body $x

	return
    }

    plugins::run_hook open_chat_pre_hook $chatid $type

    set chats(type,$chatid) $type
    set chats(ourjid,$chatid) [get_our_jid $chatid $type]
    debugmsg chats "OURJID: $chats(ourjid,$chatid)"
    lappend chats(opened) $chatid
    
    set opened($chatid) $cw
    #debugmsg chats $cw
    #debugmsg chats [array names opened_chats]
    #debugmsg chats $opened_chats($chatid)

    set chatname [roster::itemconfig [roster::find_jid $chatid] -name]
    if {$chatname != ""} {
	set titlename $chatname
	set tabtitlename $titlename
    } else {
	set titlename $chatid

    set cw [winid $chatid]

    if {[info exists opened($chatid)]} {
	unset opened($chatid)
	set idx [lsearch $chats(opened) $chatid]
	set chats(opened) [lreplace $chats(opened) $idx $idx]
	debugmsg chats $chats(opened)

	if {$chats(type,$chatid) == "groupchat"} {
	    jlib::send_presence \
		-to $chatid/[get_our_groupchat_nick $chatid] \
		-type unavailable
	    client:presence $chatid unavailable "" {}
	}

    chat::open_window $jid chat
}


proc chat::change_presence {jid status} {
    global grouproster
    variable chats
    variable opened

    set group [node_and_server_from_jid $jid]
    set nick [get_nick $jid groupchat]

    if {$nick == ""} {
	return
    }

    if {[info exists opened($group)] && ![lcontain $chats(groupchats) $jid]} {
	set cw $opened($group)

	debugmsg chats "ST: $jid $status"
	if {[cequal $status unavailable]} {
	    debugmsg chats "$jid UNAVAILABLE"
	    lvarpop grouproster(users,$group) \
		[lsearch $grouproster(users,$group) $jid]
	    debugmsg chats "GR: $grouproster(users,$group)"
	    if {!$grouproster(redraw,$group)} {
		set grouproster(redraw,$group) 1
		after idle chat::redraw_roster $cw $group
	    }
	} else {
	    set userswin [users_win $group]
	    if {![lcontain $grouproster(users,$group) $jid]} {
		roster::addline $userswin jid $nick $jid
		lappend grouproster(users,$group) $jid
		set grouproster(status,$group,$jid) $status
		if {!$grouproster(redraw,$group)} {
		    set grouproster(redraw,$group) 1
		    after idle chat::redraw_roster $cw $group
		}
		#redraw_roster $cw $group
	    }
	    set grouproster(status,$group,$jid) $status
	    roster::changeicon $userswin $jid $status
	    after idle chat::redraw_roster $cw $group
	}

	#roster:changeicon $w.users [user_from_jid $from] $status
    }

    set cw [winid $jid]

    if {[winfo exists $cw]} {
	if {![lcontain $chats(groupchats) $jid]} {
	    $cw.status.icon configure -image $status
	}
    }
}

proc chat::redraw_roster {cw group} {
    global grouproster

    set userswin [users_win $group]

    }

    set fsize [file size $filename]
    $f.pb configure -maximum $fsize
    .sfd$winid itemconfigure 0 -state disabled
    #destroy .sfd$winid

    debugmsg filetransfer "SENDFILE: $filename; $desc; $ip"

    set servsock [socket -server \
		      [list ft::send_file_accept $winid $filename] 0]

    lassign [fconfigure $servsock -sockname] addr hostname port

    set url [cconcat "http://$ip:$port/" [file tail $filename]]

    fconfigure $chan -blocking 0 -encoding binary -buffering line

    fileevent $chan readable [list set ft::chanreadable$chan 1]

    set request " "
    
    while {$request != ""} {
	debugmsg filetransfer $request
	vwait ft::chanreadable$chan
	set request [gets $chan]
    }

    fileevent $chan readable {}

    set fsize [file size $filename]

    #debugmsg filetransfer $request
    fconfigure $chan -translation binary

    puts -nonewline $chan "HTTP/1.0 200 OK\n"
    puts -nonewline $chan "Content-Length: $fsize\n"
    puts -nonewline $chan "Content-Type: text/plain\n\n"

    set fd [open $filename]

#    .rfd$winid itemconfigure 1 \
#	-command [list ft::recv_file_cancel $winid $token]
    bind .rfd$winid <Destroy> [list ft::recv_file_cancel $winid $token]
}

proc ft::recv_file_progress {pb token total current} {
    variable progress$pb
    debugmsg filetransfer "$total $current"
    $pb configure -maximum $total
    set progress$pb $current
}

proc ft::recv_file_finish {winid token} {
    upvar #0 $token state
    debugmsg filetransfer "transfer $state(status)"

    bind .rfd$winid <Destroy> {}
    destroy .rfd$winid
}

proc ft::recv_file_cancel {winid token} {
    ::http::reset $token cancelled
    destroy .rfd$winid
}

proc filters::recv {res child} {
    variable rf
    variable rule
    variable rulelist

    debugmsg filters "$res $child"

    if {![cequal $res OK]} {
	return
    }

    $rf delete 0 end
    array unset rule

proc filters::process_rule_data {name child} {
    variable rule

    jlib::wrapper:splitxml $child tag vars isempty chdata children

    lappend rule($name) $tag $chdata
    debugmsg filters [array get rule]
}

proc filters::edit {} {
    variable rf

    set name [$rf get active]
    debugmsg filters $name
    if {$name != ""} {
	open_edit $name
    }
}


proc filters::open_edit {rname} {

    variable rulecondmenu
    variable items

    set items($fcond) {}
    set items($fact) {}
    foreach {tag value} $rule($rname) {
	if {[lcontain $condtags $tag]} {
	    debugmsg filters "C $tag $value"
	    insert_item $fcond $tag $value $rulecondmenu
	} elseif {[lcontain $acttags $tag]} {
	    debugmsg filters "A $tag $value"
	    insert_item $fact $tag $value $ruleactmenu
	}
    }
}

    grid $f.mb$n      -row $n -column 0 -sticky ew
    grid $f.e$n       -row $n -column 1 -sticky ew
    grid $f.sep$n     -row $n -column 2 -sticky ew
    grid $f.remove$n  -row $n -column 3 -sticky ew


    lappend items($f) $n
    debugmsg filters $items($f)
}

proc filters::remove_item {f n} {
    variable items

    set idx [lsearch -exact $items($f) $n]
    set items($f) [lreplace $items($f) $idx $idx]

    eval destroy [grid slaves $f -row $n]

    debugmsg filters $items($f)
}

proc filters::accept_rule {w rname fcond fact} {
    variable items
    variable totag
    variable rule
    variable tmp

    }


    set rule($newname) {}
    foreach n $items($fcond) {
	set tag $totag([set ::$fcond.mb$n.var])
	set val [$fcond.e$n get]
	debugmsg filters "$tag $val"
	lappend rule($newname) $tag $val
    }

    foreach n $items($fact) {
	set tag $totag([set ::$fact.mb$n.var])
	set val [$fact.e$n get]
	debugmsg filters "$tag $val"
	lappend rule($newname) $tag $val
    }

    debugmsg filters [array get rule]

    set idx [lsearch -exact $rulelist $rname]
    set rulelist [lreplace $rulelist $idx $idx $newname]

    $rf delete 0 end
    foreach r $rulelist {
	$rf insert end $r

}

proc filters::remove {} {
    variable rf
    variable rulelist

    set name [$rf get active]
    debugmsg filters $name
    if {$name != ""} {
	set idx [lsearch -exact $rulelist $name]
	set rulelist [lreplace $rulelist $idx $idx]
	$rf delete active
	debugmsg filters $rulelist
    }
}

proc filters::commit {} {
    variable rulelist
    variable rule

    set result {}
    foreach rname $rulelist {
	set rtags {}
	foreach {tag val} $rule($rname) {
	    lappend rtags [jlib::wrapper:createtag $tag -chdata $val]
	}

	lappend result [jlib::wrapper:createtag rule \
			    -vars [list name $rname] \
			    -subtags $rtags]
    }

    debugmsg filters $result
    jlib::send_iq set \
	[jlib::wrapper:createtag item \
	     -vars {xmlns jabber:iq:filter} \
	     -subtags $result]

    destroy .filters
}

proc filters::move {shift} {
    variable rulelist
    variable rf

    set name [$rf get active]
    set idx [lsearch -exact $rulelist $name]
    set rulelist [lreplace $rulelist $idx $idx]
    set newidx [expr $idx + $shift]
    set rulelist [linsert $rulelist $newidx $name]

    debugmsg filters $rulelist

    $rf delete 0 end
    foreach r $rulelist {
	$rf insert end $r
    }

    $rf activate $newidx
    $rf selection set $newidx

    #set newidx [expr [$rf index active] - 1]
    #$rf move active $newidx
}

	set h $handler($type,,$xmlns)
    }

    if {[info exists h]} {
	set res [$h $from $child]

	if {$res != {}} {
	    debugmsg iq "IQREPLY: SENDING: $from; $useid; $id; $child"
	    jlib::send_iq result $res -to $from -id $id
	}
    } else {
	debugmsg iq "IQREPLY: SENDING: $from; $useid; $id; $child"
	# TODO
	jlib::send_iq error \
	    [jlib::wrapper:createtag error \
		 -vars {code 501} -chdata "Not Implemented"] \
	    -to $from -id $id
    }
}

proc client:iqreply {from useid id type child} {
    debugmsg iq "IQREPLY: $from; $useid; $id; $type; $child"

    iq::process_iq $from $useid $id $type $child
}


plugins::load iq-plugins

# $Id$

#set gr_nick $user
set gr_group "talks"
#set gr_server conference.$server
set gr_v2 0

proc pack_input {fr row var lab} {
    label $fr.l$var -text $lab
    entry $fr.$var -textvar $var

    grid $fr.l$var -row $row -column 0 -sticky e

    grid $fr.$var  -row $row -column 1 -sticky ew

}

proc join_group_dialog {} {
    set gw .joingroup

    if {![winfo exists $gw]} {
	Dialog $gw -title "Join group" -separator 1 -anchor e

	set gf [$gw getframe]
	grid columnconfigure $gf 1 -weight 1

	pack_input $gf 0 gr_nick "Nick:"
	pack_input $gf 1 gr_group "Group:"
	pack_input $gf 2 gr_server "Server:"

	checkbutton $gf.v2 -variable gr_v2 -text "use v2 protocol"
	grid $gf.v2 -row 3 -column 1 -sticky w

	$gw add -text "Join" -command join_group1
	$gw add -text "Cancel" -command {.joingroup withdraw}
    }
    $gw draw
}


proc join_group1 {} {
    global gr_nick gr_group gr_server groups

    .joingroup withdraw
    join_group $gr_group@${gr_server} $gr_nick
}

proc join_group {groupid nick} {
    global gr_v2
    if {!$gr_v2} {
	jlib::send_presence -to ${groupid}/${nick}
	set_our_groupchat_nick $groupid $nick
	chat::open_window $groupid groupchat
    } else {
	set_our_groupchat_nick $groupid $nick
	chat::open_window $groupid groupchat
	conference::join $groupid $nick
    }
}

proc set_our_groupchat_nick {group nick} {
    global groupchats

    set groupchats(nick,$group) $nick
}

proc get_our_groupchat_nick {group} {
    global groupchats
    
    debugmsg conference [array get groupchats]
    return $groupchats(nick,$group)
}



proc add_group_dialog {} {
    global w

}


proc conference::parse_get_result {jid res child} {
    variable confs

    debugmsg conference "$res $child"

    if {![cequal $res OK]} {
	return
    }

    set confs(reqfields,$jid) {}

    jlib::wrapper:splitxml $child tag vars isempty chdata children

    if {[cequal [jlib::wrapper:getattr $vars xmlns] jabber:iq:conference]} {
	conference::parse_req_fields $jid $children
    }

    jlib::send_iq set \
	[jlib::wrapper:createtag enter \
	     -vars {xmlns jabber:iq:conference} \
	     -subtags $confs(reqfields,$jid)
	] \
	-to $jid -command [list conference::parse_join_result $jid]

    
}

proc conference::parse_req_fields {jid items} {
    variable confs

	    }
	    privacy {
		lappend confs(reqfields,$jid) \
		    [jlib::wrapper:createtag privacy]
}
	    key     {}
	    secret  {}
	    default {debugmsg conference "Unknown iq:conference tag '$tag'"}
	}
    }
}

proc conference::parse_join_result {jid res child} {
    variable confs

    debugmsg conference "JOIN: $res $child"

    if {![cequal $res OK]} {
	return
    }

    jlib::wrapper:splitxml $child tag vars isempty chdata children

    if {[cequal [jlib::wrapper:getattr $vars xmlns] jabber:iq:conference]} {
	foreach child $children {
	    jlib::wrapper:splitxml $child tag vars isempty chdata childrens
	    switch -- $tag {
		nick {
		    debugmsg conference "OURNICK: $chdata"
		    set_our_groupchat_nick $jid $chdata
		}
		id {
		    debugmsg conference "OURID: $chdata"
		    set ::chat::chats(ourjid,$jid) $chdata
		}
	    }
	}
    }
}


proc conference::proc_browse {parent jid} {
    global browser::browser
    
    if {[cequal $browser(category,$jid) user]} {
	if {![cequal $browser(type,$jid) remove]} {
	    chat::change_presence $jid available

    variable confs
    return [info exists confs(v2,$conf)]
}

proc conference::get_nick {jid} {
    global browser::browser

    debugmsg conference "NICK: $jid - $browser(name,$jid)"
    return $browser(name,$jid)
}

# $Id$

namespace eval message {
    set msgid 0
}

proc message::show_dlg {from subject body thread priority x} {
    variable msgid

    set mw .msg$msgid
    toplevel $mw

    wm title $mw "Message from $from"
    

    frame $mw.f
    grid columnconfigure $mw.f 1 -weight 1

    label $mw.f.lsubj -text Subject:
    entry $mw.f.subj
    $mw.f.subj insert 0 $subject
    $mw.f.subj configure -state disabled

    grid $mw.f.lsubj -row 0 -column 0 -sticky e
    grid $mw.f.subj  -row 0 -column 1 -sticky ew

    pack $mw.f -side top -anchor w -fill x


    ButtonBox $mw.buttons

    $mw.buttons add -text Reply \
	-command [list message::send_dlg $from $subject $thread]
    $mw.buttons add -text Close -command [list destroy $mw]
    pack $mw.buttons -side bottom -anchor e





    ScrolledWindow $mw.sw
    text $mw.body -width 50 -height 10 \
	-yscrollcommand [list $mw.scroll set]
    $mw.body insert 0.0 $body
    $mw.body configure -state disabled
    $mw.sw setwidget $mw.body
    pack $mw.sw -side bottom -fill both -expand yes

    foreach xe $x {
	process_x $mw.f $xe
    }

    focus $mw.body

    incr msgid
}


proc message::process_x {f x} {
    jlib::wrapper:splitxml $x tag vars isempty chdata children

    set xmlns [jlib::wrapper:getattr $vars xmlns]

    switch -- $xmlns {
	jabber:x:roster {
	    foreach child $children {
		process_x_roster $f $child
	    }
	}
	jabber:x:oob {
	    foreach child $children {
		process_x_oob $f $child
	    }
	}
	jabber:x:conference {
	    process_x_conference $f [jlib::wrapper:getattr $vars jid]
	}
    }
}


proc message::process_x_roster {f x} {
    jlib::wrapper:splitxml $x tag vars isempty chdata children

    lassign [grid size $f] row
    incr row

    set jid [jlib::wrapper:getattr $vars jid]
    set name [jlib::wrapper:getattr $vars name]

    if {$name != ""} {
	set desc $name
    } else {
	set desc $jid
    }

    label $f.luser$row -text "Attached user:"
    button $f.user$row -text $desc
    
    grid $f.luser$row -row $row -column 0 -sticky e
    grid $f.user$row  -row $row -column 1 -sticky ew
}

proc message::process_x_oob {f x} {
    jlib::wrapper:splitxml $x tag vars isempty chdata children

    lassign [grid size $f] row
    incr row

    switch -- $tag {
	url {
	    label $f.lurl$row -text "Attached URL:"
	    button $f.url$row -text $chdata
    
	    grid $f.lurl$row -row $row -column 0 -sticky e
	    grid $f.url$row  -row $row -column 1 -sticky ew
	}
	desc {
	    label $f.ldesc$row -text "URL description:"
	    label $f.desc$row -text $chdata
    
	    grid $f.ldesc$row -row $row -column 0 -sticky e
	    grid $f.desc$row  -row $row -column 1 -sticky ew
	}
    }
}

proc message::process_x_conference {f conf} {
    lassign [grid size $f] row
    incr row

    label $f.lconf$row -text "Invited to:"
    button $f.conf$row -text $conf -command [list join_group $conf $::gr_nick]
    
    grid $f.lconf$row -row $row -column 0 -sticky e
    grid $f.conf$row  -row $row -column 1 -sticky ew
}



proc message::send_dlg {to subject thread} {
    variable msgid

    set sendargs ""

    if {$thread != ""} {
	lappend sendargs -thread $thread
    }

    grid $mw.f.lsubj -row 1 -column 0 -sticky e
    grid $mw.f.subj  -row 1 -column 1 -sticky ew

    pack $mw.f -side top -anchor w -fill x

    frame $mw.buttons
    button $mw.buttons.close -text Close -command [list destroy $mw]
    button $mw.buttons.reply -text Send -command [list message::send $mw]

    pack $mw.buttons.close $mw.buttons.reply -side right
    pack $mw.buttons -side bottom -anchor e


    text $mw.body -width 50 -height 10
    pack $mw.body -side bottom -fill both -expand yes


    incr msgid
}


proc message::send {mw} {
    jlib::send_msg [$mw.f.to get] -type normal \
	-subject [$mw.f.subj get] \
	-body [$mw.body get 1.0 end]

    destroy $mw
}




proc message::show_subscribe_dlg {from x args} {
    variable msgid

    set status ""

    foreach {attr val} $args {
	switch -- $attr {
	    -status {set status $val}
	    default {puts "SHOW_SUBSCRIBE_MESSAGE: unknow attr $attr $val"}

    pack $mw.subj -side top -anchor w

    frame $mw.buttons
    button $mw.buttons.close -text Close -command [list destroy $mw]
    button $mw.buttons.subscribe -text Subscribe \
	-command [join [list [list jlib::send_presence -to $from \
				  -type subscribed] \
			    [list message::send_subscribe_dlg $from] \
			    [list destroy $mw]] \n]

    button $mw.buttons.unsubscribe -text Unsubscribe \
	-command [join [list [list jlib::send_presence -to $from \
				  -type unsubscribed] \
			    [list destroy $mw]] \n]

    pack $mw.body -side bottom -fill both -expand yes


    incr msgid
}


proc message::send_subscribe_dlg {to} {
    variable msgid

    set mw .msg$msgid
    toplevel $mw

    wm title $mw "Send subscription to $to"
    
    frame $mw.subj
    label $mw.subj.lab -text "Send subscription to "
    entry $mw.subj.entry
    $mw.subj.entry insert 0 $to
    pack $mw.subj.lab $mw.subj.entry -side left
    pack $mw.subj -side top -anchor w

    frame $mw.buttons
    button $mw.buttons.close -text Close -command [list destroy $mw]
    button $mw.buttons.reply -text Subscribe \
	-command [list message::send_subscribe $mw]

    pack $mw.buttons.close $mw.buttons.reply -side right
    pack $mw.buttons -side bottom -anchor e


    text $mw.body -width 50 -height 10
    $mw.body insert 0.0 "I would like to add you to my roster."
    pack $mw.body -side bottom -fill both -expand yes


    incr msgid
}

proc message::send_subscribe {mw} {
    jlib::send_presence -to [$mw.subj.entry get] -type subscribe \
	-status [$mw.body get 1.0 end]
    jlib::send_iq set \
	[jlib::wrapper:createtag query \
	     -vars {xmlns jabber:iq:roster} \
	     -subtags [list [jlib::wrapper:createtag item \
				 -vars [list jid \
					    [$mw.subj.entry get]]]]]
    destroy $mw

}

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

proc client:presence {from type x args} {
    global presence w

    debugmsg presence "PRESENCE: $from; $type; $x; $args"

    set from [tolower_node_and_domain $from]

    switch -- $type {
	unavailable {
	    array unset presence *,$from
	    #roster:changeicon $w.roster [user_from_jid $from] unavailable
	    #roster:set_item_presence [user_from_jid $from]
	    roster::on_change_jid_presence $from
	    debugmsg presence "[user_from_jid $from] unavailable"
	    chat::change_presence $from unavailable
	}
	subscribe {eval [list message::show_subscribe_dlg $from $x] $args}
	subscribed {}
	unsubscribe {}
	unsubscribed {tk_dialog .unsubscrb "Unsubscribed from $from" \
			  "We unsubscribed from $from" "" 0 Ok}
	probe {}
	error {}
	default {

	    #roster::on_change_jid_presence [user_from_jid $from]
	    roster::on_change_jid_presence $from
	    chat::change_presence $from $show
	}
    }
    
    
    #debugmsg presence [array get presence]
}




proc get_jid_of_user {user} {
    global presence

	switch -- $userstatus {
	    available {set command jlib::send_presence}
	    invisible {set command "jlib::send_presence -type $userstatus"}
	    default {
		set command "jlib::send_presence -show $userstatus"
	    }
	}
	debugmsg presence $command
	eval $command
	if {$userstatus != "invisible"} {
	    foreach group [array names chat::opened] {
		eval $command -to $group
	    }
	} else {
	    #FIX

	-to $jid -command [list register::recv_fields $sw $jid]
    
    incr winid
}


proc register::recv_fields {sw jid res child} {
    debugmsg register "$res $child"

    if {![cequal $res OK]} {
	return
    }

    jlib::wrapper:splitxml $child tag vars isempty chdata children

	-to $jid -command [list register::recv_result $sw $jid]
}


proc register::recv_result {sw jid res child} {
    variable data

    debugmsg register "$res $child"
    
    set result Successful!

    if {![cequal $res OK]} {
	set result Unsuccessful!
	return
    }

    set roster(jids) {}
    variable show_only_online 0
}


proc roster::process_item {jid name groups subsc ask category subtype} {
    variable roster
    debugmsg roster "ROSTER_ITEM: $jid; $name; $groups; $subsc; $ask; $category; $subtype"

    set jid [tolower_node_and_domain $jid]


    if {$subsc != "remove"} {
	if {[lsearch $roster(jids) $jid] == -1} {
	    lappend roster(jids) $jid

proc client:roster_push {jid name groups subsc ask category subtype} {
    roster::process_item $jid $name $groups $subsc $ask $category $subtype
    roster::redraw
}

proc client:roster_cmd {status} {
    debugmsg roster "ROSTER_CMD: $status"
    
    if {![string compare $status END_ROSTER]} {
	roster::redraw
    } else {
	global roster::roster
	set roster::roster(jids) {}
	roster::clear .roster
    }
}


proc roster::get_groups {} {
    variable roster

    set groups {}
    foreach jid $roster(jids) {
	#debugmsg roster [array get roster]
	set groups [concat $groups $roster(group,$jid)]
    }

    set groups [lrmdups $groups]
    return $groups
}

		-name     {set param name}
		-subsc    {set param subsc}
		-ask      {set param ask}
		-category {set param category}
		-subtype  {set param subtype}
		default   {set param ""}
	    }
	    #if {[info exists roster($param,$jid)]} {
		set roster($param,$jid) $val

	    #}
	}
    }
}



proc roster::redraw {} {

		if {!$show_only_online || [is_online $jid]} {
		    addline .roster jid $name $jid
		    changeicon .roster $jid [get_jid_icon $jid]
		}
	    }
	}
    }
    #debugmsg roster [array get roster collapsed*]
}


proc roster::get_jid_icon {jid} {
    variable roster

    if {![info exists roster(category,$jid)]} {
	return [get_user_icon $jid]
    }

    lassign [get_category_and_subtype $jid] category type

    switch -- $roster(category,$jid) {
	"" {
	    return [get_user_icon $jid]
	}
	user {
	    return [get_user_icon $jid]
	}
	conference {

	    set show [get_jid_status $jid]
	    if {$show != {unavailable}} {
		return group_on
	    }
	    return group_off
	}
	service {
	    switch -- $type {
		jud {return br_jud}
		default {return ""}
	    }
	}
	default {
	    return ""
	}
    }
}


proc roster::get_user_icon {user} {
    variable roster

}


proc roster::on_change_jid_presence {jid} {
    variable roster
    
    set rjid [find_jid $jid]
    debugmsg roster "$jid $rjid"

    if {$rjid != ""} {
	lassign [get_category_and_subtype $rjid] category subtype
	
	if {$category == "user"} {
	    set_status [cconcat [get_label $rjid] " is now " \
			    [get_user_status $rjid]]
	}
    }
    redraw
}

proc roster::find_jid {jid} {
    variable roster

    if {[lcontain $roster(jids) $jid]} {
	return $jid
    }

    lassign [heuristically_get_category_and_subtype $jid] category subtype
    debugmsg roster "$category $subtype"
    foreach rjid $roster(jids) {
	lassign [get_category_and_subtype $rjid] rcategory rsubtype
	if {$category == $rcategory} {
	    switch -- $category {
		user {
		    if {[node_and_server_from_jid $jid] == $rjid} {
			return $rjid

    bind $w.canvas <4> {
	%W yview scroll -1 units
    }
    bind $w.canvas <5> {
	%W yview scroll 1 units
    }

    if {$w == ".roster"} {
	DropSite::register .roster.canvas -dropcmd roster::dropcmd \
	    -droptypes {JID}
	DragSite::register .roster.canvas -draginitcmd roster::draginitcmd
    }

    #roster:addline $w group Friendsy gr1
    #roster:addline $w jid ì£ÈÁ aleksey@jabber.ru
    #roster:addline $w jid Dronich dron@jabber.ru
    #roster:changeicon $w aleksey@jabber.ru available
}

    $c bind jid$tag <Any-Enter> \
	[list $c itemconfig jid$tag&&rect -fill $config(${type}hlfill)]
    $c bind jid$tag <Any-Leave> \
	[list $c itemconfig jid$tag&&rect -fill $rfill]




    $c bind jid$tag&&jid <Double-Button-1> [list roster::jid_doubleclick $jid]

    set roster($w,ypos) [expr $ly + $config(linepad)]

    if {[cequal $type jid]} {
	$c bind jid$tag <Any-Enter> \

    set name [$f.name get]

    itemconfig $jid -name $name
    send_item $jid
    destroy $w
}

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

proc roster::dropcmd {target source X Y op type data} {
    variable roster
    debugmsg roster "$target $source $X $Y $op $type $data"

    set c .roster.canvas

    set x [expr {$X-[winfo rootx $c]}]
    set y [expr {$Y-[winfo rooty $c]}]
    set xc [$c canvasx $x]
    set yc [$c canvasy $y]

    set tags [$c gettags [lindex [$c find closest $xc $yc] 0]]
    if {[lcontain $tags group]} {
	set tag [crange [lindex $tags 0] 3 end]
	variable jidtags
	foreach gr [array names jidtags] {
	    if {$tag == $jidtags($gr)} {
		break
	    }
	}
    } else {
	set gr {}
    }

    puts "GG: $gr; $tags"

    lassign $data jid category type name version

    if {![lcontain $roster(jids) $jid]} {
	itemconfig $jid -category $category -subtype $type \
	    -name $name -group [list $gr]
    } else {
	set groups [itemconfig $jid -group]
	if {$gr != ""} {
	    lappend groups $gr
	    set groups [lrmdups $groups]
	    puts $groups
	}
	itemconfig $jid -category $category -subtype $type \
	    -name $name -group $groups
    }
    send_item $jid
}

proc roster::draginitcmd {target x y top} {
    variable roster
    debugmsg roster "$target $x $y $top"

    balloon::destroy
    set c .roster.canvas

    set tags [$c gettags current]
    if {[lcontain $tags jid]} {
	set tag [crange [lindex $tags 0] 3 end]
	variable jidtags
	foreach jid [array names jidtags] {
	    if {$tag == $jidtags($jid)} {
		break
	    }
	}

	set data [list $jid \
		      [itemconfig $jid -category] \
		      [itemconfig $jid -subtype] \
		      [itemconfig $jid -name] {}]

	puts $data
	return [list JID {copy} $data]
    } else {
	return {}
    }
}

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


image create photo available   -file [fullpath jarl-bitmaps available.gif]
image create photo away        -file [fullpath jarl-bitmaps available-away.gif]

set m [menu .jidpopupmenu]
$m add command -label "Start chat" -command {chat::open_to_user $curuser}
$m add command -label "Send message" -command \
    {message::send_dlg $curuser "" ""}
$m add separator
$m add command -label "Send users" -command {} -state disabled
$m add command -label "Send file" -command {ft::send_file_dlg $curuser}
$m add separator
$m add command -label "Show user info" -command {userinfo::open $curuser}
$m add command -label "Edit name" -command {roster::change_name_dlg $curuser}
$m add command -label "Edit groups" -command {show_group_edit $curuser}

	-to $jid -command [list search::recv_fields $sw $jid]
    
    incr winid
}


proc search::recv_fields {sw jid res child} {
    debugmsg search "$res $child"

    if {![cequal $res OK]} {
	return
    }

    jlib::wrapper:splitxml $child tag vars isempty chdata children

	-to $jid -command [list search::recv_items $sw $jid]
}


proc search::recv_items {sw jid res child} {
    variable data

    debugmsg search "$res $child"

    if {![cequal $res OK]} {
	return
    }

    #frame $sw.items
    #pack $sw.items -expand yes -fill both -after $sw.fields -anchor nw

    foreach item $items {
	jlib::wrapper:splitxml $item tag vars isempty chdata children

	switch -- $tag {
	    item {
		set itemjid [jlib::wrapper:getattr $vars jid]
		Button $g.l${row}0 -text $itemjid -font $font \
		    -helptext "Add user" \
		    -command [list message::send_subscribe_dlg $itemjid]
		grid $g.l${row}0 -row $row -column 0 -sticky w

		foreach field $children {
		    jlib::wrapper:splitxml $field tag vars isempty \
			chdata children1

		    if {[info exists fieldcol($tag)]} {
			set col $fieldcol($tag)
			label $g.l$row$col -text $chdata -font $font
			grid $g.l$row$col -row $row -column $col -sticky w
		    }
		    debugmsg search "$tag $chdata"
		}
		incr row
	    }
	    default {}
	}	
    }
}

if {[file exists ~/.tkabber/config.tcl]} {
    source ~/.tkabber/config.tcl
}



set version 0.0.0.0.1-alpha-20020809

tk appname tkabber


#option readfile ermine.xrdb userDefault
#option readfile examples/teopetuk.xrdb userDefault

option add *Entry.font $font widgetDefault
#option add *Entry.background White
#option add *Text.background White

if {$tcl_platform(platform) == "unix"} {
    set debug_lvls {jlib}
} else {
    # Don't show debug information on enemy os
    set debug_lvls {}
}


proc debugmsg {level msg} {
    global debug_lvls





    if {[lcontain $debug_lvls $level]} {

	puts "$level: $msg"
    }
}








proc rescmd {id res ls} {
    puts "RESULT: $id $res $ls"
}


proc fullpath {args} {

######  XML library hack
proc xml::XML:decrypt {text} {
    return $text
}

proc ::LOG text {
    debugmsg jlib "$text\n"
}


###############################################################################
# Interface
###############################################################################

set w {}
wm title $w. "Tkabber"

	{command "Profile report" {} {} {} -command {
	    profile off profil
	    profrep profil cpu profresults
	}}
    }
    "&Services" {} {} 1 {
	{command "Send message" {} {} {} \
	     -command {message::send_dlg "" "" ""}}
	{cascad "Roster" {} {} 1 {
	    {command "Add user" {} {} {} \
		 -command {message::send_subscribe_dlg ""}}
	    {command "Add conference" {} {} {} -command {add_group_dialog}}
	}}
	{command "Browser" {} {} {} -command {browser::open}}
	{command "Join group" {} {} {} -command {join_group_dialog}}
	{command "Filters" {} {} {} -command {filters::open}}
	{separator}
	{cascad "Admin tools" {} {} 1 {
	    {command "Send broadcast message" {} {} {} \
		 -command {eval {message::send_dlg \
				     "$loginconf(server)/announce/online" \
				     {} {}}}}
	}}
    }
    "&Help" {} {} 1 {
	{command "Quick help" {} {} {} -command {
	    MessageDlg .m -anchor center -aspect 50000 -title "Quick help" \

}

set toolbar [$mf addtoolbar]
set bbox [ButtonBox $toolbar.bbox -spacing 0 -padx 1 -pady 1]

$bbox add -image newuser \
    -highlightthickness 0 -takefocus 0 -relief link -borderwidth 1 \
    -padx 1 -pady 1 -command {message::send_subscribe_dlg ""} \
    -helptext "Add new user"
$bbox add -image jb \
    -highlightthickness 0 -takefocus 0 -relief link -borderwidth 1 \
    -padx 1 -pady 1 -command {browser::open} \
    -helptext "Jabber Browser"
$bbox add -image groupchat \
    -highlightthickness 0 -takefocus 0 -relief link -borderwidth 1 \

} else {
    roster::create $w.roster -width 150 -height 300 -popup roster::popup_menu
    pack $w.roster -expand yes -fill both -side left -in [$mf getframe]
}




proc add_win {path args} {
    global usetabbar

    set title ""
    set tabtitle ""
    set class ""
    set raisecmd ""

proc tab_set_updated {path updated} {
    global usetabbar

    if {$usetabbar} {
	set page [crange [win_id tab $path] 1 end]

	update idletasks

	#if {$page == [.nb raise]} {return}

	if {$updated && $page != [.nb raise]} {
	    set color Red
	} else {
	    set color Black
	}

	#.nb.c itemconfigure $page:text -fill $color
	if {[.nb itemconfigure $page -foreground] != $color} {
	    .nb itemconfigure $page -foreground $color
	}

	#puts "$path $updated $page $color [.nb raise]"
    }
}

proc tab_menu {x y page} {
    global curmenutab

	$txt insert 0.0 [set $descvar]
    }
}



proc userinfo::parse_vcard {jid res child} {
    debugmsg userinfo "$res $child"

    if {![cequal $res OK]} {
	return
    }

    
    jlib::wrapper:splitxml $child tag vars isempty chdata children

	ORG      {parse_vcard_org_item $jid $children}
	TITLE    {set userinfo(title,$w)     $chdata}
	ROLE     {set userinfo(role,$w)      $chdata}
	BDAY     {set userinfo(bday,$w)      $chdata}
	UID      {set userinfo(uid,$w)       $chdata}
	URL      {set userinfo(url,$w)       $chdata}
	DESC     {set userinfo(desc,$w)      $chdata}
	default {debugmsg userinfo "Unknown vCard tag $tag"}
    }
}


proc userinfo::parse_vcard_n_item {jid items} {
    variable userinfo

    set w [w_from_jid $jid]


    foreach item $items {
	jlib::wrapper:splitxml $item tag vars isempty chdata children

	switch -- $tag {
	    FAMILY {set userinfo(family,$w) $chdata}
	    GIVEN  {set userinfo(name,$w)   $chdata}
	    MIDDLE {set userinfo(middle,$w) $chdata}
	    PREFIX {set userinfo(prefix,$w) $chdata}
	    SUFFIX {set userinfo(suffix,$w) $chdata}
	    default {debugmsg userinfo "Unknown vCard <N/> subtag $tag"}
	}
    }
}

proc userinfo::parse_vcard_adr_item {jid items} {
    variable userinfo

	switch -- $tag {
	    STREET   {set userinfo(address,$w)   $chdata}
	    EXTADD   {set userinfo(address2,$w) $chdata}
	    LOCALITY {set userinfo(city,$w)   $chdata}
	    REGION   {set userinfo(state,$w) $chdata}
	    PCODE    {set userinfo(pcode,$w)   $chdata}
	    COUNTRY  {set userinfo(country,$w) $chdata}
	    default  {debugmsg userinfo "Unknown vCard <ADR/> subtag $tag"}
	}
    }
}

proc userinfo::parse_vcard_tel_item {jid items} {
    variable userinfo

	    PCS    {lappend types pcs}
	    PREF   {lappend types pref}
	    NUMBER {
		foreach t $types {
		    set userinfo(tel_$t,$w) $chdata
		}
	    }
	    default {debugmsg userinfo "Unknown vCard <TEL/> subtag $tag"}
	}
    }
}

proc userinfo::parse_vcard_geo_item {jid items} {
    variable userinfo

    set w [w_from_jid $jid]


    foreach item $items {
	jlib::wrapper:splitxml $item tag vars isempty chdata children

	switch -- $tag {
	    LAT {set userinfo(geo_lat,$w) $chdata}
	    LON {set userinfo(geo_lon,$w)  $chdata}
	    default {debugmsg userinfo "Unknown vCard <ORG/> subtag $tag"}
	}
    }
}

proc userinfo::parse_vcard_org_item {jid items} {
    variable userinfo

    set w [w_from_jid $jid]

    # TODO: <!ELEMENT ORG (ORGNAME, ORGUNIT*)>

    foreach item $items {
	jlib::wrapper:splitxml $item tag vars isempty chdata children

	switch -- $tag {
	    ORGNAME  {set userinfo(orgname,$w) $chdata}
	    ORGUNIT {set userinfo(orgunit,$w)  $chdata}
	    default {debugmsg userinfo "Unknown vCard <ORG/> subtag $tag"}
	}
    }
}


proc userinfo::parse_iqversion {jid res child} {
    debugmsg userinfo "$res $child"

    if {![cequal $res OK]} {
	return
    }

    
    jlib::wrapper:splitxml $child tag vars isempty chdata children

    foreach item $items {
	jlib::wrapper:splitxml $item tag vars isempty chdata children

	switch -- $tag {
	    name    {set userinfo(clientname,$w)    $chdata}
	    version {set userinfo(clientversion,$w) $chdata}
	    os      {set userinfo(os,$w)            $chdata}
	    default {debugmsg userinfo "Unknown iq:version tag '$tag'"}
	}
    }
}



proc userinfo::parse_iqtime {jid res child} {
    debugmsg userinfo "$res $child"

    if {![cequal $res OK]} {
	return
    }

    
    jlib::wrapper:splitxml $child tag vars isempty chdata children

    foreach item $items {
	jlib::wrapper:splitxml $item tag vars isempty chdata children

	switch -- $tag {
	    utc     {}
	    display {set userinfo(time,$w) $chdata}
	    tz      {}
	    default {debugmsg userinfo "Unknown iq:version tag '$tag'"}
	}
    }
}