"Fossies" - the Fresh Open Source Software archive

Member "SpecTcl/SpecTcl/compile_jdk11.tk" of archive SpecTcl.tar.gz:

# SpecTcl, by S. A. Uhler and Ken Corey
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
#
# See the file "license.txt" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# experimental version for generating java code

# compile a jui into a java 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)

# Tilo was here: It's a neat idea to request the focus
set Boiler {
public static void main(String[] args) {
    Frame f = new Frame("%1$s Test");
    %1$s win = new %1$s();
    win.init();
    f.add("Center", win);
    f.pack();
    f.show();
    f.requestFocus();
}

private void reset(GridBagConstraints con) {
    con.gridx = GridBagConstraints.RELATIVE;
    con.gridy = GridBagConstraints.RELATIVE;
    con.gridwidth = 1;
    con.gridheight = 1;
 
    con.weightx = 0;
    con.weighty = 0;
    con.anchor = GridBagConstraints.CENTER;
    con.fill = GridBagConstraints.NONE;
 
    con.insets = new Insets(0, 0, 0, 0);
    con.ipadx = 0;
    con.ipady = 0;
}
}

array set Javamap {
    label   Label
    entry   TextField
    text    TextArea
    button  Button
    scrollbar Scrollbar
    frame   Panel
    checkbutton Checkbox
    radiobutton Checkbox
    menubutton  Choice
    listbox List
    canvas Canvas
}
    
# Value is the
array set Javamap {
    label.text      $var.setText("$value");
    entry.text      $var.setText("$value");
    entry.show      $var.setEchoCharacter('$value');
    checkbutton.text $var.setLabel("$value");
    radiobutton.text $var.setLabel("$value");
    radiobutton.variable "$var.setCheckboxGroup($value);"
    button.text     $var.setLabel("$value");
    menubutton.text {[choice_text $var $value]}
    *.font          {$var.setFont([jfont $value]);}
    *.foreground    {$var.setForeground([jcolor $value]);}
    *.background    {$var.setBackground([jcolor $value]);}
    *.editable  {[do_editable $var $value]}
    *.ActionListener {$var.addActionListener($value);}
    *.ItemListener {$var.addItemListener($value);}
    *.AdjustmentListener {$var.addAdjustmentListener($value);}
    *.TextListener {$var.addAdTextListener($value);}
    *.ActionCommand {$var.setActionCommand("$value");}
}
# This used to be a part of Javamap, but what's it supposed
# to do?
#   entry.width     [entry_width]

array set Javaanchormap {
    sticky:nw   NORTHWEST
    sticky:n    NORTH
    sticky:ne   NORTHEAST
    sticky:new  NORTH
    sticky:w    WEST
    sticky:c    CENTER
    sticky:     CENTER
    sticky:e    EAST
    sticky:ew   CENTER
    sticky:sw   SOUTHWEST
    sticky:s    SOUTH
    sticky:es   SOUTHEAST
    sticky:esw  SOUTH
    sticky:nsw  WEST
    sticky:ns   CENTER
    sticky:nes  EAST
    sticky:nesw CENTER
}
array set Javafillmap {
    sticky:nw   NONE
    sticky:n    NONE
    sticky:ne   NONE
    sticky:new  HORIZONTAL
    sticky:w    NONE
    sticky:c    NONE
    sticky:     NONE
    sticky:e    NONE
    sticky:ew   HORIZONTAL
    sticky:sw   NONE
    sticky:s    NONE
    sticky:es   NONE
    sticky:esw  HORIZONTAL
    sticky:nsw  VERTICAL
    sticky:ns   VERTICAL
    sticky:nes  VERTICAL
    sticky:nesw BOTH
}

# set up some java specific preferences

set P(extends) java.applet.Applet

