← Back to branch summary

~ubuntu-branches/debian/sid/tk-html3/sid

« back to all changes in this revision

Viewing changes to tests/engine.tcl

  • Committer: Package Import Robot
  • Author(s): Ole Streicher
  • Date: 2012-03-02 18:45:00 UTC
  • Revision ID: package-import@ubuntu.com-20120302184500-np17d7d6gd1jedj0
Tags: upstream-3.0~fossil20110109
Import upstream version 3.0~fossil20110109

Show diffs side-by-side

added added

removed removed

Lines of Context:
tests/engine.tcl
 
1
# This file contains the test driver for the html widget.  It defines
 
2
# a special version of the test procedure to use for testing the
 
3
# html widget.
 
4
#
 
5
 
 
6
# $Id: engine.tcl,v 1.2 2003/01/28 05:01:05 hkoba Exp $
 
7
 
 
8
# Make sure the html widget is loaded into
 
9
# our interpreter
 
10
#
 
11
if {[info command html]==""} {
 
12
  if {[catch {package require Tkhtml} error]} {
 
13
    foreach f {
 
14
      ./libTkhtml*.so
 
15
      ../libTkhtml*.so
 
16
      /usr/lib/libTkhtml*.so
 
17
      /usr/local/lib/libTkhtml*.so
 
18
      ./tkhtml.dll
 
19
    } {
 
20
      if {[set f [lindex [glob -nocomplain $f] end]] != ""} {
 
21
        if {[catch {load $f Tkhtml}]==0} break
 
22
      }
 
23
    }
 
24
  }
 
25
}
 
26
 
 
27
# Initialize variables
 
28
#
 
29
namespace eval tcltest {
 
30
  set mode run
 
31
  set current {}
 
32
  set passed 0
 
33
  set failed 0
 
34
  set total 0
 
35
  set status {}
 
36
}
 
37
 
 
38
# Arguments:
 
39
#
 
40
#   tag      A symbolic tag for this test.  Ex:  html-1.0
 
41
#
 
42
#   desc     A human-readable description of what this test does.
 
43
#
 
44
#   script   Tcl code to implement the test
 
45
#
 
46
#   result   The expected result from this test.  If the actual result
 
47
#            is different the test fails.
 
48
#
 
49
proc ::tcltest::test {tag desc script result} {
 
50
  ::tcltest::change-desc $tag $desc
 
51
  if {[info exists ::tcltest::idle]} {
 
52
    catch {after cancel $::tcltest::idle}
 
53
    catch {unset ::tcltest::idle}
 
54
  }
 
55
  set rc [catch {uplevel #0 $script} msg]
 
56
  set r [list $rc $msg]
 
57
  if {$r==$result} {
 
58
    incr ::tcltest::passed
 
59
    puts "---- Test $tag passed"
 
60
  } else {
 
61
    incr ::tcltest::failed
 
62
    puts "**** Test $tag failed"
 
63
    puts "Expected: [list $result]"
 
64
    puts "Got: [list $r]"
 
65
  }
 
66
  incr ::tcltest::total
 
67
  ::tcltest::update-status
 
68
  set ::tcltest::idle [after 100 ::tcltest::testing-complete]
 
69
}
 
70
 
 
71
# Create the test control window
 
72
#
 
73
proc ::tcltest::mainwin {} {
 
74
  set w .testinfo
 
75
  toplevel $w
 
76
  wm title $w {Html Widget Test Information}
 
77
  wm iconname $w {Html-Test}
 
78
  set f $w.f1
 
79
  frame $f
 
80
  pack $f -side top -fill x
 
81
  label $f.l -text {Status: }
 
82
  label $f.v -textvariable ::tcltest::status
 
83
  pack $f.l $f.v -side left
 
84
  set f $w.f2
 
85
  frame $f
 
86
  pack $f -side top -fill x
 
87
  label $f.l -text {Current Test: }
 
88
  label $f.v -textvariable ::tcltest::current
 
89
  pack $f.l $f.v -side left
 
90
  set f $w.b
 
91
  frame $f
 
92
  pack $f -side bottom -fill x
 
93
  button $f.pause -text Pause -command ::tcltest::pause
 
94
  button $f.pass -text {Pass} -command {::tcltest::set-result pass}
 
95
  button $f.fail -text {Fail} -command {::tcltest::set-result fail}
 
96
  button $f.exit -text Exit -command exit
 
97
  pack $f.pause $f.pass $f.fail $f.exit -side right -pady 10 -expand 1
 
98
  scrollbar $w.sb -orient vertical -command "$w.t yview"
 
99
  pack $w.sb -side right -fill y
 
100
  html $w.t -yscrollcommand "$w.sb set" -width 400 -height 150 \
 
101
     -bd 2 -relief sunken -padx 5 -pady 5
 
102
  pack $w.t -side right -fill both -expand 1 
 
103
  ::tcltest::update-status
 
104
}
 
105
 
 
106
# Change the test description in the control window
 
107
#
 
108
proc ::tcltest::change-desc {tag desc} {
 
109
  if {![winfo exists .testinfo]} ::tcltest::mainwin
 
110
  .testinfo.t clear
 
111
  .testinfo.t parse $desc\n
 
112
  set ::tcltest::current $tag
 
113
}
 
114
 
 
115
# Update the status line
 
116
#
 
117
proc ::tcltest::update-status {} {
 
118
  set v "$::tcltest::passed passed  $::tcltest::failed failed  "
 
119
  append v "$::tcltest::total total"
 
120
  set ::tcltest::status $v
 
121
}
 
122
 
 
123
# Wait for the user to press either the pass or failed buttons.
 
124
#
 
125
proc ::tcltest::user-result {} {
 
126
  .testinfo.b.pass config -state normal
 
127
  .testinfo.b.fail config -state normal
 
128
  update
 
129
  raise .testinfo
 
130
  focus .testinfo.b.pass
 
131
  set ::tcltest::result {}
 
132
  vwait ::tcltest::result
 
133
  .testinfo.b.pass config -state disabled
 
134
  .testinfo.b.fail config -state disabled
 
135
  return $::tcltest::result
 
136
}
 
137
 
 
138
# Called when the user presses either the failed or passed buttons.
 
139
#
 
140
proc ::tcltest::set-result v {
 
141
  set ::tcltest::result $v
 
142
}
 
143
 
 
144
# Call this routine at the end of all tests
 
145
#
 
146
proc ::tcltest::testing-complete {} {
 
147
  ::tcltest::change-desc {} {Testing is now complete}
 
148
}
 
149
 
 
150
# Construct an HTML widget to use for testing.
 
151
#
 
152
proc tkhtml_test_widget {} {
 
153
  set w .tkhtml_test
 
154
  if {[winfo exists $w]} {
 
155
    return $w.h
 
156
  }
 
157
  toplevel $w
 
158
  wm title $w {TkHtml Test Widget}
 
159
  wm iconname $w {TkHtml Test}
 
160
  scrollbar $w.sb -orient vertical -command "$w.h yview"
 
161
  pack $w.sb -side right -fill y
 
162
  html $w.h -yscrollcommand "$w.sb set"
 
163
  pack $w.h -side right -fill both -expand 1
 
164
  return $w.h
 
165
}