# SpecTcl, by S. A. Uhler and Ken Corey
# Copyright (c) 1994-1995 Sun Microsystems, Inc.
#
# See the file "license.txt" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# compile a ui file into tk code - TAKE 2
# Thu Apr  6 14:22:59 PDT 1995

# Each project file has the following format:
# 1: title-> WidGet file, created:  <date>

# 2: widget_data ...
#
# widget data consists of:
#   Widget  <name>
#   <tab> <type> <name> <value>
#   ...

# template for running ui file stand-alone

set Stand {

# Allow interface to be run "stand-alone" for testing

catch {
    if [info exists embed_args] {
	# we are running in the plugin
	%1$s .
    } else {
	# we are running in stand-alone mode
	if {$argv0 == [info script]} {
	    wm title . "Testing %1$s"
	    %1$s .
	}
    }
}}

proc compile_append {var newline data} {
    upvar $var v

    append v $data
    if {$newline} {
	append v \n
    }
}

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


proc compile_ui {file {out ""} {prefix ""}} {
    global Widget_data Format Masters Version P tcl_platform
    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" != ""} {
	if {[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]"
	}
	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"} {
		$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
    set script ""

    if {$prefix == ""} {
	set prefix [file root [file tail $file]]
    }
    case $tcl_platform(platform) {
	unix {
	    if ![info exists P(unix-stub)] {
		set P(unix-stub) [unix_stub_default]
	    }

	    compile_append script 1 "$P(unix-stub)"
	}
    }

    compile_append script 1 \
	"# interface generated by SpecTcl version $Version from $file"
    compile_append script 1 \
	"#   root     is the parent window for this user interface"
    compile_append script 1 \
	"\nproc [list ${prefix}_ui] {root args} {"
    compile_append script 1 {
	# this treats "." as a special case

	if {$root == "."} {
	    set base ""
	} else {
	    set base $root
	}
    }

    # now create the widgets (and the tags)
    # Sort the widgets to end up with the correct tabbing order

    set names [lsort -command "frames_first" $names]
    foreach name $names {
	upvar #0 __X_$name data

	if {$name == "f" } continue

	# gather up the widget command.
	#  Substitute %W's in -command.  This needs to change

	compile_append script 0 \
	    "\t$data(other,type) \$base.$data(other,item_name)"
	set options [lsort [array names data configure,*]]
	set font ""
	foreach option $options {
	    regsub configure, $option {} param
	    set value $data($option)
	    set check [expr [string match *command* $param] || \
		    [string match *variable* $param]]
	    if {$check && [string match {*%[BWMR]*} $value]} {
		regsub -all {([][$])} $value {\\\1} value
		regsub -all {(^|[^%])%W} $value \
		    \\1\$base.$data(other,item_name) value
		regsub -all {(^|[^%])%B} $value \\1\$base value
		regsub -all {(^|[^%])%R} $value \\1\$root value
		regsub -all {(^|[^%])%M} $value \\1[real_master $name] value
		regsub -all {([^\\])?"} $value {\1\\"} value
		compile_append script 0 " \\\n\t\t-$param \"$value\""
	    } elseif {$param == "menu"} {
		compile_append script 0 " \\\n\t\t-$param \"\$base.$data(other,item_name).$value\""
	    } else {

		# To prevent bad fonts from aborting the entire ui,
		# don't issue -font commands directly, but use "configure"
		# surrounded by a catch instead

		set stuff "-$param [list $value]"
		if {$param == "font"} {
		    append font $stuff
		} else {
		    compile_append script 0 " \\\n\t\t$stuff"
		}
	    }
	}

	# now issue the font configure command in a catch

	if {$font != ""} {
	    compile_append script 0 \
		"\n\tcatch \{\n\t\t\$base.$data(other,item_name) configure \\\n\t\t\t$font\n\t\}"
	}
	compile_append script 1 "\n"
	
	# find the tags
	
	if {$data(other,tags) != ""} {
	    append tags "\tbindtags \$base.$data(other,item_name) [list $data(other,tags)]\n"
	}

    }

    # print out any binding tags

    if {[info exists tags]} {
	compile_append script 1 "\n\t# binding tags\n\n$tags"
    }

    # Add content to menus
    compile_append script 1 "\n\t# Add contents to menus"
    foreach name $names {
	upvar #0 __X_$name data
	if {"$data(other,type)" != "menu"} {
	    continue
	}
	compile_append script 1 ""
	foreach {item options} $data(other,gadgets) {
	    compile_append script 0 \
	        "\t\$base.$data(other,item_name) add $item"
	    foreach {option val} $options {
	        if {"$option" != "-menu"} {
	            compile_append script 0 "\\\n\t\t$option [list $val]"
	        } else {
	            compile_append script 0 "\\\n\t\t$option \$base.$data(other,item_name).$val"
	        }
	    }
	    compile_append script 1 ""
	}
    }

    # now create the geometry management commands
    # this has to wait until all of the widgets are created to
    # avoid forward references

    compile_append script 1 "\n\t# Geometry management"
    foreach name $names {
	upvar #0 __X_$name data
	if {[set master [real_master $name]] == ""} {
	    continue
	}
	if {"$data(other,type)" == "menu"} {
	    continue
	}
	compile_append script 1 ""
	compile_append script 0 \
	    "\tgrid \$base.$data(other,item_name) -in $master"
	compile_append script 0 \
	    "\t-row $data(geometry,row) -column $data(geometry,column) "
	foreach option [lsort [array names data geometry,*]] {
	    regsub geometry, $option {} param
	    if {$param == "row" || $param == "column"} continue
	    compile_append script 0 " \\\n\t\t-$param [list $data($option)]"
	}
    }

    # now for the resize behavior, this is only run for geometry masters

    compile_append script 1 "\n\n\t# Resize behavior management"

    foreach name [array names Masters] {
	upvar #0 __X_$name data
        # puts "Processing master $name"
	if {$data(other,item_name) == "f"} {
	    set master \$root
	} else {
	    set master \$base.$data(other,item_name)
	}
	compile_append script 1 ""
	# puts "widget:$name master:$master"
	# parray data
	foreach dim {row column} {
	    set list [get_resize  $data(other,resize_$dim) $data(other,weight_$dim)]
	    if {[llength $list] > 0} {
		set index 0
		foreach w $list size $data(other,min_$dim) pad $data(other,pad_$dim) {
		    compile_append script 1 \
			"\tgrid ${dim}configure $master [incr index] -weight $w -minsize $size -pad $pad"
		}
	    }
	}	
    }

    # now output the additional interface code  (turned off for now)

    global __X_f
    compile_append script 1 "# additional interface code"
    if {[info exists __X_f(other,code)]} {
	compile_append script 1 $__X_f(other,code)
    }
    compile_append script 1 "# end additional interface code\n"
    compile_append script 1 "}"

    # output code to permit file to be run "stand alone"

    global Stand
    compile_append script 1 [format $Stand [list ${prefix}_ui]]

    if {"$out" != ""} {
        puts -nonewline $out_fd $script
	close $out_fd
        port_wishOwnThisFile [file join [pwd] $out]
	set script ""
    }
    
    foreach i [info globals __X_*] {
	global $i
	unset $i
    }

    return $script
}

