widgetclass.test

#---------------------------------------------------------------------
# TITLE:
#       widgetclass.test
#
# AUTHOR:
#       Arnulf Wiedemann with a lot of code form the snit tests by
#       Will Duquette
#
# DESCRIPTION:
#       Test cases for ::itcl::type command.
#       Uses the ::tcltest:: harness.
#
#       There is at least Tcl 8.6a3 needed
#
#    The tests assume tcltest 2.2
#-----------------------------------------------------------------------

# ### ### ### ######### ######### #########
## Declare the minimal version of Tcl required to run the package
## tested by this testsuite, and its dependencies.

proc testsNeedTcl {version} {
    # This command ensures that a minimum version of Tcl is used to
    # run the tests in the calling testsuite. If the minimum is not
    # met by the active interpreter we forcibly bail out of the
    # testsuite calling the command. The command has to be called
    # immediately after loading the utilities.

    if {[package vsatisfies [package provide Tcl] ${version}-]} return

    puts "    Aborting the tests found in \"[file tail [info script]]\""
    puts "    Requiring at least Tcl $version, have [package provide Tcl]."

    # This causes a 'return' in the calling scope.
    return -code return
}

# ### ### ### ######### ######### #########
## Declare the minimum version of Tcltest required to run the
## testsuite.

proc testsNeedTcltest {version} {
    # This command ensure that a minimum version of the Tcltest
    # support package is used to run the tests in the calling
    # testsuite. If the minimum is not met by the loaded package we
    # forcibly bail out of the testsuite calling the command. The
    # command has to be called after loading the utilities. The only
    # command allowed to come before it is 'textNeedTcl' above.

    # Note that this command will try to load a suitable version of
    # Tcltest if the package has not been loaded yet.

    if {[lsearch [namespace children] ::tcltest] == -1} {
	if {![catch {
	    package require tcltest $version
	}]} {
	    namespace import -force ::tcltest::*
	    return
	}
    } elseif {[package vcompare [package present tcltest] $version] >= 0} {
	namespace import -force ::tcltest::*
	return
    }

    puts "    Aborting the tests found in [file tail [info script]]."
    puts "    Requiring at least tcltest $version, have [package present tcltest]"

    # This causes a 'return' in the calling scope.
    return -code return
}

# Set up for Tk tests: enter the event loop long enough to catch
# any bgerrors.
proc tkbide {{msg "tkbide"} {msec 500}} {
    set ::bideVar 0
    set ::bideError ""
    set ::bideErrorInfo ""
    # It looks like update idletasks does the job.
    if {0} {
        after $msec {set ::bideVar 1}
        tkwait variable ::bideVar
    }
    update idletasks
    if {"" != $::bideError} {
        error "$msg: $::bideError" $::bideErrorInfo
    }
}



testsNeedTcl     8.6
testsNeedTcltest 2.2

interp alias {} type {} ::itcl::type
interp alias {} widget {} ::itcl::widget

# Marks tests which are only for Tk.
tcltest::testConstraint tk [expr {![catch {package require Tk}]}]

::tcltest::loadTestedCommands
package require itcl

#-----------------------------------------------------------------------
# Widgets

# A widget is just a widgetadaptor with an automatically created hull
# component (a Tk frame).  So the widgetadaptor tests apply; all we
# need to test here is the frame creation.

test widget-1.1 {creating a widget
} -constraints {
    tk
} -body {
    widget myframe {
        delegate method * to itcl_hull
        delegate option * to itcl_hull
    }

    myframe create .frm -background green

    set a [.frm cget -background]
    set b [.frm itcl_hull]

    destroy .frm
    tkbide
    list $a $b
} -cleanup {
    myframe destroy
} -result {green ::itcl::internal::widgets::hull1.frm}

