# $Id: datagathering.tcl 1442 2008-05-21 11:36:30Z sergei $
#
# Data Forms (XEP-0004) support
#

namespace eval data {
    set winid 0

    # Registration & search fields (see XEP-0077 & XEP-0055)

    array set field_labels [list \
	username     [::msgcat::mc "Username:"] \
	nick         [::msgcat::mc "Nickname:"] \
	password     [::msgcat::mc "Password:"] \
	name         [::msgcat::mc "Full Name:"] \
	first        [::msgcat::mc "First Name:"] \
	last         [::msgcat::mc "Last Name:"] \
	email        [::msgcat::mc "E-mail:"] \
	address      [::msgcat::mc "Address:"] \
	city         [::msgcat::mc "City:"] \
	state        [::msgcat::mc "State:"] \
	zip          [::msgcat::mc "Zip:"] \
	phone        [::msgcat::mc "Phone:"] \
	url          [::msgcat::mc "URL:"] \
	date         [::msgcat::mc "Date:"] \
	misc         [::msgcat::mc "Misc:"] \
	text         [::msgcat::mc "Text:"] \
	key          [::msgcat::mc "Key:"]]

    disco::register_feature jabber:x:data
}

proc data::fill_fields {g items} {
    variable data
    variable field_labels

    set row 0
    set data(varlist,$g) {}
    
    grid columnconfig $g 1 -weight 1 -minsize 0

    foreach item $items {
	jlib::wrapper:splitxml $item tag vars isempty chdata children
	set xmlns [jlib::wrapper:getattr $vars xmlns]
	if {$xmlns == "jabber:x:data" || $xmlns == "jabber:iq:data"} {
	    return [fill_fields_x $g $children]
	}
    }

    set focus ""
    set fields {}
    foreach item $items {
	jlib::wrapper:splitxml $item tag vars isempty chdata children

	switch -- $tag {
	    instructions {
		message $g.instructions$row -text $chdata -width 10c
		grid $g.instructions$row -row $row -column 0 -columnspan 2 \
		    -sticky w -pady 2m
		incr row
	    }
	    registered -
	    x {}
	    default {
                lappend fields $tag $chdata
	    }
	}
    }
    foreach {tag chdata} $fields {
	lappend data(varlist,$g) $tag

	if {[info exists field_labels($tag)]} {
	    label $g.l$row -text $field_labels($tag)
	} else {
	    label $g.l$row -text $tag
	}
	switch -- $tag {
	    key {
		entry $g.$row \
		    -textvariable [namespace current]::data(var,$tag,$g) \
		    -state disabled
	    }
	    password {
		entry $g.$row \
		    -textvariable [namespace current]::data(var,$tag,$g) \
		    -show *
		if {$focus == ""} {
		    set focus $g.$row
		}
	    }
	    default {
		entry $g.$row \
		    -textvariable [namespace current]::data(var,$tag,$g)
		if {$focus == ""} {
		    set focus $g.$row
		}
	    }
	}

	if {$chdata != {}} {
	    set data(var,$tag,$g) $chdata
	}

	grid $g.l$row -row $row -column 0 -sticky e
	grid $g.$row  -row $row -column 1 -sticky we

	incr row
    }
    return $focus
}

proc data::cleanup {g} {
    variable data

    array unset data *,$g
}

proc data::get_tags {g} {
    variable data

    if {[info exists data(x,$g)]} {
	return [get_tags_x $g]
    }

    set restags {}

    if {[info exists data(varlist,$g)]} {
	foreach var $data(varlist,$g) {
	    lappend restags [jlib::wrapper:createtag $var \
				 -chdata $data(var,$var,$g)]
	}
    }

    return $restags
}

proc data::get_reported_fields {g} {
    variable data

    return $data(varlist,$g)
}

###############################################################################
# x:data processing
###############################################################################

# create field tag

