# forms.tcl
# Suport for editing forms and form elements

array set FormMenu {
    {input type=text name=! size= maxlength= value=} 	
				{form		"Text input"}
    {input type=password name=! size= maxlength= value=} 	
				{form		"Password input"}
    {input type=checkbox name=! checked= value=!} 	
				{form		"Checkbox"}
    {input type=radio name=! checked= value=!} 	
				{form		"Radio Button"}
    {input type=hidden name=! value=!} 	
				{form		"Hidden Field"}
    {input type=image name=! src=! align=} 	
				{form		"Input Image"}
    {input type=reset name=! value=} 	
				{form		"Reset Button"}
    {input type=submit name=! value=} 	
				{form		"Submit Button"}
    {select name=! multiple= size=} 	
				{form		"Selection List"}
    {option value=! selection=} 	
				{form		"Selection Item"}
    {textarea name=! cols=! rows=!}	{form	"Text Area"}
}

proc Form_Reset {win} {
    upvar #0 Form$win globalForm
    upvar #0 HM$win var
    set var(S_formid) 0
    if [info exists globalForm(ids)] {
	foreach formVar $globalForm(ids) {
	    upvar #0 $formVar form
	    catch {unset form}
	}
    }
    set globalForm(ids) {}
    if [winfo exists globalForm(menu)] {
	catch {$globalForm(menu).edit delete 0 end}
	$globalForm(menu) entryconfigure "Edit Form Tag" -state disabled
	$globalForm(menu) entryconfigure "Add Form Item" -state disabled
    }
}
proc Form_Menu {win menu} {
    global FormMenu
    upvar #0 Form$win globalForm

    set globalForm(menu) $menu
    $menu add command -label "New Form..." \
	    -command [list Input_Tag $win {form  action= method= enctype=}] \
	    -underline 0
    $menu add command -label "Edit Form Tag" \
	    -command [list FormEditTag $win] \
	    -underline 0 \
	    -state disabled

    $menu add cascade -label "Add Form Item" -menu $menu.add -state disabled
    set menu [menu $menu.add]
    foreach x [lsort [array names FormMenu]] {
	set label [lindex $FormMenu($x) 0]
	$menu add command -label \
	    [format "%-6s %s" [lindex $x 0] [lindex $FormMenu($x) 1]] \
	    -command [list Input_Tag $win $x] \
	    -underline 0
    }

}

# Form_Setup lets the user choose among form templates,
# then initializes the form.
proc Form_Setup { win spec } {
    upvar #0 HM$win var
    upvar #0 Form$win globalForm
    global WebTk

    Log $win Form_Setup $spec

    regsub -all {\.} forminit$win {_} top
    set top .$top
    catch {destroy $top}
    toplevel $top -bd 4 -relief raised
    message $top.msg -text \
"Please choose a form template."
    pack $top.msg

    set f [frame $top.f -bd 10]
    set l [listbox $f.list -height 10 -yscrollcommand "$f.scroll set"]
    scrollbar $f.scroll -command "$f.list yview" -orient vertical
    pack $f.scroll -side left -fill y
    pack $f.list -side top -fill both -expand true
    pack $f -side top -fill both -expand true

    # After one necessary to avoid crash in <Button-1> event handler
    bind $l <Double-Button-1> "$top.ok flash ; after 1 [list FormSetupOK $win $top %W]"

    button $top.ok -text OK -command [list FormSetupOK $win $top $l]
    button $top.cancel -text Cancel -command [list destroy $top]
    button $top.custom -text Custom -command [list FormSetupOK $win $top custom]
    pack $top.ok $top.custom $top.cancel -side left
    pack $top.cancel -side right

    Platform_WaitVisibility $top

    foreach template [lsort \
	[glob -nocomplain [file join $WebTk(html) form *]]] {
	set x [file tail $template]
	$l insert end $x
    }

    set globalForm(makeform) 0
    tkwait window $top

    if !$globalForm(makeform) {
	return
    }
    Edit_PasteHtml $win $globalForm(html)
    unset globalForm(makeform) globalForm(html)
    FormEditTag $win
}
proc FormSetupOK {win top {list custom}} {
    upvar #0 Form$win globalForm
    global WebTk
    set globalForm(makeform) 1
    set globalForm(html) \
"<form action=URL method=POST><p>Add form items here.</p></form>"
    if {"$list" != "custom"} {
	set i [$list curselection]
	if {$i != ""} {
	    set template [$list get $i]
	    set path [file join $WebTk(html) form $template]
	    if [catch {open $path r} in] {
		Status $win $in
	    } else {
		Log $win FormTemplate $path
		set globalForm(html) [read  $in]
		close $in
	    }
	}
    } else {
	set htag "form action=URL method=POST"
	if [catch {$win index sel.first}] {
	    Text_TagAdd $win H:$htag 1.0 end
	    set start 1.0
	} else {
	    Text_TagAdd $win H:$htag sel.first sel.last
	    set start sel.first
	}
	Text_MarkSet $win insert $start
	HMtag_form $win "action=URL method=POST" {}	;# Set state
	FormEditTag $win
	set globalForm(makeform) 0
    }
    destroy $top
}

