# use_configs.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_configs"
#
proc use_configs {w  args} {
  upvar #0 $w this

  # data initializations

  set this(use_configs) $w
  set this(title) $w.title
  set this(label0) $w.title.label0
  set this(entry0) $w.title.entry0
  set this(label1) $w.title.label1
  set this(entry1) $w.title.entry1
  set this(label2) $w.title.label2
  set this(label3) $w.title.label3
  set this(choice) $w.title.choice
  set this(menu0) $w.title.choice.menu0
  set this(label4) $w.title.label4
  set this(frame0) $w.frame0
  set this(options) $w.frame0.options
  set this(buttons) $w.buttons
  set this(read) $w.buttons.read
  set this(defaults) $w.buttons.defaults
  set this(apply) $w.buttons.apply
  
  # widget creations

  frame $this(use_configs) -class Use_configs
  frame $this(title) 
  label $this(label0)  \
    -anchor "w" \
    -text "Component: "
  entry $this(entry0)  \
    -relief "sunken" \
    -textvariable "$w\(cur,compname)"
  label $this(label1)  \
    -text "Widget:" \
    -anchor w
  entry $this(entry1)  \
    -relief sunken \
    -textvariable ${w}(cur,wname)
  label $this(label2)  \
    -anchor "w" \
    -text "Class:"
  label $this(label3)  \
    -anchor "w" \
    -textvariable "${w}(cur,class)"
  menubutton $this(choice)  \
    -menu "$this(menu0)" \
    -relief "raised" \
    -text "Edit: "
  menu $this(menu0) 
  # create menu items
  
  $this(menu0) add radiobutton \
    -label Arguments \
    -variable $w\(mode) \
    -value Arguments \
    -command "$w read"
  $this(menu0) add radiobutton \
    -label Options \
    -variable $w\(mode) \
    -value Options \
    -command "$w read"
  $this(menu0) add radiobutton \
    -label Special \
    -variable $w\(mode) \
    -value Special \
    -command "$w read"
  
  label $this(label4)  \
    -anchor "w" \
    -textvariable "$w\(mode)"
  frame $this(frame0)  \
    -borderwidth "2" \
    -relief "sunken"
  frame $this(options) 
  frame $this(buttons) 
  button $this(read)  \
    -text Read \
    -command "use_configs::read $w"
  button $this(defaults)  \
    -command "use_configs::readDefaults $w" \
    -text "Read Defaults"
  button $this(apply)  \
    -command "$w apply" \
    -text "Apply"
  
  # widget layouting

  blt_table $this(title) \
    $this(label0) 0,0 -anchor w \
    $this(entry0) 0,1 -fill x \
    $this(label1) 1,0 -anchor w \
    $this(entry1) 1,1 -fill x \
    $this(label2) 2,0 -anchor w \
    $this(label3) 2,1 -fill x \
    $this(choice) 3,0 -anchor w \
    $this(label4) 3,1 -fill x
  blt_table column $this(title) configure 0 -resize none
  pack $this(read) $this(defaults) $this(apply) \
    -side left -expand true
  pack $this(title) \
    -side top \
    -padx 2m -pady 2m \
    -fill both
  pack $this(buttons) \
    -side bottom \
    -anchor center \
    -fill both \
    -pady 2m
  pack $this(frame0) \
    -side top \
    -padx 2m -pady 2m \
    -fill both \
    -expand true
  
  useCreateComponent use_configs $w $args

  # user additions

  blt_drag&drop target $w handler use_widget "
    $w compname \[lindex \$DragDrop(use_widget) 0\]
    $w wname \[lindex \$DragDrop(use_widget) 1\]
    $w read
  "
  blt_drag&drop target $w handler use_component \
    "$w compname \$DragDrop(use_component)"
  
  foreach widget "$w $this(entry0) $this(entry1)" {
     bind $widget <Return> "$this(apply) flash; $this(apply) invoke"
  }
  
  set this(cur,compname) {}
  set this(cur,wname) {}
  set this(mode) Options
  
  
  

  return $w
}

