#
# use_basic.tcl, 1.0
#  Tcl procedures for working with USE components
#

# Copyright (c) 1994 R"udiger Franke
# All Rights Reserved.
#
# Software developed with USE may contain the procedures of this file
# without written agreement and without license or royalty fees,
# provided that the following disclaimer is accepted.
# 
# Other 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.

#
# useCreateComponent:
#  - init an own component command
#  - realize widget like method calls
#  - bind destructor <component>::_destroyed
#
if {[info commands useCreateComponent] == {}} {
proc useCreateComponent { component entity {options {}} } {

  # rename entity's widget command
  # create new entity's command

  set bakcommand $entity.$component

  # check for potential cycles in widget "tree"
  if { [info commands $bakcommand] != {}} {
    error "component \"$component\" already exists for \"$entity\""
  }
  rename $entity $bakcommand

  proc $entity { method args} "
    useCallMethod $component $entity \$method \$args
  "

  # bind destruction
  # (be careful for repeated overloaded components)
  #  - first delete overloaded widget command
  #  - then call all methods "_destroyed" in the right order
  #  - afterwards unset entity's data array

  set head {}; set olddestruct {}; set tail {}
  if {[info commands $component::_destroyed] != {}} {
    set newdestruct "$component::_destroyed $entity; "
  } else {
    set newdestruct {}
  }
  if [regexp "(.*)(eval \{.*unset $entity\})(.*)" \
      [bind $entity <Destroy>] dummy head olddestruct tail] {
    regsub \
      "eval \{" $olddestruct \
      "eval \{$newdestruct" destruct
    bind $entity <Destroy> \
      "rename $bakcommand {}; $head$destruct$tail"
  } else {
    bind $entity <Destroy> \
      "+rename $bakcommand {}; eval \{${newdestruct}unset $entity\}"
  }    

  # apply options

  if { $options != {}} {
    eval $entity configure $options
  }
}
}

#
# useCallMethod
#  - call <component>::<method> if exists
#  - else call method for overloaded widget command
#  - in error case append own methods to describing string
#  --> works for multiple overloaded widgets (components)
#
if {[info commands useCallMethod] == {}} {
proc useCallMethod {component entity method arguments} {

  set command $component::$method
  if { [info commands $command] != {} } {
    eval $command $entity $arguments
  } else {
    set ret [catch {eval $entity.$component $method $arguments} code]
    if {$ret != 0} {
      if {[regexp {bad option .} $code] == 1} {
        set commands [join [lsort [info commands $component::*]]]
        regsub -all "$component::" "$commands" "" additions
        error "$code ; $additions"
      } else {
        error "$code"
      }
    } else {
      return "$code"
    }
  }
}
}
