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

  # data initializations

  set this(use_methods) $w
  set this(frame1) $w.frame1
  set this(button0) $w.frame1.button0
  set this(button1) $w.frame1.button1
  set this(button3) $w.frame1.button3
  set this(button4) $w.frame1.button4
  set this(frame0) $w.frame0
  set this(listbox) $w.frame0.listbox
  set this(scrollbar0) $w.frame0.scrollbar0
  set this(frame2) $w.frame0.frame2
  set this(frame3) $w.frame0.frame2.frame3
  set this(label2) $w.frame0.frame2.frame3.label2
  set this(entry0) $w.frame0.frame2.frame3.entry0
  set this(label3) $w.frame0.frame2.frame3.label3
  set this(entry1) $w.frame0.frame2.frame3.entry1
  set this(label4) $w.frame0.frame2.frame3.label4
  set this(text) $w.frame0.frame2.text
  set this(scrollbar1) $w.frame0.frame2.scrollbar1
  set this(label0) $w.frame0.frame2.label0
  set this(label1) $w.frame0.frame2.label1
  
  # widget creations

  frame $this(use_methods) -class Use_methods
  frame $this(frame1) 
  button $this(button0)  \
    -text "Apply" \
    -command "$w apply"
  button $this(button1)  \
    -text "Delete" \
    -command "$w delete"
  button $this(button3)  \
    -text "New" \
    -command "$w new"
  button $this(button4)  \
    -text "Replace" \
    -command "$w replace"
  frame $this(frame0) 
  listbox $this(listbox)  \
    -relief "sunken" \
    -yscrollcommand "$this(scrollbar0) set"
  scrollbar $this(scrollbar0)  \
    -command "$this(listbox) yview" \
    -relief "sunken"
  frame $this(frame2)  \
    -relief "sunken"
  frame $this(frame3) 
  label $this(label2)  \
    -text "proc <component>::"
  entry $this(entry0)  \
    -relief "sunken" \
    -width "5"
  label $this(label3)  \
    -text "\{ w "
  entry $this(entry1)  \
    -relief "sunken"
  label $this(label4)  \
    -text "\} \{"
  text $this(text)  \
    -borderwidth "2" \
    -relief "sunken" \
    -yscrollcommand "$this(scrollbar1) set"
  scrollbar $this(scrollbar1)  \
    -command "$this(text) yview" \
    -relief "sunken"
  label $this(label0)  \
    -anchor "w" \
    -text "upvar #0 \$w this"
  label $this(label1)  \
    -text "\}"
  
  # widget layouting

  pack $this(button3) \
    $this(button0) \
    $this(button4) \
    $this(button1) \
    -side left -expand true
  pack $this(label2) -side left -fill y
  pack $this(entry0) -side left -fill both -expand true
  pack $this(label3) -side left -fill y 
  pack $this(entry1) -side left -fill both -expand true
  pack $this(label4) -side left -fill y
  blt_table $this(frame2) \
    $this(frame3) 0,0 -fill x -columnspan 3 \
    $this(label0) 1,1 -fill x -columnspan 2 \
    $this(text)  2,1 -fill both \
    $this(scrollbar1) 2,2 -fill y \
    $this(label1) 3,0
  blt_table column $this(frame2) configure 0 -resize none
  blt_table column $this(frame2) configure 2 -resize none
  blt_table row $this(frame2) configure 0 -resize none
  blt_table row $this(frame2) configure 1 -resize none
  blt_table row $this(frame2) configure 3 -resize none
  blt_table $this(frame0) \
    $this(listbox) 0,0 -fill both \
    $this(scrollbar0) 0,1 -fill y \
    $this(frame2) 0,2 -fill both
  blt_table column $this(frame0) configure 0 -resize expand
  blt_table column $this(frame0) configure 1 -resize none
  
  pack $this(frame1) -side bottom -fill both -pady 2m
  pack $this(frame0) -fill both -expand true -pady 2m
  
  useCreateComponent use_methods $w $args

  # user additions

  set this(cur,component) {}
  set this(cur,method) {}
  
  blt_drag&drop target $this(use_methods) handler use_component \
    "$w compname \$DragDrop(use_component)"
  
  tk_listboxSingleSelect $this(listbox)
  bind $this(listbox) <Button-1> "
    %W select from \[%W nearest %y\]
    %W select to \[%W nearest %y\]
    set $w\(cur,method) \[%W get \[%W nearest %y\]\]
    $w read
  "
  

  return $w
}

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

  if {$this(cur,component) == {}} {
    return
  }
  
  global use
  set tree $use(tree,$this(cur,component))
  
  $tree compmethod \
    [$this(entry0) get] \
    [$this(entry1) get] \
    [$this(text) get 0.0 end]
  
  $w fillist
  
}

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

  if {[llength $args] == 0} {
    return $this(cur,component)
  }
  
  global use
  set component [lindex $args 0]
  if {$component == {}} {
    return
  }
  
  set tree $use(tree,$component)
  set this(cur,component) $component
  
  $this(label2) configure \
    -text "proc $component\::"
  
  $w new
  $w fillist
  
}

#
# method "delete"
#
proc use_methods::delete {w } {
  upvar #0 $w this

  if {$this(cur,component) == {}} {
    return
  }
  
  global use
  set tree $use(tree,$this(cur,component))
  
  $tree compmethod [$this(entry0) get] {} {}
  $w new
  $w fillist
  
}

#
# method "fillist"
#
proc use_methods::fillist {w } {
  upvar #0 $w this

  if {$this(cur,component) == {}} {
    return
  }
  
  global use
  set tree $use(tree,$this(cur,component))
  
  # clear current contents
  
  $this(listbox) delete 0 end
  set this(cur,method) {}
  
  # fill the listbox with implemented methods
  
  foreach method [lsort [$tree compmethodnames]] {
    scan $method "$this(cur,component)::%s" method
    $this(listbox) insert end $method
  }
  
}

#
# method "new"
#
proc use_methods::new {w } {
  upvar #0 $w this

  $this(entry0) configure -state normal
  $this(entry1) configure -state normal
  $this(button1) configure -state normal
  
  $this(entry0) delete 0 end
  $this(entry1) delete 0 end
  $this(text) delete 0.0 end
}

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

  if {$this(cur,method) == {}} {
    return
  }
  
  global use
  set tree $use(tree,$this(cur,component))
  
  set code [$tree compmethod $this(cur,method)]
  
  # enable all controls
  
  $this(entry0) configure -state normal
  $this(entry1) configure -state normal
  $this(button1) configure -state normal
  
  # show new methods code
  
  $this(entry0) delete 0 end
  $this(entry0) insert 0 $this(cur,method)
  $this(entry1) delete 0 end
  $this(entry1) insert 0 [lindex $code 0]
  $this(text) delete 0.0 end
  $this(text) insert 0.0 [lindex $code 1]
  
  # disable some controls for destructor
  
  if {$this(cur,method) == "_destroyed"} {
    $this(entry0) configure -state disabled
    $this(entry1) configure -state disabled
    $this(button1) configure -state disabled
  }
}

#
# method "replace"
#
proc use_methods::replace {w } {
  upvar #0 $w this

  if {$this(cur,method) == {}} {
    return
  }
  
  global use
  set tree $use(tree,$this(cur,component))
  
  $tree compmethod $this(cur,method) {} {}
  $w apply
  
}