#
# method "apply"
#
proc use_configs::apply {w } {
  upvar #0 $w this

  global use
  
  if { $this(cur,compname) == {}
      || $this(cur,wname) == {}} return
  
  set tree $use(tree,$this(cur,compname))
  
  case $this(mode) in {
    Options {
      $w applyOptions
    }
    Special {
      $tree nodespecial $this(cur,wname) \
        [$this(options) get 0.0 end]
    }
    Arguments {
      $tree nodeargs $this(cur,wname) \
        [$this(options) get 0.0 end]
    }
  }
}

#
# method "applyOptions"
#
proc use_configs::applyOptions {w } {
  upvar #0 $w this

  global use
  
  if { $this(cur,compname) == {}
      || $this(cur,wname) == {}} return
  
  set tree $use(tree,$this(cur,compname))
  
  set wpath [$tree entpath $this(cur,wname)]
  set eclass [send $use(entities) "winfo class $wpath"]
  if { $this(cur,class) != $eclass} {
    dialog $w._d_ USE \
      "Invalid widget class $eclass ($this(cur,class) expected)." error 0 OK
    return
  }
  
  # set all options that differ from default (newconfigs)
  
  set i 0
  set newconfigs {}
  foreach option [send $use(entities) "$wpath configure"] {
    if {[llength $option] == 5} {
      set oname [lindex $option 0]
      set entryw $this(options).[string tolower $oname]
      set evalue [$entryw get]
      if { $evalue != [lindex $option 3]} {
        lappend newconfigs "$oname \"$evalue\""
      }
      incr i
    }
  }
  
  $tree nodeconfigure $this(cur,wname) $newconfigs
  
  
}

#
# method "compname"
#
proc use_configs::compname {w args} {
  upvar #0 $w this

  if {[llength $args] == 0} {
    return $this(cur,compname)
  } else {
    set this(cur,compname) [lindex $args 0]
  }
}

#
# method "read"
#
proc use_configs::read {w } {
  upvar #0 $w this

  global use
  
  if { $this(cur,compname) == {}
      || $this(cur,wname) == {}} return
  
  set tree $use(tree,$this(cur,compname))
  set wpath [$tree entpath $this(cur,wname)]
  set this(cur,class) [send $use(entities) "winfo class $wpath"]
  
  case $this(mode) in {
    Options {
      $this(defaults) configure -state normal
      $w readDefaults
      foreach config [$tree nodeconfigure $this(cur,wname)] {
        set entryw $this(options).[string tolower [lindex $config 0]]
        $entryw delete 0 end
        $entryw insert 0 [string trim [lrange $config 1 1] \"]
      }
    }
    Special {
      $this(defaults) configure -state disabled
      destroy $this(options)
      text $this(options)
      pack $this(options) \
        -side top \
        -fill both
      $this(options) insert 0.0 [$tree nodespecial $this(cur,wname)]
    }
    Arguments {
      $this(defaults) configure -state disabled
      destroy $this(options)
      text $this(options)
      pack $this(options) \
        -side top \
        -fill both
      $this(options) insert 0.0 [$tree nodeargs $this(cur,wname)]
    }
  }
}

#
# method "readDefaults"
#
proc use_configs::readDefaults {w } {
  upvar #0 $w this

  global use
  
  if { $this(cur,compname) == {}
      || $this(cur,wname) == {}} return
  
  set tree $use(tree,$this(cur,compname))
  set wpath [$tree entpath $this(cur,wname)]
  
  destroy $this(options)
  frame $this(options)
  pack $this(options) \
    -side top \
    -fill both
  
  blt_table $this(options)
  blt_table column $this(options) configure 0 -resize none
  set i 0
  foreach option [send $use(entities) "$wpath configure"] {
    if {[llength $option] >= 4} {
      set oname [lindex $option 0]
      set ovalue [lindex $option 3]
      set labelw $this(options).label$i
      set entryw $this(options).[string tolower $oname]
      label $labelw \
        -text $oname \
        -anchor w
      entry $entryw \
        -relief sunken \
        -width 40
      $entryw insert 0 $ovalue
      bind $entryw <Return> \
        "+$this(apply) flash; $this(apply) invoke"
      blt_table $this(options) \
        $labelw $i,0 -anchor w \
        $entryw $i,1 -fill x
      incr i
    }
  }
  
}

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

  if {[llength $args] == 0} {
    return $this(cur,wname)
  } else {
    set this(cur,wname) [lindex $args 0]
  }
}