# HMform_install is called by the <form> tag processing code to let us
# know that a new form is being displayed.

proc HMform_install {win param formVar} {
    upvar #0 Form$win globalForm
    if {[lsearch $globalForm(ids) $formVar] < 0} {
	lappend globalForm(ids) $formVar
    }
    set m $globalForm(menu)
    if [winfo exists $m] {
	$m entryconfigure "Add Form Item" -state normal
	$m entryconfigure "Edit Form Tag" -state normal
    }
}
proc Form_EditMode {win edit} {
    upvar #0 HM$win var
    if ![info exists var(S_formid)] {
	return
    }
    for {set id 1} {$id <= $var(S_formid)} {incr id} {
	upvar #0 HM$win.form$id form
	foreach w [array names form widgets,*] {
	    regsub ^widgets, $w {} w
	    if ![winfo exists $w] {
		continue
	    }
	    if {$edit} {
		bindtags $w FormEdit
	    } else {
		bindtags $w [list $w [winfo class $w] [winfo toplevel $w] all]
	    }
	}
    }
}
bind FormEdit <ButtonRelease> {FormEditWidget %W}
bind FormEdit <Enter> {FormHighlightWidget %W}
bind FormEdit <Leave> {FormUnHighlightWidget %W}

proc FormEditTag {win} {
    upvar #0 HM$win var
    foreach tag [$win tag names insert] {
	if [regexp {H:form(.*)$} $tag x y] {
	    set htag $tag
	}
    }
    if [info exists htag] {
	Form_SetID $win insert
	upvar #0 $var(form_id) form
	set x [Dialog_Htag $win {form action=! method=!} "form $form(param)" \
		"Action is the URL of a cgi-bin script" FormEditHook]
	if {[llength $x] > 0} {
	    set form(param) [lindex $x 1]
	    lassign {m1 m2} [Edit_CurrentRange $win $htag insert]
	    Text_TagRemove $win $htag $m1 $m2
	    Text_TagAdd $win H:[string trim "form $form(param)"] $m1 $m2
	    Mark_ReadTags $win insert
	}
    }
}
# Tweak the Htag dialog
proc FormEditHook {f dialogVar} {
    upvar $dialogVar dialog
    pack forget $f.f1.entry	;# Unpack METHOD entry
    set var [$f.f1.entry cget -textvariable]
    radiobutton $f.f1.post -text Post -value POST -variable $var
    radiobutton $f.f1.get -text Get -value GET -variable $var
    pack $f.f1.post $f.f1.get -side left
    upvar #0 $var local
    if {![info exists local] && ![string length $local]} {
	set local POST
    } else {
	set local [string toupper $local]
    }
}
proc FormEditWidget {widget} {
    # Find the main text widget
    set child $widget
    set win [winfo parent $child]
    while {[winfo class $win] != "Text"} {
	set child $win
	set win [winfo parent $win]
    }
    Mark_ReadTags $win $child
    upvar #0 HM$win var
    upvar #0 $var(form_id) form

    FormEditItem $win $form(widgets,$widget)
}
proc FormHighlightWidget {widget} {
    $widget config -highlightcolor red -highlightbackground red
}
proc FormUnHighlightWidget {widget} {
    set parent [winfo parent $widget]
    set fg [$parent cget -highlightcolor]
    set bg [$parent cget -highlightbackground]
    $widget config -highlightcolor $fg -highlightbackground $bg
}
proc FormEditItem {win value} {
    global FormMenu
    upvar #0 HM$win var
    upvar #0 $var(form_id) form

    set type [lindex $value 0]
    set spec [lindex $value 1]
    set widget [lindex $value 2]
    set mark [lindex $value 3]

    dputs type $type spec $spec mark $mark
    Log $win FormEditItem $type $spec $mark

    set bg [$widget cget -highlightbackground]
    set fg [$widget cget -highlightcolor]
    $widget config -highlightbackground red -highlightcolor red
    $win see $widget

    # Extract the full spec from the Form menu
    set fullspec [lindex [array names FormMenu $type*] 0]
    set hook [list FormHook $fullspec $widget]
    switch -- $type {
	select {
	    # Get choice values from the widget
	    set choices {}
	    set list $widget.list
	    for {set i 0} {$i < [$list index end]} {incr i} {
		lappend choices [$list get $i]
	    }
	    set default {}
	    catch {set default $form(default,$list)}
	    set hook [list FormSelectHook $fullspec $choices \
			$form(values,$list) $default $widget]
	}
	input {
	    set subtype text
	    HMextract_param $spec type subtype
	    dputs subtype $subtype
	    foreach x [array names FormMenu input*] {
		if [regexp -nocase "type\[ \t]*=\[ \t]*\"?$subtype" $x] {
		    set fullspec $x
		    break
		}
	    }
	    set hook [list FormHook $fullspec $widget]
	}
    }
    set state [Dialog_Htag $win $fullspec "$type $spec" \
	"Edit $type parameters" $hook]
    if [llength $state] {
	switch -- $type {
	    textarea {
		set w $widget.text
		lappend state [$w get 1.0 end]
	    }
	    select {
		set w $widget.list
	    }
	    default {
		set w $widget
	    }
	}
	Text_MarkSet $win insert $widget
	unset form(widgets,$w)
	catch {unset form(values,$w)}
	dputs delete $widget
	Text_Delete $win $widget $widget
	Mark_Remove $win $mark
	FormInsertItem $win $type $state
    } else {
	dputs $widget config -highlightbackground $bg -highlightcolor $fg
	$widget config -highlightbackground $bg -highlightcolor $fg
    }
}
proc FormInsertItem {win type state} {
    set htag [lindex $state 0]
    set param [lindex $state 1]
    set text {}
    switch -- $type {
	select {
	    lassign {clist vlist dlist} [lindex $state 2]
	    set html "<select $param>"
	    for {set i 0} {$i < [$clist index end]} {incr i} {
		set data [$clist get $i]
		if {[string length $data] == 0} {
		    continue
		}
		set value [$vlist get $i]
		set tag option
		if {[string length $value]} {
		    append tag " value=\"$value\""
		}
		set default [$dlist get $i]
		if {[string length $default] &&
			![regexp -nocase ^no$ $default]} {
		    append tag " SELECTED"
		}
		append html "<$tag>$data"
	    }
	    append html "</select>"
	}
	textarea {
	    set text [lindex $state 2]
	    set html "<textarea $param>$text</textarea>"
	}
    }
    if [info exists html] {
	Input_Html $win $html
    } else {
	HMrender $win $htag {} $param $text
    }
}
proc FormHook {spec widget frame dialogVar} {
    upvar $dialogVar dialog
    set i 0
    foreach x [lrange $spec 1 end] {
	switch -regexp -- $x {
	    checked= {
		pack forget $frame.f$i.entry
		checkbutton $frame.f$i.check -text "" \
		    -variable [$frame.f$i.entry cget -textvariable] \
		    -onvalue "on" -offvalue ""
		pack $frame.f$i.check -side left
	    }
	    type=submit {
		catch {	;# Maybe no widget yet
		    button $frame.but.submit -text "Test Submit" -command \
			[$widget cget -command]
		    pack $frame.but.submit
		}
	    }
	}
	incr i
    }
}
proc FormSelectHook {spec choices values defaults widget frame dialogVar} {
    upvar $dialogVar dialog

    set height [llength $choices];
    if {$height < 3} {
	incr height 2
    } elseif {$height < 10} {
	incr height 1
    } else {
	set height 10
    }
    set f [frame $frame.select]
    pack $f -side bottom -fill both -expand true -padx 10

    label $f.ctext -text "Value Displayed"
    frame $f.choice

    set clist [listbox $f.choice.l -height $height -exportselection false]
    pack $f.choice.l -side left -expand true -fill both

    label $f.dtext -text "Is Default"
    frame $f.default

    set dlist [listbox $f.default.l -height $height -exportselection false -width 2]

    pack $f.default.l -side left -expand true -fill both

    label $f.vtext -text "Value Reported"
    frame $f.value

    set vlist [listbox $f.value.l -height $height -exportselection false]
    scrollbar $f.value.s -command "FormSelectYview $clist $vlist $dlist" -orient vertical
    $clist config -yscrollcommand "$f.value.s set"
    $vlist config -yscrollcommand "$f.value.s set"
    $dlist config -yscrollcommand "$f.value.s set"

    pack $f.value.s -side right -fill y
    pack $f.value.l -side left -expand true -fill both

    grid $f.ctext $f.vtext $f.dtext		-sticky we
    grid $f.choice $f.value $f.default	-sticky news
    grid columnconfigure $f 0 -weight 1
    grid columnconfigure $f 2 -weight 1
    grid rowconfigure $f 1 -weight 1

    foreach {choice} $choices {value} $values {
	$clist insert end $choice
	$vlist insert end $value
	$dlist insert end {}
    }
    foreach i $defaults {
	$dlist delete $i
	$dlist insert $i "yes"
    }
    foreach list [list $clist $vlist $dlist] {
	$list insert end {}
	bind $list <Button-1>	[list FormSelectFocus %W %y $clist $vlist $dlist]
	bind $list <Key> 		{FormSelectTypin %W %A}
	bind $list <Key-BackSpace> 	{FormSelectBackspace %W}
	bind $list <Key-Return> [list FormSelectReturn %W $clist $vlist $dlist]
	bind $list <Key-Delete> [list FormSelectDelete %W $clist $vlist $dlist]
	bind $list <Button-2>	[list FormSelectMark $clist $vlist $dlist %x %y]
	bind $list <B2-Motion>	[list FormSelectDragto $clist $vlist $dlist %x %y]
    }
    bind $clist <Key-Tab> "focus $dlist ; break"
    bind $dlist <Key-Tab> "focus $vlist ; break"
    bind $vlist <Key-Tab> "focus $clist ; break"

    return [list $clist $vlist $dlist]
}
proc FormSelectYview {clist vlist dlist args } {
    eval {$clist} yview $args
    eval {$vlist} yview $args
    eval {$dlist} yview $args
}
proc FormSelectMark {clist vlist dlist x y} {
    $clist scan mark $x $y
    $vlist scan mark $x $y
    $dlist scan mark $x $y
}
proc FormSelectDragto {clist vlist dlist x y} {
    $clist scan dragto $x $y
    $vlist scan dragto $x $y
    $dlist scan dragto $x $y
}
proc FormSelectFocus {list y clist vlist dlist} {
    focus $list
    set i [$list nearest $y]
    foreach list [list $clist $vlist $dlist] {
	FormSelectItem $list $i
    }
}
proc FormSelectTypin {list c} {
    if {$c != "" && $c != "{}"} {
	set i [$list curselection]
	set value [$list get $i]
	append value $c
	$list delete $i
	$list insert $i $value
	FormSelectItem $list $i
    }
}
proc FormSelectBackspace {list} {
    set i [$list curselection]
    set value [$list get $i]
    set value [string range $value 0 [expr [string length $value]-2]]
    $list delete $i
    $list insert $i $value
    FormSelectItem $list $i
}
proc FormSelectDelete {list clist vlist dlist} {
    set i [$list curselection]
    if {$i == ""} {
	return
    }
    foreach list [list $clist $vlist $dlist] {
	$list delete $i
	FormSelectItem $list $i
    }
}
proc FormSelectReturn {list clist vlist dlist} {
    set i [$list curselection]
    if {$i < [$list index end]} {
	incr i
    }
    foreach list [list $clist $vlist $dlist] {
	$list insert $i {}
	FormSelectItem $list $i
    }
}
proc FormSelectItem {list i} {
    $list activate $i
    $list selection clear 0 end
    $list selection set $i
    $list see $i
}

