##############################################################################
# $Id: tclet.tcl,v 1.7 2006/01/19 07:37:44 kenparkerjr Exp $
#
# tclet.tcl - procedures for creating tclets from compounds
#
# Copyright (C) 1996-1998 Stewart Allen
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

##############################################################################
# 20051213 Nelson - rough modifications on this file to get tclets operational again.
# These modifications seem to mostly work but it appears that you should NOT enable or 
# code around "Use widget command aliasing" and "Use auto-aliasing for new widgets" features.
# I have left remarks in various places as I sort through the tclet operation.

proc vTcl:create_tclet {target} {
    global vTcl
    if {$target == "" ||
        [vTcl:get_class $target] != "Toplevel"} {
        vTcl:error "You must select a Toplevel\nWindow as the Tclet base"
        return
    }
    set vTcl(cmp,alias) ""
    set vTcl(cmp,index) 0
    set cmpd [vTcl:gen_compound $target]
    set cmd [vTcl:tclet_from_cmpd "" "" $cmpd]
    set file [vTcl:get_file save "Export Tclet"]
    if {$file != ""} {
        if [catch {set out [open $file w]}] {
            vTcl:error "Error saving to file: $error"
            return
        }
        set body [string trim [info body init]]              ;vTcl:statbar 20

        ## Let's give some clue about who might well have generated
        ## this tclet
        set header "#############################################################################
# Visual Tcl v$vTcl(version) Tclet
#
"
        puts $out $header

        ## Gather information about fonts and images.
        vTcl:dump:gather_widget_info

        ## Save only fonts and images we need
        ## All images are saved inline in a tclet
        set old $vTcl(pr,saveimagesinline)
        set vTcl(pr,saveimagesinline) 1

        vTcl:image:generate_image_stock $out
        vTcl:image:generate_image_user  $out
        vTcl:font:generate_font_stock   $out
        vTcl:font:generate_font_user    $out

        set vTcl(pr,saveimagesinline) $old

        puts $out $vTcl(head,procs)                          ;vTcl:statbar 25
        puts $out "proc init \{argc argv\} \{\n$body\n\}\n"  ;vTcl:statbar 30
        puts $out "init \$argc \$argv\n"                     ;vTcl:statbar 35
        puts $out [vTcl:save_procs]                          ;vTcl:statbar 55
        puts $out $vTcl(head,gui)                            ;vTcl:statbar 65
        puts $out $cmd                                       ;vTcl:statbar 75
        puts $out "main \$argc \$argv"                       ;vTcl:statbar 95
        close $out                                           ;vTcl:statbar 0
    }
}

proc vTcl:tclet:translate_options {opts} {
    global vTcl

    set ret {}
    set index 0
    foreach i $opts {
        if {$index % 2 == 0} then {
            set opt $i
            incr index
            continue
        }
        # this option is unknown to the tcl plugin
        if {$opt == "-activebackground" ||
            $opt == "-activeforeground"} then {
            incr index
            continue
        }
        set val $i
        if {[vTcl:streq $opt "-class"]} then {
            incr index
            continue
        }
        if {[info exists vTcl(option,translate,$opt)]} then {
            set val [$vTcl(option,translate,$opt) $val]
        }

        lappend ret $opt $val
        incr index
    }
    return $ret
}

