blob: 2739b40784f158be2b4907a42510b7ad75968b5e (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
|
# 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
}
|