# This procedure is responsible for outputing the <select><option> tags
# for a selection box.  The <select> tag is output automatically
# because there is a text mark.  The rest of the option and /select tag
# must be generated by this routine.
proc FormSelectOutput {stateVar win widget}  {
    upvar $stateVar state
    upvar #0 HM$win var
    Form_SetID $win $widget
    upvar #0 $var(form_id) form
    set list $widget.list
    set defaults {}
    catch {set defaults $form(default,$list)}
    set html {}
    for {set i 0} {$i < [$list index end]} {incr i} {
	set data [$list get $i]
	if {[string length $data] == 0} {
	    continue
	}
	set tag option
	set value [lindex $form(values,$list) $i]
	if {[string length $value] && 
		([string compare $value $data] != 0)} {
	    append tag " value=\"$value\""
	}
	if {[lsearch $defaults $i] >= 0} {
	    append tag " selected"
	}
	if [info exists state(displaytext)] {
	    # Compute the whole blob of html to insert into the display
	    append html "<$tag>$data"
	} else {
	    eval $state(tagProc) state {$tag}
	    eval $state(textProc) state {$data}
	}
    }
    if [info exists state(displaytext)] {
	eval $state(displaytext) [$win index $widget] {$html}
    }
}

# This procedure is responsible for outputing the <textarea></textarea> tags
# for a textarea box.
proc FormTextAreaOutput {stateVar win widget}  {
    upvar $stateVar state
    upvar #0 HM$win var
    Form_SetID $win $widget
    upvar #0 $var(form_id) form
    set html {}
    set default [$widget.text get 1.0 end]
    if [info exists state(displaytext)] {
	eval $state(displaytext) [$win index $widget] {$default}
    } else {
	eval $state(textProc) state {$default}
    }
}