proc vTcl:tclet_from_cmpd {base name compound {level 0}} {
    global vTcl widget classes
    set todo ""
    foreach i $compound {
        set class [string trim [lindex $i 0]]
        set opts [string trim [lindex $i 1]]
        set mgr  [string trim [lindex $i 2]]
        set mgrt [string trim [lindex $mgr 0]]
        set mgri [string trim [lindex $mgr 1]]
        set bind [string trim [lindex $i 3]]
        set menu [string trim [lindex $i 4]]
        set chld [string trim [lindex $i 5]]
        set wdgt [string trim [lindex $i 6]]
        set alis [string trim [lindex $i 7]]
        set grid [string trim [lindex $i 8]]
        set proc [string trim [lindex $i 9]]
        if {$mgrt == "wm" || $base == "."} {
            set base $name
        } elseif {$level == 0} {
            set mgrt pack
            set mgri "-side top -expand 1 -fill both"
        }
        if {$level > 0} {
            set name "$base$wdgt"
        }
        #puts $opts
        if {$class != "Toplevel"} {
            set opts [vTcl:tclet:translate_options $opts]
            append todo "$classes($class,createCmd) $name \\\n"
            append todo "[vTcl:clean_pairs [vTcl:name_replace $base $opts] 4]\n"
        }
        if {$mgrt != "" && $mgrt != "wm" && $name != " "} {
            if {$mgrt == "place" && $mgri == ""} {
                set mgri "-x 5 -y 5"
            }
            set mgri [vTcl:name_replace_list $base $mgri]
            set mgrii ""
            for {set ii 0} {$ii < [llength $mgri]} {incr ii 2} {
                set item  [lindex $mgri $ii]
                set value [lindex $mgri [expr $ii+1]]
                if {$item == "-in" && [string trim $value] == ""} {
                    continue
                }
                lappend mgrii $item $value
            }
            append todo "$mgrt $name \\\n[vTcl:clean_pairs $mgrii 4]\n"
        }
        set index 0
        incr level
        foreach j $bind {
            set e [lindex $j 0]
            set c [vTcl:name_replace $base [lindex $j 1]]
            append todo "bind $name $e \"$c\"\n"
        }
        foreach j $menu {
            set t [lindex $j 0]
            set o [lindex $j 1]
            if {$t != "tearoff"} {
                append todo "$name add $t $o\n"
            }
        }
        foreach j $chld {
            append todo "[vTcl:tclet_from_cmpd $base $name \{$j\} $level]\n"
            incr index
        }
        if {$alis != ""} {
            set widget($alis) $name
            set widget(rev,$name) "$alis"
        }
        foreach j $grid {
            set cmd [lindex $j 0]
            set num [lindex $j 1]
            set prop [lindex $j 2]
            set val [lindex $j 3]
            if {$name == ""} {
                append todo "grid $cmd . $num $prop $val\n"
            } else {
                append todo "grid $cmd $name $num $prop $val\n"
            }
        }
        foreach j $proc {
            set nme [lindex $j 0]
            set arg [lindex $j 1]
            set bdy [lindex $j 2]
            append todo "proc $nme \{$arg\} \{\n$bdy\n\}\n"
        }
    }
    return $todo
}

###############################################################
# 20051213 Nelson - This is the magic proc that I am working on
# to bring tclet operations back to life. This proc is starting 
# from the change that remove the proc from the compound.tcl file
# and is documented on the diff below:
# http://cvs.sourceforge.net/viewcvs.py/vtcl/vtcl/lib/compound.tcl?r1=1.31&r2=1.32
# So I am now moving the proc back in with some modifications to 
# the tclet.tcl file.

