# use_wtree.tcl
# 
# Copyright (c) 1994 R"udiger Franke
# All Rights Reserved.
# 
# Redistribution and use in any form, with or without modification, 
# is permitted, provided that the following conditions are met:
# 1. Redistributions of source code must retain the above copyright
#    notice, this list of conditions and the following disclaimer.
# 2. Redistributions in other form must reproduce the above copyright
#    notice, this list of conditions and the following disclaimer in the
#    documentation and/or other materials provided with the distribution.
# 3. All advertising materials mentioning features or use of this software
#    must display the following acknowledgement:
#       This product includes software developed by R"udiger Franke.
# 4. The name of the author may not be used to endorse or promote products
#    derived from this software without specific prior written permission.
# 
# THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
# OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
# IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
# INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
# NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
# THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

#
# constructor for "use_wtree"
#
proc use_wtree {w  args} {
  upvar #0 $w this

  # user initializations

  global use
  
  if {![info exists use(entities)]} {
    set use(entities) [winfo name .]
  }
  
  # find a unique component name
  set i 0
  while {[send $use(entities) "info commands component$i"] != {}} {
    incr i
  }
  set this(compname) component$i
  set this(wcmds) {}
  # data initializations

  set this(use_wtree) $w
  set this(menubar) $w.menubar
  set this(menubutton0) $w.menubar.menubutton0
  set this(medit) $w.menubar.menubutton0.medit
  set this(menubutton1) $w.menubar.menubutton1
  set this(mselect) $w.menubar.menubutton1.mselect
  set this(menubutton2) $w.menubar.menubutton2
  set this(mcomponent) $w.menubar.menubutton2.mcomponent
  set this(menubutton3) $w.menubar.menubutton3
  set this(mentity) $w.menubar.menubutton3.mentity
  set this(tree) $w.tree
  set this(vscroll) $w.vscroll
  set this(hscroll) $w.hscroll
  set this(noderename) $w.noderename
  
  # widget creations

  frame $this(use_wtree) -class Use_wtree
  frame $this(menubar)  \
    -borderwidth 2 \
    -relief raised
  menubutton $this(menubutton0)  \
    -menu "$this(medit)" \
    -text "Edit" \
    -underline "0"
  menu $this(medit) 
  $this(medit) add command\
    -label {Layout...}\
    -underline {0}\
    -command "
       set shell \[use_unique .shell\]
       use_ontop \$shell use_tools tools {Component Editor} Layout
       \$shell.tools compname \[set $w\(compname)\]
     "
  $this(medit) add command\
    -label {Widgets...}\
    -underline {0}\
    -command "
       set shell \[use_unique .shell\]
       use_ontop \$shell use_tools tools {Component Editor} Widgets
       \$shell.tools compname \[set $w\(compname)\]
     "
  $this(medit) add separator
  $this(medit) add command\
    -label {Constructor...}\
    -underline {0}\
    -command "
       set shell \[use_unique .shell\]
       use_ontop \$shell use_tools tools {Component Editor} Constructor
       \$shell.tools compname \[set $w\(compname)\]
     "
  $this(medit) add command\
    -label {Methods...}\
    -underline {0}\
    -command "
       set shell \[use_unique .shell\]
       use_ontop \$shell use_tools tools {Component Editor} Methods
       \$shell.tools compname \[set $w\(compname)\]
     "
  menubutton $this(menubutton1)  \
    -menu $this(mselect) \
    -text Selected \
    -underline 0
  menu $this(mselect) 
  $this(mselect) add command\
    -label {Delete}\
    -underline {0}\
    -command "use_wtree::nodedelete $w"
  $this(mselect) add separator
  $this(mselect) add command\
    -label {Cut}\
    -underline {2}\
    -command "use_wtree::copy $w ; use_wtree::nodedelete $w"
  $this(mselect) add command\
    -label {Copy}\
    -underline {0}\
    -command "use_wtree::copy $w"
  $this(mselect) add command\
    -label {Paste}\
    -underline {0}\
    -command "use_wtree::paste $w \$use(cutbuf)"
  $this(mselect) add separator
  $this(mselect) add command\
    -label {Move Back}\
    -underline {5}\
    -command "use_wtree::nodeback $w"
  $this(mselect) add command\
    -label {Move Fore}\
    -underline {5}\
    -command "use_wtree::nodefore $w"
  
  
  menubutton $this(menubutton2)  \
    -menu $this(mcomponent) \
    -text Component \
    -underline 0
  menu $this(mcomponent) 
  $this(mcomponent) add command \
    -label {New} \
    -underline {0} \
    -command \
      "$w reset"
  $this(mcomponent) add command \
    -label {Add Node...} \
    -underline {0} \
    -command "
       set shell \[use_unique .add_shell\]
       use_ontop \$shell use_nodeadd nodeadd {Add Node}
       \$shell.nodeadd compname \[$w compname\]
     "
  $this(mcomponent) add command \
    -label {Load...} \
    -underline {0} \
    -command \
      "fselect $w.fselect \"use_wtree::load $w\" *.usc"
  $this(mcomponent) add separator
  $this(mcomponent) add command \
    -label {Save} \
    -underline {0} \
    -command \
      "use_wtree::save $w"
  $this(mcomponent) add command \
    -label {Generate Code} \
    -underline {0} \
    -command \
      "use_wtree::savecode $w"
  $this(mcomponent) add command \
    -label {Code&Send} \
    -underline {0} \
    -command "
       $w savecode
       $w send
     "
  $this(mcomponent) add command \
    -label {Save&Code&Send} \
    -underline {1} \
    -command "
       $w save
       $w savecode
       $w send
     "
  $this(mcomponent) add separator
  $this(mcomponent) add command \
    -label {Quit} \
    -underline {0} \
    -command \
      "destroy $w"
  menubutton $this(menubutton3)  \
    -menu $this(mentity) \
    -text Entity \
    -underline 2
  menu $this(mentity) 
  $this(mentity) add command \
    -label {Recreate} \
    -underline {2} \
    -command \
      "$w _resetConstructor; $w entrecreate"
  $this(mentity) add command \
    -label {Raise} \
    -underline {0} \
    -command \
      "$w entraise"
  
  use_tree $this(tree)  \
    -scrollregion "0 0 0 0" \
    -borderwidth 2 \
    -relief flat \
    -xscrollcommand "$this(hscroll) set" \
    -yscrollcommand "$this(vscroll) set"
  scrollbar $this(vscroll)  \
    -relief sunken \
    -command "$this(tree) yview"
  scrollbar $this(hscroll)  \
    -command "$this(tree) xview" \
    -orient "horizontal" \
    -relief "sunken"
  use_rename $this(noderename) left \
    -borderwidth "2" \
    -relief "groove"
  
  # widget layouting

  pack \
    $this(menubutton2) \
    $this(menubutton0) \
    $this(menubutton3) \
    $this(menubutton1) \
    -side left
  blt_table $w \
    $this(menubar) 0,0 -columnspan 2 -fill x \
    $this(tree) 1,0 -fill both \
    $this(vscroll) 1,1 -fill y \
    $this(hscroll) 2,0 -fill x \
    $this(noderename) 3,0 -fill both
  blt_table column $w configure 1 -resize none
  blt_table row $w configure 0 -resize none
  blt_table row $w configure 2 -resize none
  blt_table row $w configure 3 -resize none
  
  useCreateComponent use_wtree $w $args

  # user additions

  ## create tree
  
  set this(selected) {}
  
  bind $this(tree) <Button-1> \
    "use_wtree::nodedeselect $w"
  
  blt_drag&drop target $this(tree) handler wcommand \
    "use_wtree::nodeadd $w {} \$DragDrop(wcommand)"
  
  blt_drag&drop target $this(tree) handler use_component \
    "use_wtree::nodeadd $w {} \$DragDrop(use_component)"
  
  ## create entity window
  
  regsub -all {\.} $w _ basename
  set this(entshell) .[string trimleft $basename _]
  set this(entity) $this(entshell).$this(compname)
     
  ## initialize member "noderename"
  
  $this(noderename) command "$w noderename"
  
  blt_drag&drop target $this(noderename) handler use_widget \
    "eval \[concat $this(noderename) show \[lindex \$DragDrop(use_widget) 1\]\]"
  
  ## initialize component
  
  set this(constructErrorCode) 0
  set this(mode) interactive
  
  $w reset
  

  return $w
}