# Form_Item creates a dialog to initialize a form element.
# spec is a specification of the required and optional parameters.
# 
proc Form_Item { win spec } {
    upvar #0 HM$win var
    Form_SetID $win insert

    set type [lindex $spec 0]
    if {$type == "select"} {
	set hook [list FormSelectHook $spec {one two three} {} {} {}]
    } else {
	set hook [list FormHook $spec {}]
    }
    set state [Dialog_Htag $win $spec {} \
	"Form element:\n$spec\n! flags required parameter" \
	$hook]
    if [llength $state] {
	if {$type == "textarea"} {
	    lappend state {}	;# initial text
	}
	FormInsertItem $win $type $state
    }
}

# The Submit and Reset handlers

proc FormSubmit {win formVar param} {
    upvar #0 HM[Window_GetMaster $win] var $formVar form
    set var(form_id) $formVar
    set query {}

    dputs $win $formVar $param
    # The name/value on a submit button might be used for identification
    HMextract_param $param value
    HMextract_param $param name
    if ![info exists name] {
	set name submit
    }
    if [info exists value] {
	lappend query [list $name $value]
    }
    # Suck values from the rest of the form elements
    FormIterate $win $formVar {FormSubmitQuery query}

    # Map into the proper format
    set newquery {}
    foreach pair $query {
	set value [lindex $pair 1]
	if {$value != ""} {
	    set item [lindex $pair 0]
	    lappend newquery $item $value
	}
    }
    # this is the user callback.
    Log $win  HMsubmit_form $form(param) $newquery
    HMsubmit_form $win $form(param) $newquery

}

