Subversion Repositories or1k

#
# Tests for [incr Tk] widgets based on itk::Toplevel
# ----------------------------------------------------------------------
#   AUTHOR:  Michael J. McLennan
#            Bell Labs Innovations for Lucent Technologies
#            mmclennan@lucent.com
#            http://www.tcltk.com/itcl
#
#      RCS:  $Id: toplevel.test,v 1.1.1.1 2002-01-16 10:24:48 markom Exp $
# ----------------------------------------------------------------------
#            Copyright (c) 1993-1998  Lucent Technologies, Inc.
# ======================================================================
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.

if {[string compare test [info procs test]] == 1} then {source defs}

# ----------------------------------------------------------------------
#  Toplevel mega-widget
# ----------------------------------------------------------------------
test toplevel-1.1 {define a toplevel mega-widget class} {
    option add *TestToplevel.background linen
    option add *TestToplevel.cursor ""
    option add *TestToplevel.foreground navy
    option add *TestToplevel.highlight white
    option add *TestToplevel.normal ivory
    option add *TestToplevel.text ""

    itcl::class TestToplevel {
        inherit itk::Toplevel
        constructor {args} {
            itk_component add test1 {
                label $itk_interior.t1
            } {
                keep -background -foreground -cursor
                keep -text
            }
            pack $itk_component(test1) -side left -padx 2
            eval itk_initialize $args
        }
        public method do {cmd} {
            eval $cmd
        }

        private variable status ""
        itk_option define -background background Background {} {
            lappend status "background: $itk_option(-background)"
        }
    }
    TestToplevel .#auto
} {.testToplevel0}

test toplevel-1.2 {check the list of configuration options} {
    .testToplevel0 configure
} {{-background background Background linen linen} {-clientdata clientData ClientData {} {}} {-cursor cursor Cursor {} {}} {-foreground foreground Foreground navy navy} {-takefocus takeFocus TakeFocus 0 0} {-text text Text {} {}} {-title title Title {} {}}}

test toplevel-1.3 {check the list components} {
    lsort [.testToplevel0 component]
} {hull test1}

test toplevel-1.4 {check the propagation of configuration options} {
    .testToplevel0 configure -background red
    list [.testToplevel0 component hull cget -background] \
         [.testToplevel0 component test1 cget -background] \
         [.testToplevel0 do {set status}]
} {red red {{background: linen} {background: red}}}

test toplevel-1.5 {mega-widgets show up on the object list} {
    itcl::find objects .testToplevel*
} {.testToplevel0}

test toplevel-1.6 {when a mega-widget is destroyed, its object is deleted} {
    destroy .testToplevel0
    itcl::find objects .testToplevel*
} {}

# ----------------------------------------------------------------------
#  Clean up
# ----------------------------------------------------------------------
itcl::delete class TestToplevel