proc ::data::createfieldtag {type args}  {
    array set params $args

    switch -- $type {
	instructions -
	title {
	    if {[info exists params(-value)]} {
		return [jlib::wrapper:createtag $type \
			    -chdata $params(-value)]
	    } else {
		error "You must define -value"
	    }
	}

	fixed - 
	hidden -
	list-single -
	list-multi -
	text-single - 
	text-multi -
	text-private -
	jid-multi -
	jid-single -
	boolean {
	    set vars [list type $type]

	    if {[info exists params(-var)]} {
		lappend vars var $params(-var)
	    } elseif {![string equal $type fixed]} {
		error "You must define -var"
	    }

	    if {[info exists params(-label)]} {
		lappend vars label $params(-label)
	    }

	    set subtags  {}
	    if {[info exists params(-descr)]} {
		lappend subtags [jlib::wrapper:createtag descr \
				     -chdata $params(-descr)]
	    }
	    if {[info exists params(-required)] && $params(-required)} {
		lappend subtags [jlib::wrapper:createtag required]
	    }
	    if {[lcontain {jid-multi text-multi list-multi hidden fixed} $type]} {
		if {[info exists params(-values)]} {
		    foreach value $params(-values) {
			lappend subtags [jlib::wrapper:createtag value \
					     -chdata $value]
		    }
		} elseif {[lcontain {jid-multi hidden fixed} $type]} {
		    error "You must define -values"
		}
	    } else {	    
		if {[info exists params(-value)]} {
		    lappend subtags [jlib::wrapper:createtag value \
					 -chdata $params(-value)]
		}
	    }
		
	    if {[lcontain {list-multi list-single} $type]} {
		if {[info exists params(-options)]} {
		    foreach option $params(-options) {
			lassign $option name label
			lappend subtags \
			    [jlib::wrapper:createtag option \
				 -vars [list label $label] \
				 -subtags \
				 [list [jlib::wrapper:createtag value \
					    -chdata $name]]]
		    }
		} else {
		    error "You must define -options"
		}
	    }
	    
	    return [jlib::wrapper:createtag field \
			-vars $vars \
			-subtags $subtags]	    
	}
	
	default {
	    error "Unknown type $type"
	}
    }   
}

# parse_result
proc data::parse_xdata_results {items args} {
    set report_hidden 0
    foreach {key val} $args {
	switch -- $key {
	    -hidden { set report_hidden $val }
	}
    }

    set result {}
    foreach item $items {
	jlib::wrapper:splitxml $item tag vars isempty chdata children
	if {$tag != "field"} {
	    continue
	}
	set type [jlib::wrapper:getattr $vars type]
	if {!$report_hidden && $type == "hidden"} {
	    continue
	}
	set var [jlib::wrapper:getattr $vars var]
	if {$var == ""} {
	    continue
	}
	set label [jlib::wrapper:getattr $vars label]
	set values {}
	foreach child $children {
	    jlib::wrapper:splitxml $child tag1 vars1 isempty1 chdata1 children1
	    if {$tag1 == "value"} {
		lappend values $chdata1
	    }
	}
	lappend result [list $var $type $label $values]
    }
    return $result
}

proc data::add_label {g row label {required 0}} {
    if {$label != ""} {
	if {$required} {
	    set prefix *
	} else {
	    set prefix ""
	}
	if {![string is punct [string index $label end]]} {
	    set suffix :
	} else {
	    set suffix ""
	}
	label $g.label$row -text ${prefix}${label}$suffix
	grid $g.label$row -row $row -column 0 -sticky en
    }
}