proc compile_jui {file {out ""} {prefix ""} {run ""}} {
    global Widget_data Format Masters Version Javamap Javaanchormap Javafillmap Boiler P
    global CB_Groups
    catch "unset CB_Groups"
    set Id "WidGet file"
    catch "unset Masters"
    array set map {row height column width}
    set widget_names ""

    if {![file readable $file]} {
        set msg "$file does not exist, can't compile it."
        tk_dialog .open "Compile 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
    }

    set out_fd [Jopen_out $out]
    if {$out_fd == ""} {
        return 1
    }

    # Gather up all of the data for each widget.
    # Put it in the arrays __X_$name, generally used
    # under the alias "data"

    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
            # Set default attributes
            set data(geometry,fill) none
            set data(geometry,anchor) c
            set data(geometry,sticky) c
        } else {
            set index -1
            foreach i {type option value} {
                set $i [lindex $line [incr index]]
            }

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

    ########################################################
    # end of pass 1

    # Prefix is the name of the project (and Applet class)
    if {$prefix == ""} {
        set prefix [file root [file tail $file]]
    }

    # Sort names:
    set names [lsort -command "frames_first" $names]

    # Rename all user-level item_names to use _ not #
    foreach name $names {
        upvar #0 __X_$name data
        regsub # $data(other,item_name) _ data(other,item_name)
    }
        

    ############################################################
    # Output the info as Java code:
    #
    # $names is a list of all the internal names of the widgets
    # "f" is the top-level container.
    #
    # $data($type, $option) = $value for each specified
    # attribute of each element of the form, where "data"
    # is upleveled (one array for each widget)
    ############################################################

    # Initial boilerplate and class declaration:
    puts $out_fd "// SpecTcl generated class $prefix, version $P(Version)\n"
    if {[info exists P(package)]} {
        if {![regexp $P(package) {^[    ]*$}]} {
            puts $out_fd "package $P(package);"
        }
    }
    puts $out_fd "import java.awt.*;"
    puts $out_fd "import java.awt.event.*;"
    if {[info exists P(imports)]} {
        foreach import $P(imports) {
            puts $out_fd "import $import;"
        }
    }
    if {[info exists P(implements)]} {
        if {![regexp $P(implements) {^[     ]*$}]} {
            set imp "implements $P(implements) "
        }
    }
    append imp {}

    puts $out_fd ""
    puts $out_fd "public class $prefix extends $P(extends) $imp\{       \n"

    # Tilo was here: I needed some way to make Listener declarations visible to the class
    # read in listener declarations from an external file

    if {[file readable $prefix.listeners.java]} {
        set fd [open "$prefix.listeners.java" r]
        set code [read $fd]
        close $fd
        puts $out_fd "\n// code sourced from $prefix.listeners.java"
        puts $out_fd $code
    }

    # make a "client data" slot
    puts $out_fd "// a slot to hold an arbitrary object pointer that can"
    puts $out_fd "// be filled in by the app. and referenced in actions"

    set arg Object
    if {[info exists P(arg)]} {
        if {![regexp $P(arg) {^[    ]*$}]} {
            set arg $P(arg)
        }
    }
    puts $out_fd "public $arg arg;\n"

    # Declare an instance variable for each widget:
    foreach name $names {
        upvar #0 __X_$name data
        if {$name == "f" } continue

        set var $data(other,item_name)
        set type $data(other,type)

        # allow user's to use subclass of awt widgets
        # look for:
        #   SubClass
        #   SubClass.init_method(args)

        set data(call) ""
        if {$data(other,subclass) != ""} {
            regexp {([^. ]+)(\.(.*))?} $data(other,subclass) x \
                data(actual) x data(call)
        } else {
            set data(actual) $Javamap($type)
        }
        catch {puts $out_fd "public $data(actual) $var;"}
        if {$type == "radiobutton"} {
            set group default_group
            catch {set group $data(configure,variable)}
            if {![info exists CB_Groups($group)]} {
                set CB_Groups($group) 1
                puts $out_fd "public CheckboxGroup $group = new CheckboxGroup();"
                append widget_names \"$group\",
            }
        }
        append widget_names \"$var\",
        set name_map($var) $name
    }

    # make lists of widget pointers and names available to apps

    puts $out_fd "\n//methods to support form introspection"
    puts $out_fd "public static String names\[] = \{\n\t$widget_names\n\};"
    puts $out_fd "public String\[] getNames() \{\n\treturn names;\n\}"

    regsub -all {"} $widget_names {} widget_names
    regsub {,$} $widget_names {} widget_names
    set list [split $widget_names ,]
    puts $out_fd "\n//There should be an easier way to do this"
    puts $out_fd "public Object\[] getWidgets() \{\n\tObject\[] list = new Object\[[llength $list]];"
    set count -1
    foreach i $list {
        puts $out_fd "\tlist\[[incr count]] = $i;"
    }
    puts $out_fd "\treturn list;\n\}"

    # pass through application specific behvior

    if {[info exists P(export)]} {
        puts $out_fd "\n// Application specific widget data"
        foreach export $P(export) {
            puts $out_fd "private static String ${export}_private\[] = \{"
            set value ""
            foreach name $list {
                catch {upvar #0 __X_$name_map($name) data}
                if {![info exists data]} {
                    append value "null, "
                } elseif {[info exists data(other,$export)]} {
                    append value "\"$data(other,$export)\", "
                } else {
                    append value "null, "
                }
            }
            puts $out_fd "\t$value\n\};"
            puts $out_fd "public String\[] ${export}() \{"
            puts $out_fd "\treturn ${export}_private;"
            puts $out_fd "\}\n"
        }
    }
    # Tilo was here: define the AltF4Listener as an inner class
    # Right now listening for the Alt-modifier doesn't work properly on Windoze, so
    # we employ a nasty hack to identify a press of F4 which is "somehow" being modified.
    puts $out_fd "\nclass AltF4Listener implements KeyListener \{"
    puts $out_fd "\tpublic void keyTyped(KeyEvent e) \{\}"
    puts $out_fd "\tpublic void keyPressed(KeyEvent e) \{\}"
    puts $out_fd "\tpublic void keyReleased(KeyEvent e) \{"
#    puts $out_fd "\tSystem.out.println(e.toString());"
    puts $out_fd "\tif(e.getKeyCode() == KeyEvent.VK_F4 && (e.toString()).indexOf(\"modifier\") != -1) System.exit(3);"
    puts $out_fd "\t\}\}\n"

    # More boilerplate
    puts $out_fd "\npublic void init() \{"

    # Now code to create the widgets
    set count -1

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

        if {$name == "f" } {
            puts $out_fd "\n\t// main panel"
            puts $out_fd "  GridBagLayout grid = new GridBagLayout();"
            out_constraints f {} $out_fd

            continue
        }

        # Type is the widget type (not converted to Java)
        set type $data(other,type)
        if {![info exists Javamap($type)]} {
            puts stderr "No mapping for widget $data(other,type)"
            continue
        }

        # Var is the user variable name
        set var $data(other,item_name)

        if {[info exists data(other,min_row)]} {
            puts $out_fd "\n\t// container $var in [Jreal_master $name]"
            puts $out_fd "  GridBagLayout ${var}_grid = new GridBagLayout();"
            out_constraints $name ${var}_ $out_fd
        }

        # Generate special case initialization code.
        puts $out_fd ""
        if {$type == "entry"} {
            set width 20
            catch {set width $data(configure,width)}
            puts $out_fd "\t$var = new TextField($width);"
        } elseif {$type == "scrollbar"} {
            set orient VERTICAL
            catch {
                if {[string match "h*" $data(configure,orient)]} {
                    set orient HORIZONTAL
                }
            }
            puts $out_fd "\t$var = new Scrollbar(Scrollbar.$orient);"
        } elseif {$type == "text"} {
            set rows 5; set cols 20
            catch {set rows $data(configure,height)}
            catch {set cols $data(configure,width)}
            puts $out_fd "\t$var = new TextArea($rows,$cols);"
        } elseif {$type == "listbox"} {
            set rows 4; set multi false
            catch {set rows $data(configure,height)}
            catch {set multi [expr { \
                    $data(configure,selectmode) == "multiple" ? "true" : "false"}]}
            if {$rows == 0} {set rows 4}
            puts $out_fd "\t$var = new List($rows,$multi);"
        } elseif {$type == "menubutton" && $data(other,items) != ""} {
            puts $out_fd "\t$var = new $data(actual)();"
            foreach i [split $data(other,items) ,] {
                puts $out_fd "\t$var.addItem(\"$i\");"
            }
        } else {
            puts $out_fd "\t$var = new $data(actual)();"
        }

        # do any sub-class initialization
        if {$data(call) != ""} {
            puts $out_fd "\t$var.$data(call);   // $data(actual) initialization"
        }

        # Set all specified "configure" options:
        set options [lsort [array names data configure,*]]
        append options  " " [lsort [array names data other,*]]
        set font ""
        foreach option $options {
            regsub configure, $option {} param
            regsub other, $param {} param
            set value $data($option)

# Tilo was here: We only do sth. if the value is non-empty
            if {$value != "" && [info exists Javamap($type.$param)]} {
                set result [subst $Javamap($type.$param)]
                if {$result != {}} {
                    puts $out_fd "\t$result"
                }
            } elseif {$value != "" && [info exists Javamap(*.$param)]} {
                set result [subst $Javamap(*.$param)]
                if {$result != {}} {
                    puts $out_fd "\t$result"
                }
            }
            # puts "+++ ($option) $type.$param ($value) <$m1> <$m2>"
        }

# Tilo was here: We start another desperate attempt to get the program terminated through a
# simple keypress :-(
        puts $out_fd "\t$var.addKeyListener(new AltF4Listener());"

        puts $out_fd "\t[Jreal_master $name]add($var);"

        # puts $out_fd "\twidgets\[[incr count]] = $var;\n"
                if {[info exists P(java_include_comments)] && $P(java_include_comments) != 0} {
                    puts $out_fd "\t$data(other,comments)"
                } 
    }


    # Create the geometry management commands:
    puts $out_fd "\n\t// Geometry management"
    puts $out_fd "  GridBagConstraints con = new GridBagConstraints();"
    foreach name $names {
        upvar #0 __X_$name data
        if {$name == "f" } continue

        set type $data(other,type)
        set var $data(other,item_name)
        puts  $out_fd "\treset(con);"
        puts  $out_fd "\tcon.gridx = $data(geometry,column);"
        puts  $out_fd "\tcon.gridy = $data(geometry,row);"
        catch {puts  $out_fd "\tcon.ipadx = $data(geometry,ipadx);"}
        catch {puts  $out_fd "\tcon.ipady = $data(geometry,ipady);"}
        catch {puts $out_fd "\tcon.gridwidth = $data(geometry,columnspan);"}
        catch {puts $out_fd "\tcon.gridheight = $data(geometry,rowspan);"}
        
        set t 0; set l 0
        catch {set t $data(geometry,pady)}
        catch {set l $data(geometry,padx)}
        if {$t || $l} {
            puts $out_fd "\tcon.insets = new Insets($t, $l, $t, $l);"
        }
        puts  $out_fd "\tcon.anchor = GridBagConstraints.$Javaanchormap(sticky:$data(geometry,sticky));"
        puts  $out_fd "\tcon.fill = GridBagConstraints.$Javafillmap(sticky:$data(geometry,sticky));"

        # FIX THIS
        puts  $out_fd "\t[Jreal_master2 $name]grid.setConstraints($var, con);"
        puts  $out_fd ""
    }

    # Now for the resize behavior.  This is only run for geometry masters.
    puts $out_fd "\n\t// Resize behavior management and parent heirarchy"
    foreach name [array names Masters] {
        upvar #0 __X_$name data

        if {$name == "f" } {set uname ""; set vname ""} else {
            set uname $data(other,item_name).
            set vname $data(other,item_name)_
        }
        puts $out_fd "  ${uname}setLayout(${vname}grid);"
    }

    puts $out_fd "\n\t// Give the application a chance to do its initialization"
        set init ""
    catch {set init $P(init)}
    puts $out_fd "\t$init\n\}\n"

    # Tilo was here: handleEvent is gone... Are we gonna miss it?!?
    # write the handle event procedure

    # read in other methods from an external file

    if {[file readable $prefix.include.java]} {
        set fd [open "$prefix.include.java" r]
        set code [read $fd]
        close $fd
        puts $out_fd "\n// code sourced from $prefix.include.java"
        puts $out_fd $code
    }

    # Put out final boilerplate to end the "init" function
    # and the class:

    puts $out_fd [format $Boiler $prefix]
    puts $out_fd \}

    # Close any opened file.
    if {$out_fd != "stdout"} {
        close $out_fd
    }


    ############################################################
    # Write <project_name>Data.java
    ############################################################

    # Cleanup global data!!
    foreach i [info globals __X_*] {
        global $i
        unset $i
    }
}


