#
# 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.

# preprocessing to speed up configuration initialization

proc tkwm_widget::setdefaults {basewidget widget defaults} {
    upvar #0 $widget type
    set body "upvar #0 \$var data ; $basewidget \$var -class \$class ;"
    foreach default $defaults {
	# set the widgets resource names array
	set type([lindex $default 0]) [lrange $default 1 3]
	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 class} $body
}

# generic procedure for processing configurations

proc tkwm_widget::initialconfigure {type class var params} {
    upvar #0 $var data
    upvar $params args
    set data(type) $type
    upvar #0 $type typev

    # initialize option defaults
    $type::defaults $var $class

    # Default destruction bindings
    bind $var <Destroy>     [list tkwm_widget::destroy $var]

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

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

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

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

    # create the widget heirarchy
    $type::create $var

    # Set up widget command
    catch {rename $var.root {}}
    rename $var $var.root

    proc $var {option args} {
	set var [lindex [info level 0] 0]
	upvar #0 $var data
	if {[info command $data(type)::command-$option]!=""} {
	    $data(type)::command-$option $var args
	} else {
	    error "unknown subcommand $option"
	}
    }

    # Set up the configure subcommand
    proc $type::command-config {var params} {
	tkwm_widget::configure $var $params
    }
}

proc tkwm_widget::configure {var params} {
    upvar #0 $var data
    upvar 2 $params args
    set type $data(type)

    set len  [llength $args]

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

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

	        catch {
		    $type::config$flag $var $optn
	            set data($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
}