proc vTcl:gen_compound {target {name ""} {cmpdname ""}} {
    global vTcl widget classes
    set ret ""
    set mgr ""
    set bind ""
    set menu ""
    set chld ""
    set alias ""
    set grid ""
    set proc ""
    if {![winfo exists $target]} {
        return ""
    }
    set class [vTcl:get_class $target]

    # rename conf to configure because Iwidgets don't like conf only
    set opts [vTcl:get_opts [$target configure]]

    if {$class == "Menu"} {
        set mnum [$target index end]
        if {$mnum != "none"} {
            for {set i 0} {$i <= $mnum} {incr i} {
                set t [$target type $i]
                set c [vTcl:get_opts [$target entryconf $i]]
                lappend menu "$t \{$c\}"
            }
        }
        set mgrt {}
        set mgri {}
    } elseif {$class == "Toplevel"} {
        set mgrt "wm"
        set mgri ""
    } else {
        set mgrt [winfo manager $target]

        ## in Iwidgets, some controls are not yet packed/gridded/placed when
        ## they are in edit mode, therefore there is no manager at this time
        ##
        ## in BWidgets, pages in a notebook either don't have a manager or have
        ## the 'canvas' manager

	if {[lempty $mgrt] || [lempty [info commands $mgrt]] || $mgrt == "canvas"} {
	    set mgri {}
        } else {
	    set mgri [vTcl:get_mgropts [$mgrt info $target]]
	}
    }
    lappend mgr $mgrt $mgri
    set blst [bind $target]
    foreach i $blst {
        lappend bind "$i \{[bind $target $i]\}"
    }

    # now, are bindtags non-standard ?
    set bindtags $vTcl(bindtags,$target)
    # 20051213 Nelson - Do normal stuff and then also make sure to exclude the toplevel binding things.
    if {$bindtags != [::widgets_bindings::get_standard_bindtags $target] && [vTcl:get_class $target] != "Toplevel" } {
        # append the list of binding tags
	puts "Bind here is - $bind"
        lappend bind [list [vTcl:normalize_bindtags $target $bindtags]]
	puts "Now bind here is - $bind"

        # keep all bindings definitions with the compound
        # (even if children define them too)
	# puts "Putting bindtag - $bindtags"
        foreach bindtag $bindtags {
            if {[lsearch -exact $::widgets_bindings::tagslist $bindtag] >= 0} {
                foreach event [bind $bindtag] {
                    lappend bind "$bindtag $event \{[bind $bindtag $event]\}"
                }
            }
        }
    }

    foreach i [vTcl:get_children $target] {

      if {[string match {*#*} $i]} {continue}

      # retain children names while creating a compound
      set windowpath [split $i .]
      set lastpath [lindex $windowpath end]

	append chld "[vTcl:gen_compound $i $name.$lastpath] "
    }

    catch {set alias $widget(rev,$target)}
    set pre g
    set gcolumn [lindex [grid size $target] 0]
    set grow [lindex [grid size $target] 1]
    foreach a {column row} {
        foreach b {weight minsize} {
            set num [subst $$pre$a]
            for {set i 0} {$i < $num} {incr i} {
                if {[catch {
                    set x [expr {round([grid ${a}conf $target $i -$b])}]
                }]} {set x 0}
                if {$x > 0} {
                    lappend grid "${a}conf $i -$b $x"
                }
            }
        }
    }
    if {$cmpdname != ""} {
        foreach i $vTcl(procs) {
            if {[string match ::${cmpdname}::* $i]} {
                lappend proc [list $i [vTcl:proc:get_args $i] [info body $i]]
            }
        }
    }

    ## special case for megawidgets: code to recreate all the childsites
    if {$classes($class,compoundCmd) != ""} {
        set compoundCode [$classes($class,compoundCmd) $target]
        lappend proc [list __insert$target target $compoundCode]
    }

# 20051213 Nelson taken out
#    set topopt ""
#    if {$class == "Toplevel"} {
#        foreach i $vTcl(attr,tops) {
#            set v [wm $i $target]
#            if {$v != ""} {
#                lappend topopt [list $i $v]
#            }
#        }
#    }
    puts "Class - $class"
    puts "OPTS - $opts"
    puts "MGR - $mgr"
    puts "Bind - $bind"
    puts "Menu - $menu"
    puts "Chld - $chld"
    puts "Name - $name"
    puts "Alias - $alias"
    puts "Grid - $grid"
    puts "Proc - $proc"
    puts "CmpdName - $cmpdname"
#    puts "Topopt - $topopt"
    
#    lappend ret $class $opts $mgr $bind $menu $chld $name $alias $grid $proc $cmpdname $topopt
    lappend ret $class $opts $mgr $bind $menu $chld $name $alias $grid $proc $cmpdname
    vTcl:append_alias $target $name
    return \{$ret\}
}