#
# method "_codecreate"
#
proc use_wtree::_codecreate {w node relpath} {
  upvar #0 $w this

  # procedure for code creation from current tree
  #  - appends code to: this(code,wpaths)
  #                     this(code,wcreates)
  #                     this(code,wlayouts)
  #  - works recursive
  
  # create node widget
  
  lappend this(code,wpaths) \
    "set this($node) $relpath" "\n"
  
  set wdgcmd "$this(cmd,$node) \$this($node) $this(cmdargs,$node)"
  if {$this(code,cnf,$node) == {}} {
    lappend this(code,wcreates) "$wdgcmd" "\n"
  } else {
    lappend this(code,wcreates) "$wdgcmd \\\n  " \
      [join $this(code,cnf,$node) " \\\n  "] "\n"
  }
  if {$this(code,spc,$node) != {}} {
    lappend this(code,wcreates) $this(code,spc,$node) "\n"
  }
  
  # create all children
  
  foreach child [$this(tree) children $node] {
    use_wtree::_codecreate $w $child $relpath.$child
  }
  
  # perform layouting with node as master
  
  if { $this(code,geom,$node) != {}} {
    lappend this(code,wlayouts) $this(code,geom,$node) "\n"
  }
  
}

#
# method "_constructError"
#
proc use_wtree::_constructError {w action reason} {
  upvar #0 $w this

  set this(constructErrorCode) 1
  
  dialog $w.d USE \
    "Failed $action for \"$this(compname)\".\n($reason)" error 0 OK
  
}

#
# method "_constructErrorPrepare"
#
proc use_wtree::_constructErrorPrepare {w code action} {
  upvar #0 $w this

  return \
   "if \{ \[catch \{$code\} reason\] != 0 \} \{
      send [winfo name .] \[list $w _constructError [list $action] \$reason\]
      return
    \}"
  
}

#
# method "_createConstructor"
#
proc use_wtree::_createConstructor {w args} {
  upvar #0 $w this

  #   - call _updateCode
  #   - initialize a constructor procedure
  #   - call it
  
  global use
  
  # create code from widget tree
  
  use_wtree::_updateCode $w
  
  if {[llength $this(code,wcreates)] > 0} {
    set createcomp "useCreateComponent $this(compname) \$w \$args\n  "
  } else {
    set createcomp ""
  }
  
  # install new constructor
  
  send $use(entities) "
    proc $this(compname) \{w $this(arglist) args\} \{
      upvar #0 \$w this
      [$w _constructErrorPrepare \
        $this(code,init) {user initialization}]
      [$w _constructErrorPrepare \
        [join $this(code,wpaths) ""] {data initialization}]
      [$w _constructErrorPrepare \
        [join $this(code,wcreates) ""] {widget creation}]
      [$w _constructErrorPrepare \
        [join $this(code,wlayouts) ""] layouting]
      [$w _constructErrorPrepare \
        $createcomp {use-component creation}]
      [$w _constructErrorPrepare \
        $this(code,add) {user additions}]
      return \$w
    \}
  "
  # execute new constructor
  send $use(entities) "
    [concat $this(compname) $args]
  "
  
}

#
# method "_destroyed"
#
proc use_wtree::_destroyed {w } {
  upvar #0 $w this

  global use
    
  # destroy entity shell
  # destroy components command as it refers to this
  # catch that for when the entities interpreter has been destroyed already
  
  catch "send $use(entities) \{
    catch \{destroy $this(entshell)\}
    rename $this(compname) {}
  \}"
}

