widget.test

linux 下的源代码分析阅读器 red hat公司新版

#
# Tests for [incr Tk] widgets based on itk::Widget
# ----------------------------------------------------------------------
#   AUTHOR:  Michael J. McLennan
#            Bell Labs Innovations for Lucent Technologies
#            [e-mail]
#            http://www.tcltk.com/itcl
#
#      RCS:  $Id: widget.test 188 2003-02-18 07:15:38Z mdejong $
# ----------------------------------------------------------------------
#            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.

package require tcltest
namespace import -force ::tcltest::*

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

package require Itk

# ----------------------------------------------------------------------
#  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 [itcl::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} {
    itcl::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} {
    itcl::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}

test widget-1.24 {recreate another test widget} {
    TestWidget .testWidget
} {.testWidget}

test widget-1.25 {when an internal component is destroyed, it is removed from the list of components, and any dead options disappear} {
    list [lsort [.testWidget component]] \
         [.testWidget configure] \
      [catch {destroy [.testWidget component test1]}] \
         [.testWidget component] \
         [.testWidget do {return [lsort [array names itk_component]]}] \
         [.testWidget configure]
} {{hull test1 test2} {{-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 {} {}}} 0 {hull test2} {hull test2} {{-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 {} {}}}}

test widget-1.26 {when an internal component is deleted (but not destroyed) it is disconnected from the option list and its binding tags are updated} {
    set comp [.testWidget component test2]
    list [bindtags $comp] \
         [bind itk-destroy-$comp <Destroy>] \
      [catch {.testWidget do {itk_component delete test2}}] \
         [bindtags $comp] \
         [bind itk-destroy-$comp <Destroy>] \
         [.testWidget configure]
} {{itk-destroy-.testWidget.t2 .testWidget.t2 Button . all} {namespace inscope ::itk::Archetype {::.testWidget itk_component delete test2}} 0 {.testWidget.t2 Button . all} {} {{-background background Background linen linen} {-clientdata clientData ClientData {} {}} {-cursor cursor Cursor {} {}} {-status status Status {} {}}}}

test widget-1.27 {when a mega-widget object is deleted, its window and any
        components are destroyed (even if in another window) } {
    catch {destroy .t1}
    catch {rename .t1.bw {}}
    catch {itcl::delete class ButtonWidget}

    itcl::class ButtonWidget {
        inherit itk::Widget

        constructor {args} {
            eval itk_initialize $args

            itk_component add button {
                button $itk_option(-container).b -text Button
            } {}
            pack $itk_component(button)
        }

        itk_option define -container container Container {}
    }

    toplevel .t1
    frame .t1.f
    ButtonWidget .t1.bw -container .t1.f

    pack .t1.f
    pack .t1.bw

    set button [.t1.bw component button]
    itcl::delete object .t1.bw
    set result [list $button [winfo exists $button]]
    destroy .t1
    itcl::delete class ButtonWidget
    set result
} {.t1.f.b 0}

test widget-1.28 {when a window that contains a megawidget component
        is destroyed, the component is removed from the megawidget} {
    catch {destroy .t1}
    catch {rename .t1.bw {}}
    catch {itcl::delete class ButtonWidget}

    itcl::class ButtonWidget {
        inherit itk::Widget

        constructor {args} {
            eval itk_initialize $args

            itk_component add button {
                button $itk_option(-container).b -text Button
            } {}
            pack $itk_component(button)
        }

        itk_option define -container container Container {}
    }

    toplevel .t1
    frame .t1.f
    ButtonWidget .t1.bw -container .t1.f

    pack .t1.f
    pack .t1.bw
    set result [list [.t1.bw component]]
    destroy .t1.f
    lappend result [list [.t1.bw component]]

    itcl::delete object .t1.bw
    destroy .t1
    itcl::delete class ButtonWidget
    set result
} {{button hull} hull}

test widget-1.29 {when destroying a component that is inside another
        window protect against that case where one component destroy
        actually destroys other contained components} {
    catch {destroy .t1}
    catch {rename .t1.bw {}}
    catch {itcl::delete class ButtonWidget}

    itcl::class ButtonWidget {
        inherit itk::Widget

        constructor {args} {
            eval itk_initialize $args

            # Note, the component names matter here since
            # [.t2 component] returns names in hash order.
            # We need to delete cframe first since it
            # is the parent of cbutton.

            itk_component add cframe {
                button $itk_option(-container).cframe
            } {}
            pack $itk_component(cframe)

            itk_component add cbutton {
                button $itk_component(cframe).b -text Button
            } {}
            pack $itk_component(cbutton)
        }

        itk_option define -container container Container {}
    }

    toplevel .t1
    frame .t1.f
    ButtonWidget .t1.bw -container .t1.f

    pack .t1.f
    pack .t1.bw
    set result [list [.t1.bw component]]
    # destructor should destroy cframe but not cbutton
    itcl::delete object .t1.bw
    lappend result [winfo exists .t1.f.cframe]

    destroy .t1
    itcl::delete class ButtonWidget
    set result
} {{hull cframe cbutton} 0}


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

::tcltest::cleanupTests
exit