Subversion Repositories or1k

#
# Tests for [incr Tk] widgets based on itk::Widget
# ----------------------------------------------------------------------
#   AUTHOR:  Michael J. McLennan
#            Bell Labs Innovations for Lucent Technologies
#            mmclennan@lucent.com
#            http://www.tcltk.com/itcl
#
#      RCS:  $Id: widget.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}

# ----------------------------------------------------------------------
#  Simple mega-widget
# ----------------------------------------------------------------------
test widget-1.1 {define a simple mega-widget class} {
    option add *TestWidget.background linen
    option add *TestWidget.borderWidth 2
    option add *TestWidget.command ""
    option add *TestWidget.cursor ""
    option add *TestWidget.foreground navy
    option add *TestWidget.highlight white
    option add *TestWidget.normal ivory
    option add *TestWidget.text ""

    itcl::class TestWidget {
        inherit itk::Widget
        constructor {args} {
            itk_component add test1 {
                label $itk_interior.t1
            } {
                keep -background -foreground -cursor
                keep -text
            }
            pack $itk_component(test1) -side left -padx 2

            itk_component add test2 {
                button $itk_interior.t2 -text "Push Me"
            } {
                keep -foreground -cursor -borderwidth -command
                rename -background -normal normal Background
                rename -activebackground -highlight highlight Foreground
            }
            pack $itk_component(test2) -side right -fill x -pady 2

            eval itk_initialize $args
        }
        private variable status ""
        public method action {info} {
            lappend status $info
        }

        public method do {cmd} {
            eval $cmd
        }

        itk_option define -status status Status {} {
            lappend status $itk_option(-status)
        }
    }
    TestWidget .#auto
} {.testWidget0}

pack .testWidget0

test widget-1.2 {check the list of configuration options} {
    .testWidget0 configure
} {{-background background Background linen linen} {-borderwidth borderWidth BorderWidth 2 2} {-clientdata clientData ClientData {} {}} {-command command Command {} {}} {-cursor cursor Cursor {} {}} {-foreground foreground Foreground navy navy} {-highlight highlight Foreground white white} {-normal normal Background ivory ivory} {-status status Status {} {}} {-text text Text {} {}}}

set unique 0
foreach test {
    {-background  {-background background Background linen linen}}
    {-borderwidth {-borderwidth borderWidth BorderWidth 2 2}}
    {-clientdata  {-clientdata clientData ClientData {} {}}}
    {-command     {-command command Command {} {}}}
    {-cursor      {-cursor cursor Cursor {} {}}}
    {-foreground  {-foreground foreground Foreground navy navy}}
    {-highlight   {-highlight highlight Foreground white white}}
    {-normal      {-normal normal Background ivory ivory}}
    {-status      {-status status Status {} {}}}
    {-text        {-text text Text {} {}}}
} {
    set opt [lindex $test 0]
    set result [lindex $test 1]

    test widget-1.3.[incr unique] {check individual configuration options} {
        .testWidget0 configure $opt
    } $result
}

set unique 0
foreach test {
    {-background  red}
    {-borderwidth 1}
    {-clientdata  "foo bar"}
    {-command     {puts "hello!"}}
    {-cursor      trek}
    {-foreground  IndianRed}
    {-highlight   MistyRose}
    {-normal      MistyRose2}
    {-status      "test message"}
    {-text        "Label:"}
} {
    set opt [lindex $test 0]
    set value [lindex $test 1]

    test widget-1.4.[incr unique] {set individual configuration options} {
        list [.testWidget0 configure $opt $value] \
             [.testWidget0 cget $opt] \
             [.testWidget0 do "set itk_option($opt)"]
    } [list "" $value $value]
}

test widget-1.5 {check the list components} {
    lsort [.testWidget0 component]
} {hull test1 test2}

set unique 0
foreach test {
    {hull  .testWidget0}
    {test1 .testWidget0.t1}
    {test2 .testWidget0.t2}
} {
    set name [lindex $test 0]
    set win  [lindex $test 1]

    test widget-1.6 {check the window for each component} {
        list [.testWidget0 component $name] \
             [.testWidget0 do "set itk_component($name)"]
    } [list $win $win]
}

test widget-1.7 {check the propagation of configuration options} {
    list [.testWidget0 component hull cget -cursor] \
         [.testWidget0 component test1 cget -cursor] \
         [.testWidget0 component test2 cget -cursor]
} {trek trek trek}

test widget-1.8 {check the propagation of configuration options} {
    list [.testWidget0 component hull cget -background] \
         [.testWidget0 component test1 cget -background] \
         [.testWidget0 component test2 cget -background]
} {red red MistyRose2}

test widget-1.9 {check the propagation of configuration options} {
    list [.testWidget0 component test1 cget -text] \
         [.testWidget0 component test2 cget -text]
} {Label: {Push Me}}

test widget-1.10 {check the invocation of "config" code} {
    .testWidget0 do {set status}
} {{} {test message}}

test widget-1.11a {configure using the "code" command} {
    .testWidget0 do {configure -command [code $this action "button press"]}
    .testWidget0 cget -command
} {namespace inscope ::TestWidget {::.testWidget0 action {button press}}}

test widget-1.11b {execute some code created by "code" command} {
    .testWidget0 do {set status ""}
    .testWidget0 component test2 invoke
    .testWidget0 configure -status "in between"
    .testWidget0 component test2 invoke
    .testWidget0 do {set status}
} {{button press} {in between} {button press}}

test widget-1.12a {components can be added on the fly} {
    .testWidget0 do {
        itk_component add test3 {
            label $itk_interior.t3 -text "Temporary"
        } {
            keep -background -foreground -cursor
        }
    }
} {test3}

test widget-1.12b {components can be added on the fly} {
    .testWidget0 do {
        pack $itk_component(test3) -fill x
    }
} {}

test widget-1.13 {new components show up on the component list} {
    lsort [.testWidget0 component]
} {hull test1 test2 test3}

test widget-1.14 {new components are initialized properly} {
    list [.testWidget0 component test3 cget -background] \
         [.testWidget0 component test3 cget -foreground] \
         [.testWidget0 component test3 cget -cursor]
} {red IndianRed trek}

test widget-1.15 {components can be deleted like ordinary widgets} {
    destroy [.testWidget0 component test3]
} {}

test widget-1.16 {dead components are removed from the component list} {
    lsort [.testWidget0 component]
} {hull test1 test2}

test widget-1.17 {use "configbody" command to change "config" code} {
    configbody TestWidget::status {lappend status "new"}
} {}

test widget-1.18 {"config" code can really change} {
    .testWidget0 do {set status ""}
    .testWidget0 configure -status "test message"
    .testWidget0 configure -status "another"
    .testWidget0 do {set status}
} {new new}

test widget-1.19 {"config" code can change back} {
    configbody TestWidget::status {lappend status $itk_option(-status)}
} {}

test widget-1.20 {mega-widgets show up on the object list} {
    itcl::find objects .testWidget*
} {.testWidget0}

test widget-1.21 {when a mega-widget is destroyed, its object is deleted} {
    destroy .testWidget0
    itcl::find objects .testWidget*
} {}

test widget-1.22 {recreate a test widget} {
    TestWidget .testWidget0
    itcl::find objects .testWidget*
} {.testWidget0}

test widget-1.23 {when an object is deleted the widget is destroyed} {
    itcl::delete object .testWidget0
    winfo exists .testWidget0
} {0}

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