proc data::render_media {g row media_list} {
    foreach item $media_list {
	jlib::wrapper:splitxml $item tag vars isempty chdata children
	set unsupported 1
	foreach child $children {
	    jlib::wrapper:splitxml $child tag1 vars1 isempty1 chdata1 children1
	    switch -- $tag1 {
		uri {
		    render_url $g.mediauri$row $chdata1 $chdata1 -bg [get_conf $g -bg]
		    grid $g.mediauri$row -row $row -column 1 -sticky ew
		    set unsupported 0
		    incr row
		}
		data {
		    set type [jlib::wrapper:getattr $vars1 type]
		    switch -glob -- $type {
			image/* {
			    if {![catch {image create photo -data [base64::decode $chdata1]} img]} {
				label $g.mediaimg$row -image $img
				bind $g.mediaimg$row <Destroy> [list image delete $img]
				grid $g.mediaimg$row -row $row -column 1 -sticky ew
				set unsupported 0
				incr row
			    }
			}
			default {
			    # TODO: implement other types
			}
		    }
		}
	    }
	}
	if {$unsupported} {
	    # No supported media item
	    return -code error "No supported types for a media element"
	}
    }
    return $row
}

proc data::fill_fields_x {g items} {
    variable data

    set data(x,$g) 1
    set row 0
    set data(allvarlist,$g) {}
    set focus ""

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

	switch -- $tag {
	    instructions {
		#add_label $g $row [::msgcat::mc "Instructions"]
		message $g.instructions$row -text $chdata -width 15c
		grid $g.instructions$row -row $row -column 0 \
		    -columnspan 2 -sticky w -pady 2m
		incr row
	    }
	    field {
		set widget [fill_field_x $g $row $tag $vars $chdata $children]
		if {$focus == ""} {
		    set focus $widget
		}
		incr row
	    }
	    title {
		set top [winfo toplevel $g]
		if {$top != "."} {
		    wm title $top $chdata
		    wm iconname $top $chdata
		}
	    }
	    default {
		debugmsg filetransfer "XDATA: unknown tag $tag"
	    }
	}
    }

    # FIX THIS
    set data(varlist,$g) $data(allvarlist,$g)

    return $focus
}


proc data::fill_field_x {g row tag vars chdata children} {
    variable data

    set required 0
    set desc {}
    set options {}
    set vals {}
    set var   [jlib::wrapper:getattr $vars var]
    set type  [jlib::wrapper:getattr $vars type]
    if {$type == ""} {
	set type text-single
    }
    set label [jlib::wrapper:getattr $vars label]
    set data(var,$var,$g) ""
    set widget ""
    set media_list {}

    foreach item $children {
	jlib::wrapper:splitxml $item tag1 vars1 isempty1 chdata1 children1
	switch -- $tag1 {
	    required {set required 1}
	    value {
		set data(var,$var,$g) $chdata1
		lappend vals $chdata1
	    }
	    desc {set desc $chdata1}
	    option {
		set lab [jlib::wrapper:getattr $vars1 label]
		foreach item $children1 {
		    jlib::wrapper:splitxml $item \
			tag2 vars2 isempty2 chdata2 children2
		    switch -- $tag2 {
			value {set val $chdata2}
		    }
		}
		lappend options $lab $val
	    }
	    media {
		if {[jlib::wrapper:getattr $vars1 xmlns] == $::NS(media-element)} {
		    lappend media_list $item
		}
	    }
	}
    }

    switch -- $type {
	jid-single -
	text-single -
	text-private {
	    add_label $g $row $label $required
	    set row [render_media $g $row $media_list]
	    entry $g.entry$row \
		-textvariable [namespace current]::data(var,$var,$g)
	    if {$type == "text-private"} {
		$g.entry$row configure -show *
	    }
	    grid $g.entry$row  -row $row -column 1 -sticky we
	    set widget $g.entry$row
	    if {$desc != ""} {
		balloon::setup $g.entry$row -text $desc
	    }
	}
	jid-multi -
	text-multi {
	    add_label $g $row $label $required
	    set row [render_media $g $row $media_list]
	    set sw [ScrolledWindow $g.textsw$row -scrollbar vertical]
	    textUndoable $g.text$row -height 6 -width 50
	    $sw setwidget $g.text$row
	    bind $g.text$row <Control-Key-Return> { }
	    bind $g.text$row <Return> "[bind Text <Return>]\nbreak"
	    set data(var,$var,$g) [join $vals \n]
	    catch { $g.text$row insert end $data(var,$var,$g) }
	    grid $sw -row $row -column 1 -sticky we
	    set data(text,$var,$g) $g.text$row
	    set widget $g.text$row
	    if {$desc != ""} {
		balloon::setup $g.text$row -text $desc
	    }
	}
	boolean {
	    switch -- $data(var,$var,$g) {
		1 -
		0 {
		    set onvalue 1
		    set offvalue 0
		}
		true -
		false {
		    set onvalue true
		    set offvalue false
		}
		default {
		    set onvalue 1
		    set offvalue 0
		    set data(var,$var,$g) 0
		}
	    }
	    add_label $g $row $label $required
	    set row [render_media $g $row $media_list]
	    checkbutton $g.cb$row \
		-variable [namespace current]::data(var,$var,$g) \
		-onvalue $onvalue -offvalue $offvalue
	    grid $g.cb$row  -row $row -column 1 -sticky w
	    set widget $g.cb$row
	    if {$desc != ""} {
		balloon::setup $g.cb$row -text $desc
	    }
	}
	fixed {
	    add_label $g $row $label $required
	    set row [render_media $g $row $media_list]
	    catch { message $g.m$row -text [join $vals \n] -width 10c }
	    grid $g.m$row -row $row -column 1 -sticky w
	    set dont_report 1
	    if {$desc != ""} {
		balloon::setup $g.m$row -text $desc
	    }
	}
	list-single {
	    add_label $g $row $label $required
	    set row [render_media $g $row $media_list]
	    set height 0
	    foreach {lab val} $options {
		lappend data(combol$row,$var,$g) $lab
		incr height
		if {[string equal $data(var,$var,$g) $val]} {
		    set data(combov$row,$var,$g) $lab
		}
	    }
	    if {$height > 10} {
		set height 10
	    }
	    set cb [ComboBox $g.combo$row \
			-height $height \
			-editable no \
			-values $data(combol$row,$var,$g) \
			-textvariable \
			[namespace current]::data(combov$row,$var,$g)]
	    grid $cb -row $row -column 1 -sticky we
	    trace variable [namespace current]::data(combov$row,$var,$g) w \
		[list data::trace_combo $options \
		     [namespace current]::data(var,$var,$g)]
	    set widget $g.combo$row
	    if {$desc != ""} {
		balloon::setup $g.combo$row -text $desc
	    }
	}
	list-multi {
	    add_label $g $row $label $required
	    set row [render_media $g $row $media_list]
	    set sw [ScrolledWindow $g.sw$row]
	    set l [listbox $g.lb$row -height 6 \
		       -selectmode multiple -exportselection no]
	    $sw setwidget $l
	    foreach {lab val} $options {
		$l insert end $lab
		if {[lcontain $vals $val]} {
		    $l selection set end
		}
	    }
	    grid $sw  -row $row -column 1 -sticky we
	    set data(multi,$var,$g) 1
	    trace_listmulti $l $options \
		data::data(var,$var,$g)
	    bind $l <<ListboxSelect>> \
		[list data::trace_listmulti %W $options \
		     [namespace current]::data(var,$var,$g)]
	    set widget $sw
	    if {$desc != ""} {
		balloon::setup $g.lb$row -text $desc
	    }
	}
	hidden {}

	default {
	    debugmsg filetransfer "XDATA: unknown field type '$type'"
	}
    }

    if {![info exists dont_report]} {
	lappend data(allvarlist,$g) $var
    }
    return $widget
}

proc data::trace_combo {assoc dst name1 name2 op} {
    foreach {lab val} $assoc {
	if {[string equal $lab [set ${name1}($name2)]]} {
	    set $dst $val
	}
    }
}

proc data::trace_listmulti {l assoc dst} {
    set $dst {}
    foreach idx [$l curselection] {
	#debugmsg filetransfer [lindex $assoc [expr $idx * 2 + 1]]
	lappend $dst [lindex $assoc [expr $idx * 2 + 1]]
    }
}


proc data::get_tags_x {g} {
    variable data

    set restags {}

    foreach var $data(varlist,$g) {
	if {[info exists data(multi,$var,$g)]} {
	    set vartags {}
	    foreach val $data(var,$var,$g) {
	        lappend vartags [jlib::wrapper:createtag value \
	        		     -chdata $val]
	    }
	} elseif {[info exists data(text,$var,$g)]} {
	    set data(var,$var,$g) [$data(text,$var,$g) get 1.0 "end -1c"]
	    set vartags {}
	    foreach val [split $data(var,$var,$g) \n] {
	        lappend vartags [jlib::wrapper:createtag value \
	        		     -chdata $val]
	    }
	} else {
	    set vartags [list [jlib::wrapper:createtag value \
	        		   -chdata $data(var,$var,$g)]]
	}
	lappend restags [jlib::wrapper:createtag field \
			     -vars [list var $var] \
			     -subtags $vartags]
    }

    set restag [list [jlib::wrapper:createtag x \
			  -vars [list xmlns jabber:x:data type submit] \
			  -subtags $restags]]

    return $restag
}

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

proc data::draw_window {items send_cmd {cancel_cmd destroy}} {
    variable winid

    set w .datagathering$winid
    incr winid

    if {[winfo exists $w]} {
	destroy $w
    }

    toplevel $w -class XData
    wm group $w .
    wm title $w ""
    wm iconname $w ""
    wm transient $w .
    wm withdraw $w
    set geometry [option get $w geometry XData]
    if {$geometry != ""} {
	wm geometry $w $geometry
    }

    set sw [ScrolledWindow $w.sw]
    set sf [ScrollableFrame $w.fields -constrainedwidth yes]
    set f [$sf getframe]
    $sf configure -height 10
    $sw setwidget $sf
    if {[catch {data::fill_fields $f $items} focus]} {
	destroy $w
	return -code error $focus
    }

    set bbox [ButtonBox $w.bbox -spacing 10 -padx 10 -default 0]
    pack $bbox -side bottom -anchor e -padx 2m -pady 2m
    $bbox add -text [::msgcat::mc "Send"] \
	-command [list eval $send_cmd [list $w] \[data::get_tags $f\]]
    $bbox add -text [::msgcat::mc "Cancel"] \
	-command [list eval $cancel_cmd [list $w]]
    bind $w <Return> [list ButtonBox::invoke $bbox default]
    bind $w <Escape> [list ButtonBox::invoke $bbox 1]
    bind $f <Destroy> [list [namespace current]::cleanup $f]

    bindscroll $f $sf

    pack [Separator $w.sep] -side bottom -fill x  -pady 1m

    set hf [frame $w.error]
    pack $hf -side top
    set vf [frame $w.vf]
    pack $vf -side left -pady 2m
    pack $sw -side top -expand yes -fill both -padx 2m -pady 2m

    update idletasks
    $hf configure -width [expr {[winfo reqwidth $f] + [winfo pixels $f 1c]}]

    set h [winfo reqheight $f]
    set sh [winfo screenheight $w]
    if {$h > $sh - 200} {
	set h [expr {$sh - 200}]
    }
    $vf configure -height $h
    wm deiconify $w
    if {$focus != ""} {
	focus $focus
    }

    return $w
}

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

proc data::request_data {xmlns jid node args} {

    foreach {key val} $args {
	switch -- $key {
	    -connection { set connid $val }
	}
    }
    if {![info exists connid]} {
	return -code error "data::request_data error: -connection required"
    }

    set vars [list xmlns $xmlns]
    if {$node != ""} {
	lappend vars node $node
    }

    jlib::send_iq get \
	[jlib::wrapper:createtag query \
	     -vars $vars] \
	-to $jid \
	-connection $connid \
	-command [list [namespace current]::receive_data $connid $xmlns $jid $node]
}

proc data::receive_data {connid xmlns jid node res child} {
    if {[string equal $res DISCONNECT]} {
	return
    }

    if {[string equal $res ERR]} {
	set ew .data_err
	if {[winfo exists $ew]} {
	    destroy $ew
	}
	MessageDlg $ew -aspect 50000 -icon error \
	    -message [::msgcat::mc "Error requesting data: %s" \
				   [error_to_string $child]] \
	    -type user -buttons ok -default 0 -cancel 0
	return
    }

    switch -- $xmlns {
	jabber:iq:data {
	    set children [list $child]
	}
	default {
	    jlib::wrapper:splitxml $child tag vars isempty chdata children
	}
    }

    data::draw_window $children \
	[list [namespace current]::send_data $connid $xmlns $jid $node] \
	[list [namespace current]::cancel_data $connid $xmlns $jid $node]
}

proc data::cancel_data {connid xmlns jid node w} {
    send_data $connid $xmlns $jid $node $w \
	      [list [jlib::wrapper:createtag x \
			 -vars [list xmlns jabber:x:data \
				     type cancel]]]
}

proc data::send_data {connid xmlns jid node w restags} {
    switch -- $xmlns {
	jabber:iq:data {
	    set child [lindex $restags 0]
	    jlib::wrapper:splitxml $child tag vars isempty chdata children

	    array set arr $vars
	    set arr(xmlns) $xmlns
	    set vars [array get arr]
	}
	default {
	    set children $restags
	    set vars [list xmlns $xmlns]
	}
    }

    if {$node != ""} {
        lappend vars node $node
    }

    destroy $w.error.msg
    $w.bbox itemconfigure 0 -state disabled

    jlib::send_iq set [jlib::wrapper:createtag query \
			   -vars $vars \
			   -subtags $children] \
	-to $jid \
	-connection $connid \
	-command [list [namespace current]::test_error_res $w]
}

proc data::test_error_res {w res child} {
    if {[string equal $res OK]} {
	destroy $w
	return
    }

    $sw.bbox itemconfigure 0 -state normal

    set m [message $w.error.msg \
		   -aspect 50000 \
		   -text [error_to_string $child] \
		   -pady 2m]
    $m configure -foreground [option get $m errorForeground Message]
    pack $m
}

disco::browser::register_feature_handler jabber:iq:data \
    [list [namespace current]::data::request_data jabber:iq:data] -node 1 \
    -desc [list * [::msgcat::mc "Data form"]]

disco::browser::register_feature_handler ejabberd:config \
    [list [namespace current]::data::request_data ejabberd:config] -node 1 \
    -desc [list * [::msgcat::mc "Configure service"]]