#---------------------------------------------------------------------
# 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