File: engine.tcl

package info (click to toggle)
tk-html3 3.0~fossil20110109-6
  • links: PTS, VCS
  • area: main
  • in suites: stretch
  • size: 6,644 kB
  • ctags: 5,882
  • sloc: ansic: 48,994; tcl: 26,030; sh: 1,190; yacc: 161; makefile: 24
file content (165 lines) | stat: -rw-r--r-- 4,318 bytes parent folder | download | duplicates (5)
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
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
# 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.
#

# $Id: engine.tcl,v 1.2 2003/01/28 05:01:05 hkoba Exp $

# Make sure the html widget is loaded into
# our interpreter
#
if {[info command html]==""} {
  if {[catch {package require Tkhtml} error]} {
    foreach f {
      ./libTkhtml*.so
      ../libTkhtml*.so
      /usr/lib/libTkhtml*.so
      /usr/local/lib/libTkhtml*.so
      ./tkhtml.dll
    } {
      if {[set f [lindex [glob -nocomplain $f] end]] != ""} {
        if {[catch {load $f Tkhtml}]==0} break
      }
    }
  }
}

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