#
# method "_entshellcreate"
#
proc use_wtree::_entshellcreate {w } {
  upvar #0 $w this

  global use
  
  send $use(entities) "
    toplevel $this(entshell) -width 200 -height 200
    wm title $this(entshell) {Entity Shell}
    wm minsize $this(entshell) 10 10
  #  wm protocol $this(entshell) WM_DELETE_WINDOW \
  #    \{send [winfo name .] \
  #      \{topmessage $w.d USE {Don't delete entity shell.}\}\}
  "
  
}

#
# method "_nodedeleteData"
#
proc use_wtree::_nodedeleteData {w wname} {
  upvar #0 $w this

  # is called for when a node is deleted
  
  global use
  
  set index [lsearch $this(wcmds) $this(cmd,$wname)]
  set this(wcmds) [lreplace $this(wcmds) $index $index]
  
  if {[lsearch [winfo interps] $use(entities)] >= 0} {
    send $use(entities) "catch \{unset $this(entity)\($wname\)\}"
  }
  
  set id $this(id,$wname)
  unset this(cmd,$wname)
  unset this(cmdargs,$wname)
  unset this(code,cnf,$wname)
  unset this(code,spc,$wname)
  unset this(geomcmd,$wname)
  unset this(code,geom,$wname)
  unset this(id,$wname)
  unset this(wname,$id)
  
}

#
# method "_noderename"
#
proc use_wtree::_noderename {w oldname newname} {
  upvar #0 $w this

  #  - update tree
  #  - remain entity widget with its old name
  #    (it will get a new one with next recreation)
  
  # check new name for validy
  # (is important as it is used later)
  
  if {[llength [$this(tree) find withtag $oldname]] == 0} {
    error "unknown node \"$oldname\" for renaming"
  }
  
  if {[$this(tree) parent $oldname] == {}
      && $newname != $this(compname)} {
    error "root node has components name"
  }
  
  set testpath $w.vscroll.$newname
  if {$newname == "" || [catch {frame $testpath}]} {
    error "bad new name \"$newname\""
  }
  destroy $testpath
  
  if {[llength [$this(tree) find withtag $newname]] > 0} {
    error "\"$newname\" already exists in component"
  }
  
  global use
  
  # store data with new node name
  
  set id $this(id,$oldname)
  
  set this(cmd,$newname) $this(cmd,$oldname)
  set this(cmdargs,$newname) $this(cmdargs,$oldname)
  set this(code,cnf,$newname) $this(code,cnf,$oldname)
  set this(code,spc,$newname) $this(code,spc,$oldname)
  set this(geomcmd,$newname) $this(geomcmd,$oldname)
  set this(code,geom,$newname) $this(code,geom,$oldname)
  set this(id,$newname) $this(id,$oldname)
  set this(wname,$id) $newname
  
  if {$this(selected) == $oldname} {
    set this(selected) $newname
  }
  
  set wpath [
    send $use(entities) "
      set $this(entity)\($newname\) \[set $this(entity)\($oldname\)\]
    "
  ]
  
  # update tree layout
  
  $this(tree) noderename $oldname $newname
  $w _treeNodeConfigure $newname
  
  # delete data for old name
  # reset current constructor
  
  send $use(entities) "unset $this(entity)\($oldname\)"
  
  unset this(cmd,$oldname)
  unset this(cmdargs,$oldname)
  unset this(code,cnf,$oldname)
  unset this(code,spc,$oldname)
  unset this(geomcmd,$oldname)
  unset this(code,geom,$oldname)
  unset this(id,$oldname)
  
  $w _resetConstructor
  
}

