# compile_html.tcl
#
#	Compile an hui file into HTML code.
#
#
# Copyright (c) 1997 Sun Microsystems, Inc. All rights reserved.
#
# SCCS: @(#) compile_html.tk 1.1 97/05/16 17:19:02

# compile a ui into an HTML form
#
#  file:  the name of the file containing the ui description
#  out:	  The name of the file to write the tk program to (defaults to stdout)
#  prefix: The procedure prefix
#  run:	  Invoke the generated procedure (not used)

proc compile_hui {file {out ""} {prefix ""}} {
    global Widget_data Masters Version
    set Id "WidGet file"
    catch "unset Masters"
    array set map {row height column width}

    if {![file readable $file]} {
	set msg "Can't read $file"
	tk_dialog .open "Read Error" $msg "error" 0 OK
	return 1
    }
    set fd [open "$file" r]

    set line ""
    gets $fd line
    if {[string first $Id $line] != 0} {
	set msg "$file is not a UI file"
	tk_dialog .open "Open Error" $msg "error" 0 OK
	close $fd
	return 1
    }

    if {$out == ""} {
	set out_fd stdout
    } elseif {[catch [list open $out w] out_fd]} {
	tk_dialog .open "Save Error"  $out_fd "error" 0 OK
	set _Message "can't write to $out"
	return 1
    }
    

    # gather up all of the data for each widget

    while {1} {
	gets $fd line
	if {[eof $fd]} break

	# gather entire line

	while {![info complete $line]} {
	    append line "\n[gets $fd]"
	    # puts stderr gulp
	}
	if {[string first Widget $line] == 0} {
	    set name [lindex $line 1]
	    lappend names $name
	    upvar #0 __X_$name data
	} else {
	    set index -1
	    foreach i {type option value} {
		set $i [lindex $line [incr index]]
	    }

	    # fix the font name

	    if {$option == "font"} {
		# puts stderr "Filtering font"
		$Widget_data(outfilter:font) dummy font value
	    }

	    if {$option == "master"} {
		set Masters([string trimleft \
		    [expr {$value=="" ? "f" : $value}] .]) 1
	    }
	    set data($type,$option) $value
	}
    }
    close $fd

    # now output the info as a tcl script

    if {$prefix == ""} {
	set prefix [file root [file tail $file]]
    }
    puts $out_fd "<!HTML generated by SpecTcl version $Version from $file>"
    # run any prefix code (Turn off for now)
    
    # now create the widgets (and the tags)
    # Sort the widgets to end up with the correct tabbing order
    puts $out_fd <form>
    compile_table $out_fd $names {}
    puts $out_fd </form>
    close $out_fd 
}


# compile_table --
#
#	Recursively compiles the UI into an HTML table.
#
# Arguments:
#	out_fd	the putput file channel
#	names	list of all the widgets in the UI
#	master	the master of the (sub)table currently being generated.
#
# Results:
#	None.

proc compile_table {out_fd names master} {
    set row 1
    set col 1

    puts $out_fd <table>
    puts $out_fd <tr>

    foreach name [lsort -command sort_row_col [get_children $names $master]] {
	upvar #0 __X_$name data

	if {$row < $data(geometry,row)} {
	    while {$row < $data(geometry,row)} {
		puts $out_fd </tr>
		puts $out_fd <tr>
		incr row
	    }
	    set col 1
	}
	if {$col < $data(geometry,column)} {
	    puts $out_fd "<td><!empty cell></td>"
	    incr col
	}

	puts -nonewline $out_fd "<td"
	if [info exists data(geometry,sticky)] {
	    if [string match *w* $data(geometry,sticky)] {
		puts $out_fd " ALIGN=LEFT"
	    } elseif [string match *e* $data(geometry,sticky)] {
		puts $out_fd " ALIGN=RIGHT"
	    }  else {
		puts $out_fd " ALIGN=CENTER"
	    }
	    if [string match *n* $data(geometry,sticky)] {
		puts $out_fd " VALIGN=TOP"
	    } elseif [string match *s* $data(geometry,sticky)] {
		puts $out_fd " VALIGN=BOTTOM"
	    }  else {
		puts $out_fd " VALIGN=MIDDLE"
	    }
	}
	if [info exists data(geometry,rowspan)] {
	    puts $out_fd " ROWSPAN=$data(geometry,rowspan)"
	}
	if [info exists data(geometry,columnspan)] {
	    puts $out_fd " COLSPAN=$data(geometry,columnspan)"
	}
	puts -nonewline $out_fd ">"

	case $data(other,type) {
	    button {
		case $data(other,htmltype) {
		    {submit reset} {
			puts -nonewline $out_fd \
			    "<INPUT TYPE=$data(other,htmltype) "
			puts -nonewline $out_fd \
			    "VALUE=[html_quote $data(configure,text)]>"
		    }
		}
	    }
	    {checkbutton radiobutton} {
		if {$data(other,type) == "checkbutton"} {
		    puts -nonewline $out_fd "<INPUT TYPE=checkbox"
		} else {
		    puts -nonewline $out_fd "<INPUT TYPE=radio"
		    puts -nonewline $out_fd " VALUE=$data(configure,value)"
		}
		puts -nonewline $out_fd \
		    " NAME=[html_quote $data(configure,variable)]"
		if [string match 1 $data(other,checked)] {
		    puts -nonewline $out_fd " CHECKED"
		}
		puts -nonewline $out_fd ">"
		puts -nonewline $out_fd [html_quote $data(configure,text)]
	    }
	    entry {
		puts -nonewline $out_fd "<INPUT TYPE=text "
		puts -nonewline $out_fd \
		    "NAME=[html_quote $data(other,item_name)]>"
	    }
	    label {	
		puts -nonewline $out_fd [html_quote $data(configure,text)]
	    }
	    listbox {
		puts -nonewline $out_fd "<select size=5></select>"
	    }
	    text {
		puts -nonewline $out_fd "<textarea>"
		puts -nonewline $out_fd "</textarea>"
	    }
	    frame {
		puts $out_fd ""
		compile_table $out_fd $names .$name
		puts $out_fd ""
	    }
	}
	puts $out_fd "</td>"
	incr col
    }
    puts $out_fd </tr>
    puts $out_fd </table>
}

proc html_quote {text} {
    regsub -all "<" $text "\\&lt;" text
    return $text
}


# figure out the resize behavior

proc get_resize {list} {
	set index 0
	set result ""
	foreach i $list {
		if {$i > 1} {
			lappend result 1
		} else {
			lappend result 0
		}
	}
	return $result
}

proc get_children {names master} {
    set children {}

    foreach name $names {
	upvar #0 __X_$name data

	if {$name == "f"} {
	    continue
	}
	if {$data(other,master) == $master} {
	    lappend children $name
	}
    }

    return $children
}

# sort_row_col --
#
#	Sort the widgets by row,column order of the top-left corner of
#	the widget. E.g.  (r1,c1) before (r1,c2) before (r2,c1)
#
#	This version depends upon the running state of SpecTcl, and
#	needs to be re-written to permit the compiler to be invoked as
#	a separate app

proc sort_row_col {name1 name2} {
    upvar #0 __X_$name1 data1 __X_$name2 data2

    if {$data1(geometry,row) < $data2(geometry,row)} {
	return -1
    } elseif {$data1(geometry,row) > $data2(geometry,row)} {
	return  1
    } else {
	if {$data1(geometry,column) < $data2(geometry,column)} {
	    return -1
	} else {
	    return 1
	}
    }
}

