# testutils.tcl --
#
# This file is sourced by each test file when invoking "tcltest::loadTestedCommands".
# It implements the testutils mechanism which is used to import utility procs
# into test files that need them.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

#
# DOCUMENTATION FOR TEST AUTHORS AND MAINTAINERS
#
# The testutils mechanism is documented in the separate file "testutils.GUIDE",
# which is placed in the same directory as this file "testutils.tcl".
#

namespace eval ::tk::test {
    #
    # The namespace ::tk::test itself doesn't contain any procs or variables.
    # The contents of this namespace exist solely in child namespaces that
    # are defined hereafter.
    #
    # Each child namespace represents a functional area, also called "domain".
    #
}

namespace eval ::tk::test::generic {

    proc assert {expr} {
	if {! [uplevel 1 [list expr $expr]]} {
	    return -code error "assertion failed: \"[uplevel 1 [list subst -nocommands $expr]]\""
	}
    }

    # controlPointerWarpTiming --
    #
    # This proc is intended to ensure that the (mouse) pointer has actually
    # been moved to its new position after a Tk test issued:
    #
    #    [event generate $w $event -warp 1 ...]
    #
    # It takes care of the following timing details of pointer warping:
    #
    # a. Allow pointer warping to happen if it was scheduled for execution at
    #    idle time. This happens synchronously if $w refers to the
    #    whole screen or if the -when option to [event generate] is "now".
    #
    # b. Work around a race condition associated with OS notification of
    #    mouse motion on Windows.
    #
    #    When calling [event generate $w $event -warp 1 ...], the following
    #    sequence occurs:
    #    - At some point in the processing of this command, either via a
    #      synchronous execution path, or asynchronously at idle time, Tk calls
    #      an OS function* to carry out the mouse cursor motion.
    #    - Tk has previously registered a callback function** with the OS, for
    #      the OS to call in order to notify Tk when a mouse move is completed.
    #    - Tk doesn't wait for the callback function to receive the notification
    #      from the OS, but continues processing. This suits most use cases
    #      because usually the notification arrives fast enough (within a few tens
    #      of microseconds). However ...
    #    - A problem arises if Tk performs some processing, immediately following
    #      up on [event generate $w $event -warp 1 ...], and that processing
    #      relies on the mouse pointer having actually moved. If such processing
    #      happens just before the notification from the OS has been received,
    #      Tk will be using not yet updated info (e.g. mouse coordinates).
    #
    #         Hickup, choke etc ... !
    #
    #            *  the function SendInput() of the Win32 API
    #            ** the callback function is TkWinChildProc()
    #
    #    This timing issue can be addressed by putting the Tk process on hold
    #    (do nothing at all) for a somewhat extended amount of time, while
    #    letting the OS complete its job in the meantime. This is what is
    #    accomplished by calling [after ms].
    #
    #    ----
    #    For the history of this issue please refer to Tk ticket [69b48f427e],
    #    specifically the comment on 2019-10-27 14:24:26.
    #
    #
    # Beware: there are cases, not (yet) exercised by the Tk test suite, where
    # [controlPointerWarpTiming] doesn't ensure the new position of the pointer.
    # For example, when issued under Tk8.7+, if the value for the -when option
    # to [event generate $w] is not "now", and $w refers to a Tk window, i.e. not
    # the whole screen.
    #
    proc controlPointerWarpTiming {{duration 50}} {
	update idletasks ;# see a. above
	if {[tk windowingsystem] eq "win32"} {
	    after $duration ;# see b. above
	}
    }

    proc deleteWindows {} {
	destroy {*}[winfo children .]
	# This update is needed to avoid intermittent failures on macOS in unixEmbed.test
	# with the (GitHub Actions) CI runner.
	# Reason for the failures is unclear but could have to do with window ids being deleted
	# after the destroy command returns. The detailed mechanism of such delayed deletions
	# is not understood, but it appears that this update prevents the test failures.
	update
    }

    # On macOS windows are not allowed to overlap the menubar at the top of the
    # screen or the dock.  So tests which move a window and then check whether it
    # got moved to the requested location should use a y coordinate larger than the
    # height of the menubar (normally 23 pixels) and an x coordinate larger than the
    # width of the dock, if it happens to be on the left.
    # The C-level command "testmenubarheight" deals with this issue but it may
    # not be available on each platform. Therefore, provide a fallback here.
    if {[llength [info commands testmenubarheight]] == 0} {
	if {[tk windowingsystem] ne "aqua"} {
	    # Windows may overlap the menubar
	    proc testmenubarheight {} {
		return 0
	    }
	} else {
	    # Windows may not overlap the menubar
	    proc testmenubarheight {} {
		return 30 ;  # arbitrary value known to be larger than the menubar height
	    }
	}
    }