#
# method "_readFile"
#
proc use_wtree::_readFile {w fd} {
  upvar #0 $w this

  # load a *.usc file
  # problem:
  #  - keep track of "\\\n" inside edited code
  #    --> don't use "eval" or "source"
  
  set code [read $fd]
  foreach cmd $code {
    set method [lindex $cmd 0]
    case $method in {
      {#*} {}
      nodeadd \
        {$w $method [lindex $cmd 1] [lindex $cmd 2] [lindex $cmd 3] \
          [lindex $cmd 4]}
      nodespecial \
        {$w $method [lindex $cmd 1] [lindex $cmd 2]}
      nodeconfigure \
        {$w $method [lindex $cmd 1] [lindex $cmd 2]}
      nodelayout \
        {$w $method [lindex $cmd 1] [lindex $cmd 2] [lindex $cmd 3]}
      compmethod \
        {$w $method [lindex $cmd 1] [lindex $cmd 2] [lindex $cmd 3]}
      compconstructor \
        {$w $method [lindex $cmd 1] [lindex $cmd 2] [lindex $cmd 3] \
          [lindex $cmd 4]}
      default \
        {error "can't interpret \"$method\""}
    }
  }
  
}

#
# method "_resetConstructor"
#
proc use_wtree::_resetConstructor {w } {
  upvar #0 $w this

  # reset constructor for when it gets out of date
  # (let it force it's own creation for when it is called)
  
  global use
  
  send $use(entities) "
    proc $this(compname) {args} \{
      send [winfo name .] use_wtree::_createConstructor $w \$args
    \}
  "
  
}

#
# method "_saveConfigs"
#
proc use_wtree::_saveConfigs {w fd node} {
  upvar #0 $w this

  if {$this(code,cnf,$node) != {}} {
    puts $fd "\{nodeconfigure $node \{$this(code,cnf,$node)\}\}"
  }
  
  foreach child [$this(tree) children $node] {
    use_wtree::_saveConfigs $w $fd $child
  }
  
}

#
# method "_saveCreates"
#
proc use_wtree::_saveCreates {w fd parent node} {
  upvar #0 $w this

  puts $fd "\{nodeadd \{$parent\} \{$this(cmd,$node)\} \{$node\} \{$this(cmdargs,$node)\}\}"
  
  if {$this(code,spc,$node) != {}} {
    puts $fd "\{nodespecial \{$node\} \{$this(code,spc,$node)\}\}"
  }
  
  foreach child [$this(tree) children $node] {
    use_wtree::_saveCreates $w $fd $node $child
  }
  
}

#
# method "_saveLayouts"
#
proc use_wtree::_saveLayouts {w fd node} {
  upvar #0 $w this

  foreach child [$this(tree) children $node] {
    use_wtree::_saveLayouts $w $fd $child
  }
  
  if {$this(code,geom,$node) != {}} {
    puts $fd \
      "\{nodelayout $node $this(geomcmd,$node) \{$this(code,geom,$node)\}\}"
  }
  
}

#
# method "_treeNodeConfigure"
#
proc use_wtree::_treeNodeConfigure {w wname} {
  upvar #0 $w this

  global use
  
  set id $this(id,$wname)
  set wclass [send $use(entities) "winfo class [$w entpath $wname]"]
  
  $this(tree).node$id configure \
    -text $wname\n($wclass) \
    -aspect 10000 \
    -bd 1 -relief raised \
    -justify center
  
  $this(tree) redraw
  
}

#
# method "_updateCode"
#
proc use_wtree::_updateCode {w } {
  upvar #0 $w this

  #  - create components code with _codecreate if needed
  #  (current constructor could be checked for reset-state first)
  
  set this(code,wpaths) {}
  set this(code,wcreates) {}
  set this(code,wlayouts) {}
  if { [$this(tree) find withtag $this(compname)] != {} } {
    $w _codecreate $this(compname) \$w
  }
  
}

#
# method "close"
#
proc use_wtree::close {w } {
  upvar #0 $w this

  global use
  
  wm withdraw [winfo toplevel $w]
  
  set rootpath $this(entshell).$this(compname)
  send $use(entities) "
    if \[winfo exists $rootpath\] \{
      wm withdraw \[winfo toplevel $rootpath\]
    \} else \{
      wm withdraw $this(entshell)
    \}
  "
  
}

#
# method "compconstructor"
#
proc use_wtree::compconstructor {w args} {
  upvar #0 $w this

  # procedure for updating component constructor
  
  if {[llength $args] == 0} {
    return [list \
      $this(code,init) \
      $this(code,add) \
      $this(arglist) \
      $this(testargs)]
  }
  
  global use
  
  # store current constructor's code segments
  
  set oldinitcode $this(code,init)
  set oldaddcode $this(code,add)
  set oldarglist $this(arglist)
  set oldtestargs $this(testargs)
  
  # apply new constructor
  
  set this(code,init) [lindex $args 0]
  set this(code,add) [lindex $args 1]
  set this(arglist) [lindex $args 2]
  set this(testargs) [lindex $args 3]
  
  # apply new constructor
  # revert current component in error cases
  
  $w _resetConstructor
  $w entrecreate
  if {$this(constructErrorCode) != 0} {
    set this(code,init) $oldinitcode
    set this(code,add) $oldaddcode
    set this(arglist) $oldarglist
    set this(testargs) $oldtestargs
    $w _resetConstructor
    $w entrecreate
    return
  }
  
}

#
# method "compmethod"
#
proc use_wtree::compmethod {w mname args} {
  upvar #0 $w this

  set mname [string trim $mname]
  
  if {[llength $args] == 0} {
    return [list \
      $this(arglist,$mname) \
      $this(code,met,$mname)
    ]
  }
  
  global use
  
  set arglist [lindex $args 0]
  set body [lindex $args 1]
  
  if {$body != {} || $mname == "_destroyed"} {
  
    # install method
  
    send $use(entities) "\
      proc $this(compname)::$mname \{w $arglist\} \{
        upvar #0 \$w this
        $body
      \}
    "
  
    set this(arglist,$mname) $arglist
    set this(code,met,$mname) $body
    if {[lsearch $this(methods) $mname] < 0} {
      lappend this(methods) $mname
    }
  
  } else {
  
    # delete method
  
    send $use(entities) "rename $this(compname)::$mname {}"
    set index [lsearch $this(methods) $mname]
    set this(methods) [lreplace $this(methods) $index $index]
    unset this(arglist,$mname)
    unset this(code,met,$mname)
  }
  
}

#
# method "compmethodnames"
#
proc use_wtree::compmethodnames {w } {
  upvar #0 $w this

  return $this(methods)
  
}

#
# method "compname"
#
proc use_wtree::compname {w {newname {}}} {
  upvar #0 $w this

  #    - return current components name
  # or - rename constructor and methods for new name
  #    - recreate current component so that new methods will work
  
  # return current components name if requested
  
  if {$newname == {}} {
    return $this(compname)
  }
  
  if {$newname == $this(compname)} {
    return
  }
  
  global use
  set oldname $this(compname)
  
  # check validy
  # (same component name and widget commands would cause an infinity loop)
  if {[lsearch $this(wcmds) $newname] >= 0} {
    error "can't apply member widgets command \"$newname\" for component name"
  }
  
  # rename constructor; store new name
  
  if {[send $use(entities) "info commands $newname"] != {}} {
    if [info exists use(tree,$newname)] {
      error "component \"$newname\" already exists."
    }
    send $use(entities) "rename \{$newname\} {}"
  }
  
  send $use(entities) "
    rename $this(compname) $newname
  "
  set this(compname) $newname
  
  # rename methods
  
  send $use(entities) "
    foreach method \[info commands $newname::*\] \{
      rename \$method {}
    \}
    foreach method \{$this(methods)\} \{
      rename $oldname\::\$method $newname\::\$method
    \}
  "
  
  # rename root node if exists
  
  if {[$this(tree) find withtag $oldname] != {}} {
    $w noderename $oldname $newname
  }
  
  # recreate component (because methods wouldn't work with new name else)
  # provide an old destructor for recreation
  
  send $use(entities) "
    proc $oldname::_destroyed \
      \[info args $newname\::_destroyed\] \
      \[info body $newname\::_destroyed\]
  "
  $w entrecreate
  set this(entity) $this(entshell).$this(compname)
  send $use(entities) "
    rename $oldname\::_destroyed {}
  "
  
}

