#
# Copyright (c) 1993 Eric Schenk.
# All rights reserved.
#
# Permission is hereby granted, without written agreement and without
# license or royalty fees, to use, copy, modify, and distribute this
# software and its documentation for any purpose, provided that the
# above copyright notice and the following two paragraphs appear in
# all copies of this software.
# 
# IN NO EVENT SHALL ERIC SCHENK BE LIABLE TO ANY PARTY FOR
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF ERIC
# SCHENK HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#
# ERIC SCHENK SPECIFICALLY DISCLAIMS ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
# AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
# ON AN "AS IS" BASIS, AND ERIC SCHENK HAS NO OBLIGATION TO
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.

# generic routines to help build new widgets.

proc tkwm_widget::makecommand {var procedure} {
    upvar #0 $var data
    # move the root widget to the side
    catch {rename $var.root {}}
    rename $var $var.root
    # make a copy of the named procedure
    proc $var [info args $procedure] [info body $procedure]
}

# preprocessing to speed up configuration initialization

proc tkwm_widget::setdefaults {widget class defaults} {
    upvar #0 $widget type
    set body "upvar #0 \$var data ; frame \$var -class $class ;"
    foreach default $defaults {
	# set the widgets resource names array
	set type([lindex $default 0]) [lrange $default 1 2]
	option add *$class.[lindex $default 2] [lindex $default 3] widgetDefault
	set get "option get \$var [lindex $default 1] [lindex $default 2]"
	set sdef "set data([lindex $default 0]) \[$get\] ;"
	set body [concat $body $sdef]
    }
    proc $widget::defaults {var} $body
}

# generic procedure for processing configurations

proc tkwm_widget::initialconfigure {var params} {
    upvar #0 $var data
    upvar #0 $data(type) type
    upvar $params paramlist


    # initialize option defaults
    $data(type)::defaults $var

    set len  [expr [llength $paramlist]-2]
    set i 0

    while {$i <= $len} {
        set flag [lindex $paramlist $i]
        incr i
        set optn [lindex $paramlist $i]
        incr i

	if [info exists type($flag)] {
	    set data($flag) $optn
	} else {
	    error "unknown option $flag"
        }
    }

    if {$i!=[expr $len+2]} {
        error "Odd number of config parameters applied to $var"
    }

    return ""
}

proc tkwm_widget::configure {configproc var params} {
    upvar #0 $var data
    upvar $params paramlist

    set len  [llength $paramlist]

    switch $len {
	0 {
    	    upvar #0 $data(type) type
            set option_list [array names type]
	    set lst {}
	    foreach flag $option_list {
		lappend lst [list $flag \
				  [lindex $type($flag) 0] \
				  [lindex $type($flag) 1] \
				  [lindex $type($flag) 2] \
				  $data($flag)]
	    }
	    return $lst
	}
	1 {
    	    upvar #0 $data(type) type
	    set flag [lindex $paramlist 0]
	    return [list $flag \
			 [lindex $type($flag) 0] \
			 [lindex $type($flag) 1] \
			 [lindex $type($flag) 2] \
			 $data($flag)]
	}
	default {
	    set len2 [expr {$len - 2}] 
	    set i 0

	    while {$i <= $len2} {
		set flag [lindex $paramlist $i]
		incr i
		set optn [lindex $paramlist $i]
		incr i

		$configproc $var $flag $optn
	    }

	    if {$i != $len} {
		error "Odd number of config parameters applied to $var"
	    }
	    return ""
	}
    }
}

# generic destructor for a widget

proc tkwm_widget::destroy {var} {
    global $var
    catch {rename $var.root {}}
    unset $var
}