diff options
author | William Joye <wjoye@cfa.harvard.edu> | 2019-01-07 20:02:26 (GMT) |
---|---|---|
committer | William Joye <wjoye@cfa.harvard.edu> | 2019-01-07 20:02:26 (GMT) |
commit | dd7ebc578d780f789cf3a15f249c8a874faf79e3 (patch) | |
tree | fb96917e1f49ca7bcef7efc1107c1306f604a471 /tkhtml1/tests/engine.tcl | |
parent | 40254c18e6e39a5d7b83ec6bebf5506851309eb7 (diff) | |
download | blt-dd7ebc578d780f789cf3a15f249c8a874faf79e3.zip blt-dd7ebc578d780f789cf3a15f249c8a874faf79e3.tar.gz blt-dd7ebc578d780f789cf3a15f249c8a874faf79e3.tar.bz2 |
update TEA 3.13
Diffstat (limited to 'tkhtml1/tests/engine.tcl')
-rw-r--r-- | tkhtml1/tests/engine.tcl | 144 |
1 files changed, 0 insertions, 144 deletions
diff --git a/tkhtml1/tests/engine.tcl b/tkhtml1/tests/engine.tcl deleted file mode 100644 index 2739b40..0000000 --- a/tkhtml1/tests/engine.tcl +++ /dev/null @@ -1,144 +0,0 @@ -# This file contains the test driver for the html widget. It defines -# a special version of the test procedure to use for testing the -# html widget. -# - -# Initialize variables -# -namespace eval tcltest { - set mode run - set current {} - set passed 0 - set failed 0 - set total 0 - set status {} -} - -# Arguments: -# -# tag A symbolic tag for this test. Ex: html-1.0 -# -# desc A human-readable description of what this test does. -# -# script Tcl code to implement the test -# -# result The expected result from this test. If the actual result -# is different the test fails. -# -proc ::tcltest::test {tag desc script result} { - ::tcltest::change-desc $tag $desc - if {[info exists ::tcltest::idle]} { - catch {after cancel $::tcltest::idle} - catch {unset ::tcltest::idle} - } - set rc [catch {uplevel #0 $script} msg] - set r [list $rc $msg] - if {$r==$result} { - incr ::tcltest::passed - puts "---- Test $tag passed" - } else { - incr ::tcltest::failed - puts "**** Test $tag failed" - puts "Expected: [list $result]" - puts "Got: [list $r]" - } - incr ::tcltest::total - ::tcltest::update-status - set ::tcltest::idle [after 100 ::tcltest::testing-complete] -} - -# Create the test control window -# -proc ::tcltest::mainwin {} { - set w .testinfo - toplevel $w - wm title $w {Html Widget Test Information} - wm iconname $w {Html-Test} - set f $w.f1 - frame $f - pack $f -side top -fill x - label $f.l -text {Status: } - label $f.v -textvariable ::tcltest::status - pack $f.l $f.v -side left - set f $w.f2 - frame $f - pack $f -side top -fill x - label $f.l -text {Current Test: } - label $f.v -textvariable ::tcltest::current - pack $f.l $f.v -side left - set f $w.b - frame $f - pack $f -side bottom -fill x - button $f.pause -text Pause -command ::tcltest::pause - button $f.pass -text {Pass} -command {::tcltest::set-result pass} - button $f.fail -text {Fail} -command {::tcltest::set-result fail} - button $f.exit -text Exit -command exit - pack $f.pause $f.pass $f.fail $f.exit -side right -pady 10 -expand 1 - scrollbar $w.sb -orient vertical -command "$w.t yview" - pack $w.sb -side right -fill y - html $w.t -yscrollcommand "$w.sb set" -width 400 -height 150 \ - -bd 2 -relief sunken -padx 5 -pady 5 - pack $w.t -side right -fill both -expand 1 - ::tcltest::update-status -} - -# Change the test description in the control window -# -proc ::tcltest::change-desc {tag desc} { - if {![winfo exists .testinfo]} ::tcltest::mainwin - .testinfo.t clear - .testinfo.t parse $desc\n - set ::tcltest::current $tag -} - -# Update the status line -# -proc ::tcltest::update-status {} { - set v "$::tcltest::passed passed $::tcltest::failed failed " - append v "$::tcltest::total total" - set ::tcltest::status $v -} - -# Wait for the user to press either the pass or failed buttons. -# -proc ::tcltest::user-result {} { - .testinfo.b.pass config -state normal - .testinfo.b.fail config -state normal - update - raise .testinfo - focus .testinfo.b.pass - set ::tcltest::result {} - vwait ::tcltest::result - .testinfo.b.pass config -state disabled - .testinfo.b.fail config -state disabled - return $::tcltest::result -} - -# Called when the user presses either the failed or passed buttons. -# -proc ::tcltest::set-result v { - set ::tcltest::result $v -} - -# Call this routine at the end of all tests -# -proc ::tcltest::testing-complete {} { - ::tcltest::change-desc {} {Testing is now complete} -} - -# Construct an HTML widget to use for testing. -# -proc tkhtml_test_widget {} { - set w .tkhtml_test - if {[winfo exists $w]} { - return $w.h - } - toplevel $w - wm title $w {TkHtml Test Widget} - wm iconname $w {TkHtml Test} - scrollbar $w.sb -orient vertical -command "$w.h yview" - pack $w.sb -side right -fill y - html $w.h -yscrollcommand "$w.sb set" - pack $w.h -side right -fill both -expand 1 - return $w.h -} |