# TODO - Figure out how to get the state from type=image
proc FormSubmitQuery {qVar win formVar type htag param widget} {
    upvar #0 HM$win var $formVar form
    upvar $qVar query
    set name $type
    HMextract_param $param name
    set tclvar {}
    if [HMextract_param $param tclvar] {
	upvar #0 $tclvar z
	if [info exists z] {
	    set value $z
	}
    }
    if ![info exists value] {
	set value {}
	HMextract_param $param value	;# handles "hidden", too
    }
    dputs $win $formVar $type $htag $param $widget
    switch -- $type {
	option -
	reset -
	submit {
	    return
	}
	select {
	    set list $widget
	    set sel [$list curselection]
	    for {set i 0} {$i < [$list size]} {incr i} {
		if {[lsearch $sel $i] >= 0} {
		    lappend query [list $name [lindex $form(values,$widget) $i]]
		}
	    }
	    return
	}
	radio -
	checkbox {
	    upvar #0 [$widget cget -variable] x
	    set value $x
	}
	password -
	text {
	    set value [$widget get]
	}
	textarea {
	    set value [$widget get 1.0 end]
	}
	image {
	    error "The editor doesn't do form image maps, yet"
	}
    }
    if {$type == "radio"} {
	if {[lsearch $query [list $name $value]] >= 0} {
	    return
	}
    }
    lappend query [list $name $value]
}
proc FormReset {win formVar param} {
    Log $win FormReset
    FormIterate $win $formVar FormResetItem
}
proc FormResetItem {win formVar type htag param widget} {
    upvar #0 HM[Window_GetMaster $win] var $formVar form
    set var(form_id) $formVar
    Log $win FormResetItem $type $htag $param $widget
    switch -- $type {
	select {
	    set list $widget.list
	    $list selection clear 0 end
	    if [info exists form(default,$list)] {
		foreach ix $form(default,$list) {
		    $list select $ix
		}
	    } else {
		    $list select 0
	    }
	}
	radio {
	    $widget deselect
	    if [HMextract_param $param checked] {
		$widget select
	    }
	}
	checkbox {
	    if {[HMextract_param $param checked]} {
		    $widget select
	    } else {
		    $widget deselect
	    }
	}
	password -
	text {
	    $widget delete 0 end
	    if {[HMextract_param $param value]} {
		    $widget insert 0 $value
	    }
	}
	textarea {
	    set t $widget.text
	    $t delete 1.0 end
	    $t insert 1.0 $form(textarea,$widget)
	}
    }
}
proc FormIterate {win formVar callback} {
    upvar #0 HM[Window_GetMaster $win] var $formVar form
    foreach w [array names form widgets,*] {
        regsub ^widgets, $w {} w
	lassign {htag param} $form(widgets,$w)
	if {"$htag" == "input"} {
	    set type text
	    HMextract_param $param type
	} else {
	    set type $htag
	}
	uplevel [concat $callback [list $win $formVar $type $htag $param $w]]
    }
}