    # testutils --
    #
    #    Takes care of exporting/importing/forgetting utility procs and any
    #    associated variables from a specific test domain (functional area).
    #
    #    More information is available in the file "testutils.GUIDE"
    #
    # Arguments:
    #    subCmd : "export", "import" or "forget"
    #    args   : a sequence of domains that need to be imported/forgotten,
    #             unused for "export"
    #
    proc testutils {subCmd args} {
	variable importedDomains
	variable importVars

	if {$subCmd ni [list export import forget]} {
	    return -code error "invalid subCmd \"$subCmd\". Usage: [lindex [info level 0] 0] export|import|forget ?domain domain ...?"
	}

	set argc [llength $args]
	if {$subCmd eq "export"} {
	    if {$argc != 0} {
		return -code error "invalid #args. Usage: [lindex [info level 0] 0] export"
	    }

	    # export all procs from the invoking domain namespace except "init"
	    uplevel 1 {
		if {[info procs init] eq "init"} {
		    set exports [info procs]
		    namespace export {*}[lremove $exports [lsearch $exports "init"]]
		    unset exports
		} else {
		    namespace export *
		}
	    }
	    return
	}
	if {$argc < 1} {
	    return -code error "invalid #args. Usage: [lindex [info level 0] 0] import|forget domain ?domain ...?"
	}

	# determine the requesting namespace
	set ns [uplevel 1 {namespace current}]

	# import/forget domains
	foreach domain $args {
	    if {! [namespace exists ::tk::test::$domain]} {
		return -code error "testutils domain \"$domain\" doesn't exist"
	    }

	    switch -- $subCmd {
		import {
		    if {[info exists importedDomains($ns)] && ($domain in $importedDomains($ns))} {
			return -code error "testutils domain \"$domain\" was already imported"
		    } else {

			# import procs
			if {[catch {
			    uplevel 1 [list namespace import ::tk::test::${domain}::*]
			} errMsg]} {
			    # revert import of procs already done
			    uplevel 1 [list namespace forget ::tk::test::${domain}::*]
			    return -code error "import from testutils domain \"$domain\" failed: $errMsg"
			}

			# import associated namespace variables declared in the init proc
			if {"init" in [namespace inscope ::tk::test::$domain {info procs init}]} {
			    if {[info exists importVars($ns,$domain)]} {
				#
				# Note [A1]:
				# If test files inadvertently leave behind a variable with the same name
				# as an upvar'ed namespace variable, its last value will serve as a new
				# initial value in case that the init proc declares that variable without
				# a value. Also, the result of "info exists varName" would be different
				# between test files.
				#
				# The next unset prevents such artefacts. See also note [A2] below.
				#
				uplevel 1 [list unset -nocomplain {*}$importVars($ns,$domain)]
			    }
			    ::tk::test::${domain}::init
			    if {($ns ne "::") || (! [info exists importVars($ns,$domain)])} {
				#
				# Importing associated namespace variables into the global namespace where
				# tests are normally executing, needs to be done only once because an upvar
				# link cannot be removed from a namespace. For other requesting namespaces
				# we need to reckon with deletion and re-creation of the namespace in the
				# meantime.
				#
				if {[info exists importVars($ns,$domain)]} {
				    set associatedVars $importVars($ns,$domain)
				} else {
				    set associatedVars [namespace inscope ::tk::test::$domain {info vars}]
				}
				foreach varName $associatedVars {
				    if {[catch {
					uplevel 1 [list upvar #0 ::tk::test::${domain}::$varName $varName]
				    } errMsg]} {
					# revert imported procs and partial variable import
					uplevel 1 [list unset -nocomplain {*}$associatedVars]
					uplevel 1 [list namespace forget ::tk::test::${domain}::*]
					return -code error "import from testutils domain \"$domain\" failed: $errMsg"
				    }
				}
				set importVars($ns,$domain) $associatedVars
			    }
			}

			# register domain as imported
			lappend importedDomains($ns) $domain
		    }
		}
		forget {
		    if {(! [info exists importedDomains($ns)]) || ($domain ni $importedDomains($ns))} {
			return -code error "testutils domain \"$domain\" was not imported"
		    }

		    # remove imported utility procs from the namespace where tests are executing
		    uplevel 1 [list namespace forget ::tk::test::${domain}::*]

		    #
		    # Some namespace variables are meant to persist across test files
		    # in the entire Tk test suite (notably the variable ImageNames,
		    # domain "image"). These variables are also not meant to be accessed
		    # from, and imported into the namespace where tests are executing,
		    # and they should not be cleaned up here.
		    #

		    if {[info exists importVars($ns,$domain)]} {
			#
			# Remove imported namespace variables.
			#
			# Note [A2]:
			# The upvar link in the namespace where tests are executing cannot be removed.
			# Without specific attention, this can cause surprising behaviour upon
			# re-initialization. See also note [A1] above.
			#
			uplevel 1 [list unset -nocomplain {*}$importVars($ns,$domain)]
		    }
		    set importedDomains($ns) [lremove $importedDomains($ns) [lsearch $importedDomains($ns) $domain]]
		}
	    }
	}
    }

    testutils export
}

# Import generic utility procs into the global namespace (in which tests are
# normally executing) as a standard policy.
::tk::test::generic::testutils import generic

namespace eval ::tk::test::image {