#
# method "copy"
#
proc use_wtree::copy {w {wname {}}} {
  upvar #0 $w this

  global use
  
  if { $wname == {}} {
    set wname $this(selected)
  }
     
  if { $wname == {} } {
    return
  }
  
  # inititialize cut buffer
  
  if {$use(cutbuf) != -1} {
    close $use(cutbuf)
    set use(cutbuf) -1
  }
  
  set tmpname [use_tmpname]
  set use(cutbuf) [open $tmpname w+]
  exec rm $tmpname
  
  # write requested subtree
  
  $w _saveCreates $use(cutbuf) {} $wname
  $w _saveConfigs $use(cutbuf) $wname
  $w _saveLayouts $use(cutbuf) $wname
  
  
}

#
# method "entpath"
#
proc use_wtree::entpath {w {wname {}}} {
  upvar #0 $w this

  # return current values of entities data array
  # (a path through the tree is false after renaming up to next recreation!)
  
  global use
  
  if {$wname == {}} {
    return $this(entshell)
  } else {
    if {[catch {send $use(entities) "set $this(entity)\($wname\)"} ret] == 0} {
      return $ret;
    } else {
      error "no entity for widget \"$wname\" existent"
    }
  }
  
  #  set pathlist $this(entshell)
  #  foreach id [$this(tree) ancestors $this(id,$wname)] {
  #    lappend pathlist $this(wname,$id)
  #  }
  #  lappend pathlist $wname
  #  return [join $pathlist .]
  
}

#
# method "entraise"
#
proc use_wtree::entraise {w } {
  upvar #0 $w this

  global use
  
  set rootpath $this(entshell).$this(compname)
  
  send $use(entities) "
    if \[winfo exists $rootpath\] \{
      if \{ \[winfo toplevel $rootpath\] == \"$this(entshell)\" \} \{
        wm withdraw $this(entshell)
        wm deiconify $this(entshell)
      \}
    \}
  "
  
}

#
# method "entrecreate"
#
proc use_wtree::entrecreate {w } {
  upvar #0 $w this

  # procedure for recreating entity (destroy old one and create a new one)
  
  global use
  
  set this(constructErrorCode) 0
  
  if {$this(mode) != "interactive"} {
    return
  }
  
  set testargs $this(testargs)
  
  set rootpath $this(entshell).$this(compname)
  
  # destroy current entity
  
  send $use(entities) "
    if \{ \[winfo exists $this(entity)\] \} \{ destroy $this(entity) \}
  "
  if {[send $use(entities) "winfo exists $this(entshell)"] == 0} {
    $w _entshellcreate
  }
  
  # create new entity, init created widget tree (if any)
  
  send $use(entities) "
    $this(compname) $rootpath $testargs
  "
  
  if [send $use(entities) "winfo exists $rootpath"] {
    send $use(entities) "
      if \{ \[winfo toplevel $rootpath\] == \"$this(entshell)\" \} \{
        pack $rootpath -fill both -expand true
  #      wm deiconify $this(entshell)
  #      blt_win raise $this(entshell)
      \} else \{
        wm withdraw $this(entshell)
      \}
    "
  }
  
}

#
# method "load"
#
proc use_wtree::load {w {fname {}}} {
  upvar #0 $w this

  global use
  
  if {$fname == {}} {
    set fname $use(wd)\/$this(compname).usc
  }
  
  # open file
      
  if { [catch {open $fname r} retval] != 0} {
    dialog $w.d {File Open Error} $retval error 0 OK
    return
  }
  set fd $retval
  
  # destroy current component
  # (wait for delayed destruction)
  
  $w reset
  # send $use(entities) "update"
  
  $w configure -cursor watch
  update idletasks
  $w configure -cursor {}
  
  set this(mode) passive
  
  # load new component
  
  use_wtree::_readFile $w $fd
  
  close $fd
  
  set this(mode) interactive
  $w _resetConstructor
  $w entrecreate
  
}