############################################################################
# Utility functions
############################################################################

# Convert SpecTcl to Java fonts

proc jfont {value} {
    set font [split $value ,]
    set family [lindex $font) 0]
    set size [lindex $font 1]
    set style "Font.PLAIN "
    foreach i [lrange $font 2 end] {
        append style "+ Font.[string toupper $i] "
    }
    return "new Font(\"$family\",$style, $size)"
}

# convert colors

proc jcolor {value} {
    regsub -all " " "[winfo rgb . $value] " "/256 " new
    return "new Color([join $new ,])"
}

# figure out the resize behavior

proc get_resize {list} {
    set index 0
    set result ""
    foreach i $list {
        if {[lindex "x $list" [incr index]] > 1} {
            lappend result $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"} {
        dputs "  frames: $data2(other,level) - $data1(other,level)"
        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
    }

    # 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 [list $data1(geometry,row) $data1(geometry,column)]
    set c2 [list $data2(geometry,row) $data2(geometry,column)]

    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 Jreal_master {name} {
    upvar #0 __X_$name data
    
    if {$name == "f" } {return "this."}
    
    set master [string trimleft $data(other,master) .]
    if {$master == ""} {return "this."}
    if {$master == "f"} {return "this."}
    
    # the name of the master may have been changed!
    upvar #0 __X_$master m
    return $m(other,item_name).
}

proc Jreal_master2 {name} {
    upvar #0 __X_$name data
    
    if {$name == "f" } {return ""}
    
    set master [string trimleft $data(other,master) .]
    if {$master == ""} {return ""}
    if {$master == "f"} {return ""}
    
    # the name of the master may have been changed!
    upvar #0 __X_$master m
    return $m(other,item_name)_
}

proc Jopen_out {out} {
    if {$out == ""} {
        return stdout
    } elseif {[catch {open "$out" w} out_fd]} {
        tk_dialog .save "save error" $out_fd error 0 OK
        return ""
    } else {
        return $out_fd
    }
}   

proc out_constraints {frame prefix fd} {
        upvar #0 __X_$frame data

        puts -nonewline $fd "\tint ${prefix}rowHeights\[] = \{"
        puts $fd "0,[join $data(other,min_row) ,]\};"

        puts -nonewline $fd "\tint ${prefix}columnWidths\[] = \{"
        puts $fd "0,[join $data(other,min_column) ,]\};"

        foreach i {row column} {
            set weight $data(other,resize_$i)
            regsub -all {[01]} $weight 0.0 weight
            regsub -all {[23]} $weight 1.0 weight
            puts -nonewline $fd "\tdouble ${prefix}${i}Weights\[] = \{"
            puts $fd "0.0,[join $weight ,]\};"
        }

        puts $fd "\t${prefix}grid.rowHeights = ${prefix}rowHeights;"
        puts $fd "\t${prefix}grid.columnWidths = ${prefix}columnWidths;"
        puts $fd "\t${prefix}grid.rowWeights = ${prefix}rowWeights;"
        puts $fd "\t${prefix}grid.columnWeights = ${prefix}columnWeights;"
}

proc choice_text {var value} {
    if {$value == ""} {
        return {}
    } else {
        return $var.addItem("$value")\;
    }
}

proc do_editable {var value} {
    switch -- $value {
    0     -
    false -
    no {
        return $var.setEditable(false)\;
    }
    default {
        return {}
    }
    }
}