proc HMsubmit_form {win param query} {
	set mainwin [Window_GetMaster $win]
	upvar #0 HM$mainwin var
	set result ""
	set sep ""
	set text {}
	dputs param $param
	foreach i $query {
		append result  $sep [HMmap_reply $i]
		append text $i
		if {$sep != "="} {
		    set sep =
		    append text " = "
		} else {
		    set sep &
		    append text \n
		}
	}
	set action $var(S_url)
	HMextract_param $param action
	set method GET
	HMextract_param $param method
	if {![Input_Edit $win]} {
	    dputs HMlink_callback $method $action $result
	    if {$method == "GET"} {
		    HMlink_callback $mainwin $action?$result
	    } else {
		    HMlink_callback $mainwin $action $result
	    }
	   # return
	} else {
	    # Otherwise just display the query
	    set t .submit.t
	    if [winfo exists .submit] {
		raise .submit
	    } else {
		toplevel .submit -bd 4 -relief raised
		wm title .submit "Submit Results"
		text $t -width 50 -height 30 -yscrollcommand {.submit.s set}
		scrollbar .submit.s -command "$t yview"
		pack .submit.s -side right -fill y
		pack $t -side left -expand true -fill both
	    }
	    $t delete 1.0 end
	    $t insert insert "Form attributes:\n"
	    foreach x [split $param] {
		$t insert insert "  $x\n"
	    }
	    $t insert insert "\nRaw query:\n"
	    $t insert insert $result\n
	    $t insert insert "\nForm values:\n"
	    $t insert insert $text
	}
}