#
# method "nodeadd"
#
proc use_wtree::nodeadd {w parent wcmd {wname {}} {cmdargs {}}} {
  upvar #0 $w this

  global use   
  
  # initializations, validy check, assert exactly one root
  
  if {$wcmd == $this(compname)} {
    error "can't add widget with command \"$wcmd\" that is component name"
  }
  
  if {$parent == {}} {
    set parent $this(selected)
  }
  set parentpath [$w entpath $parent]
  
  if {$parent == {}} {
    if {[llength [$this(tree) children {}]] > 0} {
      dialog $w.d USE {Select parent widget first.} error 0 OK
      return
    }
  }
  
  # find a unique name for new node
  
  if { $parent == {}} {
    if {$wname != {}} {
      $w compname $wname
    }
    set wname $this(compname)
  } 
  if { $wname == {}} {
    set i 0
    set wstub $wcmd
    set wname ${wstub}$i
    while { [llength [$this(tree) find withtag $wname]] > 0
       || [send $use(entities) "winfo exists \{$parentpath.$wname\}"] == 1} {
      incr i
      set wname ${wstub}${i}
    }
  } else {
    if { [llength [$this(tree) find withtag $wname]] > 0
       || [send $use(entities) "winfo exists \{$parentpath.$wname\}"] == 1} {
      error "node \"$wname\" already exists"
    }
  }
     
  # create entity widget for new node
  
  send $use(entities) "
    proc $this(compname) \{w $this(arglist) args\} \{
      upvar #0 \$w this
      $this(code,init)
      set this($wname) $parentpath.$wname
      eval \{$wcmd \$this($wname) $cmdargs\}
      if \{\{$parent\} == {} && \"$this(mode)\" == \"interactive\"\} \{
        useCreateComponent $this(compname) \$this($wname) \$args
        if \{\[winfo toplevel \$this($wname)\] != \"$this(entshell)\"\} \{
          wm withdraw $this(entshell)
        \} else \{
          pack \$this($wname) -fill both -expand true
        \}
      \}
    \}
  "
  send $use(entities) "
    $this(compname) $this(entshell).$this(compname) $this(testargs)
  "
  
  $w _resetConstructor
  
  # create new node in tree layout
  
  set id [$this(tree) create window 0 0]
  set nodewindow $this(tree).node$id
  message $nodewindow
  $this(tree) itemconfigure $id  -window $nodewindow  -tags "$wname"
  $this(tree) nodeadd $parent $wname
  $this(tree) nodermscript $wname "destroy $nodewindow"
  
  bind $nodewindow <Destroy>  "+use_wtree::_nodedeleteData $w \[set $w\(wname,$id)\]"
     
  bind $nodewindow <Button-1>  "use_wtree::nodeselect $w \[set $w\(wname,$id)\]"
  
  blt_drag&drop source $nodewindow config  -packagecmd "use_wtree::package_use_widget $w \[set ${w}\(wname,$id\)\]"
  blt_drag&drop source $nodewindow handler use_widget dd_send_use_widget
     
  # integrate new widget
  
  lappend this(wcmds) $wcmd
  
  set this(cmd,$wname) $wcmd
  set this(cmdargs,$wname) $cmdargs
  set this(code,cnf,$wname) {}
  set this(code,spc,$wname) {}
  set this(geomcmd,$wname) {}
  set this(code,geom,$wname) {}
  set this(id,$wname) $id
  set this(wname,$id) $wname
  
  $w _treeNodeConfigure $wname
  $this(noderename) show $wname
  
}

#
# method "nodeargs"
#
proc use_wtree::nodeargs {w wname args} {
  upvar #0 $w this

  if {[llength $args] == 0} {
    return $this(cmdargs,$wname)
  }
  
  set oldargs $this(cmdargs,$wname)
  set this(cmdargs,$wname) [lindex $args 0]
  
  # apply new arguments
  # revert current component in error cases
  
  $w _resetConstructor
  $w entrecreate
  if {$this(constructErrorCode) != 0} {
    set this(cmdargs,$wname) $oldargs
    $w _resetConstructor
    $w entrecreate
    return
  }
  
  # update tree node as widget class could have changed
  
  $w _treeNodeConfigure $wname
  
}

#
# method "nodeback"
#
proc use_wtree::nodeback {w {wname {}}} {
  upvar #0 $w this

  global use
  
  if {$wname == {}} {
    set wname $this(selected)
  }
     
  if {$wname == {}} {
    return
  }
  
  # update tree layout
  # recreate entity for when it exists
  
  $this(tree) nodemove $wname -1
  
  if {[catch {$w entpath $wname}] == 0} {
    $w _resetConstructor
    $w entrecreate
  }
  
}

#
# method "nodeconfigure"
#
proc use_wtree::nodeconfigure {w wname {newconfigs get} {resetconfigs {}}} {
  upvar #0 $w this

  global use
  
  if {$newconfigs == "get"} {
    return $this(code,cnf,$wname)
  }
  
  set wpath [$w entpath $wname]
    
  # build a difference list between new configs and stored configs
  # store pendings
  
  set diffs {}
  set diffnames {}
  set pendings $this(code,cnf,$wname)
  foreach config $newconfigs {
    set index [lsearch $pendings $config]
    if {$index < 0} {
      lappend diffs $config
      lappend diffnames [lindex $config 0]
    } else {
      set pendings [lreplace $pendings $index $index]
    }
  }
  
  # reset pendings that are not found in diffnames
  # (pendings that are found in diffnames will get a new value)
  # reset configs at global scope (there should be only constants)
  
  set resets {}
  foreach config $pendings {
    set oname [lindex $config 0]
    if { [lsearch $diffnames $oname] < 0} {
      set option [send $use(entities) "$wpath configure $oname"]
      lappend resets "$oname \"[lindex $option 3]\""
    }
  }
  if {[llength $resets] > 0} {
    set code \
      [catch {send $use(entities) "[join "$wpath configure $resets"]"} ret]
    if {$code != 0} {
      error \
   "Can't reset options for \"$wname\". \n($ret)\nAre your widgets defaults ok?"
      set this(code,cnf,$wname) {}
      $w entrecreate
      return
    }
  }
  
  # set differences
  # (build a constructor for testing)
  
  if {[llength $diffs] > 0} {
    send $use(entities) "
      proc $this(compname) \{w $this(arglist) args\} \{
        upvar #0 \$w this
        $this(code,init)
        [join "$wpath configure $diffs"]
      \}
    "
    set code [catch {send $use(entities) \
      "$this(compname) $this(entshell).$this(compname) $this(testargs)"} ret]
    $w _resetConstructor
    if {$code != 0} {
      error \
        "Can't apply new options for \"$wname\". \n($ret)"
      return
    }
  }
  
  # store new configs
  
  set this(code,cnf,$wname) $newconfigs
  
}

#
# method "nodedelete"
#
proc use_wtree::nodedelete {w {wname {}}} {
  upvar #0 $w this

  global use   
  
  if { $wname == {}} {
    set wname $this(selected)
  }
     
  if { $wname != {} } {
  
    # destroy entity widget
    # catch that as it could be corrupted
  
    if {[catch {set wpath [$w entpath $wname]}] == 0} {
      send $use(entities) "destroy $wpath"
    }
    if {[$this(tree) parent $wname] == {}} {
      send $use(entities) "
        if \[winfo exists $this(entshell)\] \{
          wm deiconify $this(entshell)
        \}
      "
    }
    $w _resetConstructor
  
    # update tree layout
  
    if { $wname == $this(selected)} {
      set this(selected) {}
    }
    $this(tree) nodedelete $wname
    $this(tree) redraw
  }
  
}