test widget-2.1 {can't redefine hull
} -constraints {
    tk
} -body {
    # there is no need to define or set itcl_hull as that is done automatically
    widget myframe {
        method resethull {} {
	set itcl_hull ""
	}
    }

    myframe .frm

    .frm resethull
} -returnCodes {
    error
} -cleanup {
    myframe destroy
} -result {can't set "itcl_hull": The itcl_hull component cannot be redefined}


#-----------------------------------------------------------------------
# install
#
# The install command is used to install widget components, while getting
# options for the option database.

test install-1.1 {installed components are created properly
} -constraints {
    tk
} -body {
    widget myframe {
        # Delegate an option just to make sure the component variable
        # exists.
        delegate option -font to text

        constructor {args} {
            installcomponent text using text $win.text -background green
        }

        method getit {} {
            $win.text cget -background
        }
    }

    myframe .frm
    set a [.frm getit]
    destroy .frm
    tkbide
    set a
} -cleanup {
    myframe destroy
} -result {green}

test install-1.2 {installed components are saved properly
} -constraints {
    tk
} -body {
    widget myframe {
        # Delegate an option just to make sure the component variable
        # exists.
        delegate option -font to text

        constructor {args} {
            installcomponent text using text $win.text -background green
        }

        method getit {} {
            $text cget -background
        }
    }

    myframe .frm
    set a [.frm getit]
    destroy .frm
    tkbide
    set a
} -cleanup {
    myframe destroy
} -result {green}

test install-1.4 {install queries option database
} -constraints {
    tk
} -body {
    widget myframe {
        delegate option -font to text

        typeconstructor {
            option add *Myframe.font Courier
        }

        constructor {args} {
            installcomponent text using text $win.text
        }
    }

    myframe .frm
    set a [.frm cget -font]
    destroy .frm
    tkbide
    set a
} -cleanup {
    myframe destroy
} -result {Courier}

test install-1.5 {explicit options override option database
} -constraints {
    tk
} -body {
    widget myframe {
        delegate option -font to text

        typeconstructor {
            option add *Myframe.font Courier
        }

        constructor {args} {
            installcomponent text using text $win.text -font Times
        }
    }

    myframe .frm
    set a [.frm cget -font]
    destroy .frm
    tkbide
    set a
} -cleanup {
    myframe destroy
} -result {Times}

test install-1.6 {option db works with targetted options
} -constraints {
    tk
} -body {
    widget myframe {
        delegate option -textfont to text as -font

        typeconstructor {
            option add *Myframe.textfont Courier
        }

        constructor {args} {
            installcomponent text using text $win.text
        }
    }

    myframe .frm
    set a [.frm cget -textfont]
    destroy .frm
    tkbide
    set a
} -cleanup {
    myframe destroy
} -result {Courier}

test install-1.8 {install can install non-widget components
} -constraints {
    tk
} -body {
    type dog {
        option -tailcolor black
    }

    widget myframe {
        delegate option -tailcolor to thedog

        typeconstructor {
            option add *Myframe.tailcolor green
        }

        constructor {args} {
            installcomponent thedog using dog $win.dog
        }
    }

    myframe .frm
    set a [.frm cget -tailcolor]
    destroy .frm
    tkbide
    set a

} -cleanup {
    dog destroy
    myframe destroy
} -result {green}

test install-1.9 {ok if no options are delegated to component
} -constraints {
    tk
} -body {
    type dog {
        option -tailcolor black
    }

    widget myframe {
        constructor {args} {
            installcomponent thedog using dog $win.dog
        }
    }

    myframe .frm
    destroy .frm
    tkbide

    # Test passes if no error is raised.
    list ok
} -cleanup {
    myframe destroy
    dog destroy
} -result {ok}

test install-2.1 {
    delegate option * for a non-shadowed option.  The text widget's
    -foreground and -font options should be set according to what's
    in the option database on the widgetclass.
} -constraints {
    tk
} -body {
    widget myframe {
        delegate option * to text

        typeconstructor {
            option add *Myframe.foreground red
            option add *Myframe.font {Times 14}
        }

        constructor {args} {
            installcomponent text using text $win.text
        }
    }

    myframe .frm
    set a [.frm cget -foreground]
    set b [.frm cget -font]
    destroy .frm
    tkbide

    list $a $b
} -cleanup {
    myframe destroy
} -result {red {Times 14}}


test install-2.2 {
    Delegate option * for a shadowed option.  Foreground is declared
    as a non-delegated option, hence it will pick up the option database
    default.  -foreground is not included in the "delegate option *", so
    the text widget's -foreground option will not be set from the
    option database.
} -constraints {
    tk
} -body {
    widget myframe {
        option -foreground white
        delegate option * to text

        typeconstructor {
            option add *Myframe.foreground red
        }

        constructor {args} {
            installcomponent text using text $win.text
        }

        method getit {} {
            $text cget -foreground
        }
    }

    myframe .frm
    set a [.frm cget -foreground]
    set b [.frm getit]
    destroy .frm
    tkbide

    expr {![string equal $a $b]}
} -cleanup {
    myframe destroy
} -result {1}

test install-2.3 {
    Delegate option * for a creation option.  Because the text widget's
    -foreground is set explicitly by the constructor, that always
    overrides the option database.
} -constraints {
    tk
} -body {
    widget myframe {
        delegate option * to text

        typeconstructor {
            option add *Myframe.foreground red
        }

        constructor {args} {
            installcomponent text using text $win.text -foreground blue
        }
    }

    myframe .frm
    set a [.frm cget -foreground]
    destroy .frm
    tkbide

    set a
} -cleanup {
    myframe destroy
} -result {blue}

test install-2.4 {
    Delegate option * with an excepted option.  Because the text widget's
    -state is excepted, it won't be set from the option database.
} -constraints {
    tk
} -body {
    widget myframe {
        delegate option * to text except -state

        typeconstructor {
            option add *Myframe.foreground red
            option add *Myframe.state disabled
        }

        constructor {args} {
            installcomponent text using text $win.text
        }

        method getstate {} {
            $text cget -state
        }
    }

    myframe .frm
    set a [.frm getstate]
    destroy .frm
    tkbide

    set a
} -cleanup {
    myframe destroy
} -result {normal}


#-----------------------------------------------------------------------
# Advanced installhull tests
#
# installhull is used to install the hull widget for both widgets and
# widget adaptors.  It has two forms.  In one form it installs a widget
# created by some third party; in this form no querying of the option
# database is needed, because we haven't taken responsibility for creating
# it.  But in the other form (installhull using) installhull actually
# creates the widget, and takes responsibility for querying the
# option database as needed.
#
# NOTE: "installhull using" is always used to create a widget's hull frame.
#
# That options passed into installhull override those from the
# option database.

test installhull-1.1 {
    options delegated to a widget's itcl_hull frame with the same name are
    initialized from the option database.  Note that there's no
    explicit code in Snit to do this; it happens because we set the
    -class when the widget was created.  In fact, it happens whether
    we delegate the option name or not.
} -constraints {
    tk
} -body {
    widget myframe {
        delegate option -background to itcl_hull

        typeconstructor {
            option add *Myframe.background red
            option add *Myframe.width 123
        }

        method getwid {} {
            $itcl_hull cget -width
        }
    }

    myframe .frm
    set a [.frm cget -background]
    set b [.frm getwid]
    destroy .frm
    tkbide
    list $a $b
} -cleanup {
    myframe destroy
} -result {red 123}

test installhull-1.2 {
    Options delegated to a widget's itcl_hull frame with a different name are
    initialized from the option database.
} -constraints {
    tk
} -body {
    widget myframe {
        delegate option -mainbackground to itcl_hull as -background

        typeconstructor {
            option add *Myframe.mainbackground green
        }
    }

    myframe .frm
    set a [.frm cget -mainbackground]
    destroy .frm
    tkbide
    set a
} -cleanup {
    myframe destroy
} -result {green}



test option-5.1 {local widget options read from option database
} -constraints {
    tk
} -body {
    widget dog {
        option -foo a
        option -bar b

        typeconstructor {
            option add *Dog.bar bb
        }
    }

    dog .fido
    set a [.fido cget -foo]
    set b [.fido cget -bar]
    destroy .fido
    tkbide

    list $a $b

} -cleanup {
    dog destroy
} -result {a bb}

test option-5.2 {local option database values available in constructor
} -constraints {
    tk
} -body {
    widget dog {
        option -bar b
        variable saveit

        typeconstructor {
            option add *Dog.bar bb
        }

        constructor {args} {
            set saveit $itcl_options(-bar)
        }

        method getit {} {
            return $saveit
        }
    }

    dog .fido
    set result [.fido getit]
    destroy .fido
    tkbide

    set result
} -cleanup {
    dog destroy
} -result {bb}

#-----------------------------------------------------------------------
# Setting the widget class explicitly

test widgetclass-1.3 {widgetclass must begin with uppercase letter
} -constraints {
    tk
} -body {
    widget dog {
        widgetclass dog
    }
} -returnCodes {
    error
} -result {widgetclass "dog" does not begin with an uppercase letter}

test widgetclass-1.4 {widgetclass can only be defined once
} -constraints {
    tk
} -body {
    widget dog {
        widgetclass Dog
        widgetclass Dog
    }
} -returnCodes {
    error
} -result {too many widgetclass statements}

test widgetclass-1.5 {widgetclass set successfully
} -constraints {
    tk
} -body {
    widget dog {
        widgetclass DogWidget
    }

    # The test passes if no error is thrown.
    list ok
} -cleanup {
    dog destroy
} -result {ok}

test widgetclass-1.6 {implicit widgetclass applied to hull
} -constraints {
    tk
} -body {
    widget dog {
        typeconstructor {
            option add *Dog.background green
        }

        method background {} {
            $itcl_hull cget -background
        }
    }

    dog .dog

    set bg [.dog background]

    destroy .dog

    set bg
} -cleanup {
    dog destroy
} -result {green}

test widgetclass-1.7 {explicit widgetclass applied to hull
} -constraints {
    tk
} -body {
    widget dog {
        widgetclass DogWidget

        typeconstructor {
            option add *DogWidget.background yellow
        }

        method background {} {
            $itcl_hull cget -background
        }
    }

    dog .dog

    set bg [.dog background]

    destroy .dog

    set bg
} -cleanup {
    dog destroy
} -result {yellow}

#-----------------------------------------------------------------------
# hulltype statement

test hulltype-1.3 {hulltype can be frame
} -constraints {
    tk
} -body {
    widget dog {
        delegate option * to itcl_hull
        hulltype frame
    }

    dog .fido
    catch {.fido configure -use} result
    destroy .fido
    tkbide

    set result
} -cleanup {
    dog destroy
} -result {unknown option "-use"}

test hulltype-1.4 {hulltype can be toplevel
} -constraints {
    tk
} -body {
    widget dog {
        delegate option * to itcl_hull
        hulltype toplevel
    }

    dog .fido
    catch {.fido configure -use} result
    destroy .fido
    tkbide

    set result
} -cleanup {
    dog destroy
} -result {-use use Use {} {}}

test hulltype-1.5 {hulltype can only be defined once
} -constraints {
    tk
} -body {
    widget dog {
        hulltype frame
        hulltype toplevel
    }
} -returnCodes {
    error
} -result {too many hulltype statements}

test hulltype-2.1 {list of valid hulltypes
} -constraints {
    tk
} -body {
    type dog {
    }

    lsort [dog info hulltypes]
} -cleanup {
    dog destroy
} -result {frame labelframe toplevel ttk:frame ttk:labelframe ttk:toplevel}

test winfo-10.1 {widget info widgets
} -constraints {
    tk
} -body {
    widget dog {
    }

    widget cat {
    }

    lsort [dog info widgets]
} -cleanup {
    dog destroy
    cat destroy
} -result {cat dog}

test winfo-10.2 {widget info components
} -constraints {
    tk
} -body {
    widget dog {
        component comp1
        component comp2
    }

    widget cat {
        component comp1
        component comp1a
    }

    set a [lsort [dog info components]]
    set b [lsort [cat info components]]
    list $a $b
} -cleanup {
    dog destroy
    cat destroy
} -result {{comp1 comp2 itcl_hull} {comp1 comp1a itcl_hull}}

test winfo-10.3 {widget info widgetclasses
} -constraints {
    tk
} -body {
    widget dog {
        widgetclass DogWidget
    }

    widget cat {
        widgetclass CatWidget
    }

    lsort [dog info widgetclasses]
} -cleanup {
    dog destroy
    cat destroy
} -result {CatWidget DogWidget}


#---------------------------------------------------------------------
# Clean up

::tcltest::cleanupTests
return