# figure out the resize behavior

proc get_resize {list1 {list2 ""}} {
	set index 0
	set result ""
	if {[llength $list2]==0} {
	    foreach i $list1 {lappend list2 1}
	}
	foreach i $list1 {
		if {$i > 1} {
			lappend result [lindex $list2 $index]
		} else {
			lappend result 0
		}
		incr index
	}
	return $result
}

# Sort the widgets to generate the proper stacking order
# * Create all the frames first.  Make sure all outer frames are 
#   created before the inner ones
# * Create all widgets in the specified tabbing order.  If the tab order is the
#   same, then use row/col order based on the coordinates of the containing
#   table cell

# 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 frames_first {name1 name2} {
	upvar #0 __X_$name1 data1 __X_$name2 data2
	dputs "compare $name1 $name2"

	# both frames
	if {$data1(other,type) == "frame" && $data2(other,type) == "frame"} {
            if {$data2(other,level) == ""} {
		set data2(other,level) 0
            }
	    return [expr $data1(other,level) - $data2(other,level)]
	}

	# 1 frame, 1 widget
	if {$data1(other,type) == "frame"} {
		return -1
	} elseif {$data2(other,type) == "frame"} {
		return 1
	}

	# 1 menu, 1 widget
	# Menus always come last because sometimes they are
	# children of menubuttons
	if {$data1(other,type) == "menu"} {
		if {$data2(other,type) == "menu"} { # both are menus
			regsub {[^.]} $data1(other,item_name) {} str1
			regsub {[^.]} $data2(other,item_name) {} str2
			# Always put the one with most "."s last
			return [expr [string length $str1]>[string length $str2]? 1: -1]
		} else {
			return 1
		}
	} elseif {$data2(other,type) == "menu"} {
		return -1
	}

	# sort by explicit tabbing order field
	if {[set result [string compare $data1(other,tabbing) $data2(other,tabbing)]] != 0} {
		dputs "  order $result"
		return $result
	}

	# compute order based on cell coords

	set c1 [get_tabbing_coords .can.f.$name1]
	set c2 [get_tabbing_coords .can.f.$name2]

	foreach index {0 1} {
		set diff [expr [lindex $c1 $index] - [lindex $c2 $index]]
		dputs "  diff ($index) -> $diff"
		if {$diff != 0} {return $diff}
	}
	dputs "   equal??"
	return 0
}


# find the real master of this window, as the user may have changed its name.

proc real_master {name} {
	upvar #0 __X_$name data
	set master [string trimleft $data(other,master) .]
	dputs $master

	if {$name == "f" } return ""
	
	if {$master == ""} {
		return {$root}
	} else {
		# the name of the master may have been changed!
		upvar #0 __X_$master m
		set master $m(other,item_name)
		return \$base.$master
	}
}