#
# method "nodedeselect"
#
proc use_wtree::nodedeselect {w } {
  upvar #0 $w this

  if { $this(selected) != {} } {
    useToggleColors $this(tree).node$this(id,$this(selected))
  }
  set this(selected) {}
  
}

#
# method "nodefore"
#
proc use_wtree::nodefore {w {wname {}}} {
  upvar #0 $w this

  global use
  
  if {$wname == {}} {
    set wname $this(selected)
  }
     
  if {$wname == {}} {
    return
  }
  
  # update tree layout
  # recreate entity for when it exists
  
  $this(tree) nodemove $wname 1
  
  if {[catch {$w entpath $wname}] == 0} {
    $w _resetConstructor
    $w entrecreate
  }
  
}

#
# method "nodelayout"
#
proc use_wtree::nodelayout {w wname args} {
  upvar #0 $w this

  #  - every widget may be a potential master for layouting
  
  global use
  
  if {[llength $args] == 0} {
    return [list $this(geomcmd,$wname) $this(code,geom,$wname)]
  }
  
  set geomcmd [lindex $args 0]
  set geom [lindex $args 1]
  
  set wpath [$w entpath $wname]
  
  # destroy old layout
  # attention: blt_table may raise an exception
  #     for when it doesn't knows a master widget
  
  set oldcmd $this(geomcmd,$wname)
  if { $oldcmd != {}} {
    set code [catch {send $use(entities) "$oldcmd slaves $wpath"} slaves]
    if {$code == 0 && [llength $slaves] > 0} {
      send $use(entities) [concat $oldcmd forget $slaves]
    }
  }
  
  # clear layout for wname for empty call arguments and return
  
  if {$geomcmd == {} && $geom == {}} {
    set this(geomcmd,$wname) {}
    set this(code,geom,$wname) {}
    return
  }
  
  # update layout
  
  send $use(entities) "
    proc $this(compname) \{w $this(arglist) args\} \{
      upvar #0 \$w this
      $this(code,init)
      $geom
    \}
  "
  set code [catch {send $use(entities) \
    "$this(compname) $this(entity) $this(testargs)"} ret]
  $w _resetConstructor
  if {$code != 0} {
    error \
      "Can't apply new layout for \"$wname\". \n($ret)"
    return
  }
  
  # store new layout
  # (try to enshure that "$geom" is useful code)
  
  set code [catch {send $use(entities) "$geomcmd slaves $wpath"} retval]
  if {$code == 0} {
    set this(geomcmd,$wname) $geomcmd
    set this(code,geom,$wname) $geom
  } else {
    topmessage $w.d USE \
      "Don't store layouting for \"$wname\" with \"$geomcmd\".\n($retval)" \
      warning
  }
  
}

#
# method "noderename"
#
proc use_wtree::noderename {w oldname newname} {
  upvar #0 $w this

  if {$oldname == $this(compname)} {
    $w compname $newname
  } else {
    $w _noderename $oldname $newname
  }
}

#
# method "nodeselect"
#
proc use_wtree::nodeselect {w node} {
  upvar #0 $w this

  if { $this(selected) != {} } {
    useToggleColors $this(tree).node$this(id,$this(selected))
  }
     
  useToggleColors $this(tree).node$this(id,$node)
  set this(selected) $node
  
}

#
# method "nodespecial"
#
proc use_wtree::nodespecial {w wname args} {
  upvar #0 $w this

  if {[llength $args] == 0} {
    return $this(code,spc,$wname)
  }
  
  set oldspc $this(code,spc,$wname)
  set this(code,spc,$wname) [lindex $args 0]
  
  # apply new widget code
  # revert component in error cases
  
  $w _resetConstructor
  $w entrecreate
  if {$this(constructErrorCode) != 0} {
    set this(code,spc,$wname) $oldspc
    $w _resetConstructor
    $w entrecreate
    return
  }
  
}

#
# method "nodeup"
#
proc use_wtree::nodeup {w {wname {}}} {
  upvar #0 $w this

  global use
  
  if {$wname == {}} {
    set wname $this(selected)
  }
     
  if {$wname == {}} {
    return
  }
  
  # update tree layout
  # recreate entity for when it exists
  
  $this(tree) nodemove $wname 1
  
  if {[catch {$w entpath $wname}] == 0} {
    $w _resetConstructor
    $w entrecreate
  }
  
}

#
# method "open"
#
proc use_wtree::open {w } {
  upvar #0 $w this

  global use
  
  set rootpath $this(entshell).$this(compname)
  send $use(entities) "
    if \[winfo exists $rootpath\] \{
      wm deiconify \[winfo toplevel $rootpath\]
    \} else \{
      wm deiconify $this(entshell)
    \}
  "
  
  set top [winfo toplevel $w]
  wm deiconify $top
  blt_win raise $top
}

#
# method "package_use_widget"
#
proc use_wtree::package_use_widget {w wname token} {
  upvar #0 $w this

  global use
  
  if {[winfo children $token] == ""} {
    label $token.dd_use_widget
    pack $token.dd_use_widget
  }
  $token.dd_use_widget configure \
    -text $wname
  
  return "[$w compname] $wname"
  
}

#
# method "paste"
#
proc use_wtree::paste {w fd} {
  upvar #0 $w this

  if {$fd == -1} {
    return
  }
  
  seek $fd 0
  use_wtree::_readFile $w $fd
  
}

