option.test

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

#
# Basic tests for [incr Tk] mega-widgets
# ----------------------------------------------------------------------
#   AUTHOR:  Michael J. McLennan
#            Bell Labs Innovations for Lucent Technologies
#            [e-mail]
#            http://www.tcltk.com/itcl
#
#      RCS:  $Id: option.test 144 2003-02-05 10:56:26Z 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

# ----------------------------------------------------------------------
#  Component option processing
# ----------------------------------------------------------------------
test option-1.1 {create a widget for the following tests} {
    itcl::class TestOptComp {
        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
            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)
        }
    }

    itcl::class TestOptWidget {
        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
            eval itk_initialize $args
        }
        public method do {cmd} {
            eval $cmd
        }
    }
    TestOptWidget .#auto
} {.testOptWidget0}

test option-1.2 {"keep" can be called more than once} {
    .testOptWidget0 do {
        itk_component add k0 {
            TestOptComp $itk_interior.k0 -status "create"
        } {
            keep -background -foreground -cursor
            keep -background -foreground -cursor
            keep -status
            keep -status
        }
        pack $itk_component(k0)
    }
    .testOptWidget0 configure -status "foo"
    .testOptWidget0 component k0 do {set status}
} {create foo}

test option-1.3 {"rename" can be called more than once} {
    .testOptWidget0 do {
        itk_component add k1 {
            TestOptComp $itk_interior.k1 -status "create"
        } {
            rename -status -test test Test
            rename -status -test test Test
        }
        pack $itk_component(k1)
    }
    .testOptWidget0 configure -test "bar"
    .testOptWidget0 component k1 do {set status}
} {create bar}

test option-1.4 {"ignore" overrides keep and rename} {
    .testOptWidget0 do {
        itk_component add k2 {
            TestOptComp $itk_interior.k2 -status "create"
        } {
            keep -status
            rename -status -test test Test
            ignore -status
        }
        pack $itk_component(k2)
    }
    .testOptWidget0 configure -status k2 -test k2
    .testOptWidget0 component k2 do {set status}
} {create foo bar}

# ----------------------------------------------------------------------
#  Option processing with "usual" command
# ----------------------------------------------------------------------
test option-2.1 {create a widget for the following tests} {
    TestOptComp .testUsual
} {.testUsual}

test option-2.2 {register some "usual" code} {
    itk::usual TestOptComp-test {keep -cursor -foreground}
} {}

test option-2.3 {query back "usual" code} {
    itk::usual TestOptComp-test
} {keep -cursor -foreground}

test option-2.4 {query back unknown "usual" code} {
    itk::usual xyzzyxyzzy
} {}

test option-2.5 {add a component using "usual" code} {
    .testUsual do {
        itk_component add u0 {
            label $itk_interior.u0 -text "Usual Test #0"
        } {
            usual TestOptComp-test
        }
        pack $itk_component(u0)
    }
    .testUsual configure -foreground green -cursor gumby

    list [.testUsual component u0 cget -foreground] \
         [.testUsual component u0 cget -cursor]
} {green gumby}

test option-2.6 {override "usual" options} {
    .testUsual do {
        itk_component add u1 {
            label $itk_interior.u1 -text "Usual Test #1"
        } {
            usual TestOptComp-test
            ignore -cursor
            keep -background
        }
        pack $itk_component(u1)
    }
    .testUsual configure -foreground red -background white -cursor dot

    list [.testUsual component u1 cget -foreground] \
         [.testUsual component u1 cget -background] \
         [.testUsual component u1 cget -cursor]
} {red white gumby}

set unique 0
foreach widget {button canvas checkbutton entry frame label listbox
                menu menubutton message radiobutton scale scrollbar
                text toplevel} {
    set name "c[incr unique]"
    test option-2.7.$name {verify "usual" options for all Tk widgets} {
        .testUsual do [format {
            itk_component add %s {
                %s $itk_interior.%s
            }
        } $name $widget $name]
    } $name
}

# ----------------------------------------------------------------------
#  Clean up
# ----------------------------------------------------------------------
itcl::delete class TestOptComp TestOptWidget

::tcltest::cleanupTests
exit