    proc imageCleanup {} {
	variable ImageNames
	foreach img [image names] {
	    if {$img ni $ImageNames} {image delete $img}
	}
    }

    proc imageFinish {} {
	variable ImageNames
	set imgs [lsearch -all -inline -glob -not [lsort [image names]] ::tk::icons::indicator*]
	if {$imgs ne $ImageNames} {
	    return -code error "images remaining: [image names] != $ImageNames"
	}
	imageCleanup
    }

    proc imageInit {} {
	variable ImageNames
	if {![info exists ImageNames]} {
	    set ImageNames [lsearch -all -inline -glob -not [lsort [image names]] ::tk::icons::indicator*]
	}
	imageCleanup
	if {[lsort [image names]] ne $ImageNames} {
	    return -code error "IMAGE NAMES mismatch: [image names] != $ImageNames"
	}
    }

    proc imageNames {} {
	variable ImageNames
	set r {}
	foreach img [image names] {
	    if {$img ni $ImageNames} {lappend r $img}
	}
	return $r
    }

    testutils export
}

namespace eval ::tk::test::scroll {

    # init --
    #
    # This is a reserved proc that is part of the mechanism that the proc
    # testutils employs when making utility procs and associated namespace
    # variables available to test files.
    #
    # Test authors should define and initialize namespace variables here if
    # they need to be imported into the namespace in which tests are executing.
    # This proc must not be exported.
    #
    # For more information, see the documentation in the file "testutils.GUIDE"
    #
    proc init {} {
	variable scrollInfo {}
    }

    # Used as the scrolling command for widgets, set with "-[xy]scrollcommand".
    # It saves the scrolling information in a namespace variable "scrollInfo".
    proc setScrollInfo {args} {
	variable scrollInfo $args
    }

    testutils export
}

namespace eval ::tk::test::text {

    # init --
    #
    # This is a reserved proc that is part of the mechanism that the proc
    # testutils employs when making utility procs and associated namespace
    # variables available to test files.
    #
    # Test authors should define and initialize namespace variables here if
    # they need to be imported into the namespace in which tests are executing.
    # This proc must not be exported.
    #
    # For more information, see the documentation in the file "testutils.GUIDE"
    #
    proc init {} {
	variable fixedFont {Courier -12}
	variable fixedWidth [font measure $fixedFont m]
	variable fixedHeight [font metrics $fixedFont -linespace]
	variable fixedAscent [font metrics $fixedFont -ascent]
    }

    # full border size of the text widget, i.e. first x or y coordinate inside the text widget
    # warning:  -padx  is supposed to be the same as  -pady  (same border size horizontally and
    # vertically around the widget)
    proc bo {{w .t}} {
	return [expr {[$w cget -borderwidth] + [$w cget -highlightthickness] + [$w cget -padx]}]
    }

    # x-coordinate of the first pixel of $n-th char (count starts at zero), left justified
    proc xchar {n {w .t}} {
	return [expr {[bo $w] + [xw $n]}]
    }

    # x-width of $n chars, fixed width font
    proc xw {n} {
	variable fixedWidth
	return [expr {$n * $fixedWidth}]
    }

    # y-coordinate of the first pixel of $l-th display line (count starts at 1)
    proc yline {l {w .t}} {
	variable fixedHeight
	return [expr {[bo $w] + ($l - 1) * $fixedHeight}]
    }

    testutils export
}

namespace eval ::tk::test::timing {

    # init --
    #
    # This is a reserved proc that is part of the mechanism that the proc
    # testutils employs when making utility procs and associated namespace
    # variables available to test files.
    #
    # Test authors should define and initialize namespace variables here if
    # they need to be imported into the namespace in which tests are executing.
    # This proc must not be exported.
    #
    # For more information, see the documentation in the file "testutils.GUIDE"
    #
    proc init {} {
	variable dt
	set dt(granularity) milliseconds
	set dt(t0) [clock milliseconds]
    }

    proc dt.get {} {
	variable dt
	set now [clock $dt(granularity)]
	set result [expr {$now - $dt(t0)}]
	set dt(t0) $now
	return $result
    }

    proc dt.reset {{granularity milliseconds}} {
	if {$granularity ni "microseconds milliseconds seconds"} {
	    return -code error "invalid parameter \"$granularity\", expected \"microseconds\", \"milliseconds\" or \"seconds\""
	}
	variable dt
	set dt(granularity) $granularity
	set dt(t0) [clock $dt(granularity)]
    }

    # progress.* --
    #
    #	This set of procs monitors progress and total duration of a procedure
    #	in a loop.
    #
    #	Derived from tests/ttk/ttk.test, see:
    #
    #	https://core.tcl-lang.org/tk/file?ci=f94f84b254b0c5ad&name=tests/ttk/ttk.test&ln=335-340
    #
    proc progress.init {{granularity milliseconds}} {
	dt.reset $granularity
    }

    proc progress.update {} {
	puts -nonewline stderr "." ; flush stderr
    }

    proc progress.end {} {
	puts stderr " [dt.get] $::tk::test::timing::dt(granularity)"
    }

    testutils export
}

# EOF