#
# method "reset"
#
proc use_wtree::reset {w } {
  upvar #0 $w this

  global use
  
  # clear up current component (if any)
  
  if { [$this(tree) find withtag $this(compname)] != {} } {
    $w nodedelete $this(compname)
    send $use(entities) "
  #    update;
      rename \{$this(compname)\} {}
      foreach method \{$this(methods)\} \{
        rename $this(compname)::\$method {}
      \}
    "
  }
  
  if {[send $use(entities) "winfo exists $this(entshell)"] == 0} {
    $w _entshellcreate
  }
  
  #  initialize component's constructor, destructor and code segments
  
  set this(code,init) {}
  set this(code,wpaths) {}
  set this(code,wcreates) {}
  set this(code,wlayouts) {}
  set this(code,add) {}
  set this(arglist) {}
  set this(testargs) {}
  set this(methods) {}
  
  $w _resetConstructor
  $w compmethod _destroyed {} {}
  
  set this(selected) {}
  
}

#
# method "save"
#
proc use_wtree::save {w {fname {}}} {
  upvar #0 $w this

  global use
  
  $w configure -cursor watch
  update idletasks
  $w configure -cursor {}
  
  if {$fname == {}} {
    set fname $this(compname).usc
    set fabsname $use(wd)\/$fname
  } else {
    set fabsname $fname
  }
  
  # open file
  
  use_bakfile $fabsname
      
  if { [catch {open $fabsname w} retval] != 0} {
    dialog $w.d {File Open Error} $retval error 0 OK
    return
  }
  set fd $retval
  
  # generate contents
  
  # header
  
  puts $fd "\{# description file for a USE component, version $use(version)\}"
  puts $fd "\{[use_filehead $fname]\}\n"
      
  # widget tree
  
  # constructor for arguments and init-code
  
  if {$this(code,init) != {} 
      || $this(arglist) != {}
      || $this(testargs) != {}} {
    puts $fd  "\{compconstructor \{$this(code,init)\} \{\} \{$this(arglist)\} \{$this(testargs)\}\}"
  }
  
  if { [$this(tree) find withtag $this(compname)] != {} } {
    $w _saveCreates $fd {} $this(compname)
    $w _saveConfigs $fd $this(compname)
    $w _saveLayouts $fd $this(compname)
  }
  
  # methods
  
  foreach met $this(methods) {
    if {$this(code,met,$met) != {}} {
      puts $fd  "\{compmethod $met \{$this(arglist,$met)\} \{$this(code,met,$met)\}\}"
    }
  }
  
  # constructor for additional code
  
  if {$this(code,add) != {}} {
    puts $fd  "\{compconstructor \{$this(code,init)\} \{$this(code,add)\} \{$this(arglist)\} \{$this(testargs)\}\}"
  }
  
  close $fd
  
}

#
# method "savecode"
#
proc use_wtree::savecode {w {fname {}}} {
  upvar #0 $w this

  # generate a tcl file for current component
  
  global use
  
  $w configure -cursor watch
  update idletasks
  $w configure -cursor {}
  
  if {$fname == {}} {
    set fname $this(compname).tcl
    set fabsname $use(wd)\/$fname
  } else {
    set fabsname $fname
  }
  
  # open file
  
  use_bakfile $fabsname
  
  if { [catch {open $fabsname w} retval] != 0} {
    dialog $w.d {File Open Error} $retval error 0 OK
    return
  }
  set fd $retval
  
  # generate code
  
  $w _updateCode
  
  if { [llength $this(methods)] > 1
      || [string trim $this(code,met,_destroyed)] != {}} {
    set withmethods 1
  } else {
    set withmethods 0
  }
  
  if {$withmethods && [llength $this(code,wcreates)] == 0} {
    dialog $w.d {Code Generation Error} \
      {Missing root widget for generating components code with methods.} \
      info 0 OK
    close $fd
    return
  }
    
  # header
  
  puts $fd "[use_filehead $fname]\n"
  
  # constructor
  
  puts $fd "#\n# constructor for \"$this(compname)\"\n#"
  puts $fd "proc $this(compname) \{w $this(arglist) args\} \{"
  if $withmethods {
    puts $fd  "  upvar #0 \$w this"
  }
  puts $fd ""
  if {$this(code,init) != {}} {
    regsub -all "\n" $this(code,init) "\n  " code
    puts $fd "  # user initializations\n"
    puts $fd "  $code"
  }
  if {[llength $this(code,wpaths)] > 0} {
    regsub -all "\n" [join $this(code,wpaths) ""] "\n  " code
    puts $fd "  # data initializations\n"
    puts $fd "  $code"
  }
  if {[llength $this(code,wcreates)] > 0} {
    regsub -all "\n" [join $this(code,wcreates) ""] "\n  " code
    puts $fd "  # widget creations\n"
    puts $fd "  $code"
  }
  if {[llength $this(code,wlayouts)] > 0} {
    regsub -all "\n" [join $this(code,wlayouts) ""] "\n  " code
    puts $fd "  # widget layouting\n"
    puts $fd "  $code"
  }
  if {$withmethods} {
    puts $fd "  useCreateComponent $this(compname) \$w \$args\n"
  } else {
    puts $fd "  if {\[llength \$args\] > 0} {eval \$w configure \$args}"
  }
  if {$this(code,add) != {}} {
    regsub -all "\n" $this(code,add) "\n  " code
    puts $fd "  # user additions\n"
    puts $fd "  $code"
  }
  puts $fd ""
  puts $fd "  return \$w\n\}\n"
  
  # methods
  
  if $withmethods {
    foreach mname [lsort $this(methods)] {
      if {$this(code,met,$mname) != {}} {
        puts $fd "#\n# method \"$mname\"\n#"
        puts $fd "proc $this(compname)::$mname \{w $this(arglist,$mname)\} \{"
        puts $fd "  upvar #0 \$w this"
        puts $fd ""
        regsub -all "\n" $this(code,met,$mname) "\n  " code
        puts $fd "  $code"
        puts $fd "\}\n"
      }
    }
  }  
  
  close $fd
  
}

#
# method "send"
#
proc use_wtree::send {w {fname {}}} {
  upvar #0 $w this

  global use
  
  if {$fname == {}} {
    set fname $use(wd)\/$this(compname).tcl
  }
  
  send $use(target) "source $fname"
  
}

