labeledwidget.test

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

# This file is a Tcl script to test out [incr Widgets] Labeledwidget class.
# It is organized in the standard fashion for Tcl tests with the following
# notation for test case labels:
#
#   1.x - Construction/Destruction tests
#   2.x - Configuration option tests
#   3.x - Method tests
#
# Copyright (c) 1995 DSC Technologies Corporation
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# @(#) $Id: labeledwidget.test 144 2003-02-05 10:56:26Z mdejong $

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

package require Iwidgets 3.0

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

wm geometry . {}
raise .

set c 1
set o 1
set m 1

#
# Initial construction test
#
test Labeledwidget-1.$c {Labeledwidget construction} {
    iwidgets::Labeledwidget .lw
    pack [listbox [.lw childsite].lb -relief sunken] -padx 10 -pady 10
    pack .lw -fill both -expand yes -padx 10 -pady 10
    image create bitmap flagup -file $tk_library/demos/images/flagup.bmp
    update 
} {}

incr c

#
# Option tests which are successful.
#
test Labeledwidget-2.$o {configuration option} {
    llength [.lw configure]
} {13}

incr o

foreach test {
    {-labelvariable foo foo}
    {-labelvariable {} {}}
    {-labeltext "Label" "Label"}
    {-labelpos nw nw}
    {-labelpos n n}
    {-labelpos ne ne}
    {-labelpos en en}
    {-labelpos e e}
    {-labelpos es es}
    {-labelpos sw sw}
    {-labelpos s s}
    {-labelpos se se}
    {-labelpos wn wn}
    {-labelpos w w}
    {-labelpos ws ws}
    {-labelmargin 20 20}
    {-labelfont 6x13 6x13}
    {-labelimage flagup flagup}
    {-labelpos nw nw}
    {-labelpos n n}
    {-labelpos ne ne}
    {-labelpos en en}
    {-labelpos e e}
    {-labelpos es es}
    {-labelpos sw sw}
    {-labelpos s s}
    {-labelpos se se}
    {-labelpos wn wn}
    {-labelpos w w}
    {-labelpos ws ws}
    {-labelimage {} {}}} {
	set option [lindex $test 0]
	test Labeledwidget-1.$o "configuration options, $option" {
	    .lw configure $option [lindex $test 1]
	    lindex [.lw configure $option] 4
	} [lindex $test 2]
        update 
	incr o
    }

#
# Method tests which are successful.
#
test Labeledwidget-3.$m {object method, childsite} {
    list [catch {.lw childsite} msg] $msg
} [list 0 .lw.lwchildsite]

incr m

test Labeledwidget-3.$m {object static method, alignlabels} {
    list [catch {iwidgets::Labeledwidget::alignlabels .lw} msg] $msg
} {0 {}}

incr m

#
# Method tests which fail and produce errors
#
test Labeledwidget-3.$m {alignlabels static method} {
    button .b
    list [catch {iwidgets::Labeledwidget::alignlabels .b} msg] $msg
} {1 {.b is not a "Labeledwidget"}}

incr m

test Labeledwidget-1.$c {Labeledwidget destruction} {
    destroy .b
    destroy .lw
    update 
    image delete flagup
} {}

incr c

test Labeledwidget-1.$c {Labeledwidget construction} {
    iwidgets::labeledwidget .lw -labeltext "ListBox" -labelpos s
    pack [listbox [.lw childsite].lb -relief sunken] -padx 10 -pady 10
    pack .lw -fill both -expand yes -padx 10 -pady 10
    update 
} {}

incr c

test Labeledwidget-1.$c {Labeledwidget destruction} {
    destroy .lw
    update 
} {}

incr c

test Labeledwidget-1.$c {Labeledwidget construction} {
    iwidgets::labeledwidget .lw 
    pack .lw 
    destroy .lw
    update 
} {}

::tcltest::cleanupTests
exit