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
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
|
#----------------------------------------------------------------------
# DEFAULT BROWSER CONFIGURATION:
#
# This should be edited for site-specific browsers. On SUSE linux
# the following works:
#
# lappend BROWSERS Firefox {/usr/lib/firefox/firefox-bin}
lappend BROWSERS Firefox {/home/dan/sw/firefox/firefox-bin}
if {![info exists env(LD_LIBRARY_PATH)]} {
set env(LD_LIBRARY_PATH) ""
}
set env(LD_LIBRARY_PATH) $env(LD_LIBRARY_PATH):/home/dan/sw/firefox/
lappend BROWSERS Hv3 {./hwish ../htmlwidget/hv/hv3_main.tcl}
lappend BROWSERS Opera {opera -nosession}
set DEFAULT_BROWSERS [list Hv3 Firefox]
#----------------------------------------------------------------------
# TEST ARCHITECTURE OVERVIEW:
#
# This program is a driver for a browser compatibility test framework.
# In this framework, each test is specified as follows:
#
# A) A single HTML document. The document must contain the
# following element in the head section:
#
# <SCRIPT src="/get_framework"></SCRIPT>
#
# The document should have no other external dependancies. The
# <BODY> element should not have an onLoad event handler defined.
#
# B) The definition of a javascript function called "browser_test".
# For example:
#
# function browser_test () { return document.images.length }
#
#
# A test case is executed as follows:
#
# 1. A web-browser process is started. The browser connects to an
# HTTP server embedded in the test driver (this script) and
# retrieves the test document (A).
#
# 2. The <SCRIPT> tag in the test document causes the browser
# to retrieve a javascript program from the same embedded
# server. The browser_test() function is part of the
# javascript program.
#
# 3. An "onLoad" event on the <BODY> of the test document in the
# browser causes it to execute the browser_test() function.
# The return value of browser_test() is converted to a string
# and an HTTP GET request made to a URI of the form:
#
# /test_result?result=<Result of browser_test()>
#
# 4. Once the above request is seen by the embedded web-server,
# the web-browser process is halted.
#
# Tcl proc [::browsertest::run] implements this procedure.
#
# The above 4 steps should be repeated with 2 or more browsers. The
# strings returned by the browser_test() function are compared to
# determine browser compatibility. Tcl proc [::browser::do_test]
# implements this in terms of [::browsertest::run].
#
#----------------------------------------------------------------------
# INTERFACE:
#
# ::browsertest::run BROWSER TIMEOUT DOCUMENT FUNCTION
#
# The low level interface. Execute a single test-case in a single
# browser instance.
#
#
#
# ::browsertest::do_test NAME OPTIONS
#
# -browsers BROWSER-LIST (default is all configured)
# -html HTML-DOCUMENT-BODY (default is "")
# -timeout TIMEOUT (default is 10000)
# -expected STRING (if not specified do not use)
# -javascript SCRIPT-FUNCTION-BODY (mandatory)
#
# High level interface.
#
namespace eval browsertest {
variable listen_socket "" ;# Socket returned by [socket -server]
variable listen_port "" ;# Port number $listen_socket is listening on.
variable test_document "" ;# Document for a "GET /get_test" request.
variable test_script "" ;# Document for a "GET /get_script" request.
variable test_result "" ;# Value returned by browser_test()
# If the following variable is not set to an empty string, then
# it is a [string match] style pattern applied to the name of each
# test before it is executed. If the test-name does not match
# the pattern, the test will not be executed.
#
# Note that this applies to invocations of [::browsertest::do_test]
# only, [::browsertest::run] will still run anything passed to it.
#
variable pattern ""
proc Init {} {
variable listen_port
variable listen_socket
if {$listen_socket eq ""} {
set cmd [namespace code Accept]
set listen_socket [socket -server $cmd -myaddr 127.0.0.1 0]
set listen_port [lindex [fconfigure $listen_socket -sockname] 2]
}
}
proc Accept {sock host path} {
fconfigure $sock -blocking 0
fileevent $sock readable [namespace code [list Request $sock]]
}
proc HttpResponse {sock content_type content} {
set r ""
append r "HTTP/1.0 200 OK\n"
append r "Content-type: $content_type\n"
append r "\n"
append r "$content"
append r "\n"
puts -nonewline $sock $r
close $sock
}
proc Decode {component} {
set zIn $component
set zOut ""
while {[regexp {^([^%]*)(%..)(.*)$} $zIn -> start esc tail]} {
append zOut $start
set zIn $tail
set hex "0x[string range $esc 1 end]"
append zOut [format %c $hex]
}
append zOut $zIn
return $zOut
}
proc Request {sock} {
variable test_document
variable test_script
variable test_result
set line [gets $sock]
if {[fblocked $sock]} return
if {[eof $sock]} {
close $sock
return
}
if {[regexp {^GET.*get_test} $line]} {
HttpResponse $sock text/html $test_document
} elseif {[regexp {^GET.*get_framework} $line]} {
HttpResponse $sock text/javascript $test_script
} elseif {[regexp {^GET.*test_result.result=([^ ]*)} $line -> result]} {
set test_result [Decode $result]
close $sock
} elseif {[regexp {^GET.*} $line]} {
close $sock
}
}
# run --
#
# run BROWSER TIMEOUT DOCUMENT FUNCTION
#
proc run {browser timeout document function} {
variable listen_port
variable test_document
variable test_script
variable test_result
# Set up the listening socket (if it is not already ready)
Init
# Set the global variable $test_document. This is the content that
# will be returned to a request on the /get_test URI.
#
set test_document $document
# Set up the script infrastructure:
set test_script $function
append test_script "\n"
append test_script {
function run_browser_test() {
result = browser_test().toString()
enc_result = encodeURIComponent(result);
req = new XMLHttpRequest()
req.open("GET", "/test_result?result=" + enc_result)
req.send("")
}
window.onload = run_browser_test
}
# If the specified browser is not in the global $::BROWSERS array,
# raise a Tcl exception.
#
array set b $::BROWSERS
if {![info exists b($browser)]} {
error "No such configured browser: $browser"
}
# [exec] the browser. Load the /get_test URI initially.
#
after 500
set doc_uri "http://127.0.0.1:$listen_port/get_test"
set pid [eval exec $b($browser) [list $doc_uri] &]
set timeout_msg "BROWSER TIMEOUT ($timeout ms)"
set afterscript [list set [namespace current]::test_result $timeout_msg]
after $timeout $afterscript
set test_result ""
vwait [namespace current]::test_result
after cancel $afterscript
# [kill] the browser process.
#
exec kill $pid
return $test_result
}
proc do_test {name args} {
variable pattern
if {$pattern ne "" && ![string match $pattern $name]} return
# Argument processing:
#
set opts(-browsers) $::DEFAULT_BROWSERS
set opts(-timeout) 10000
set opts(-html) ""
array set opts $args
if {![info exists opts(-javascript)]} {
error "Missing mandatory -javascript option"
}
foreach option [array names opts] {
switch -- $option {
-browsers {}
-timeout {}
-html {}
-javascript {}
-expected {set results(Expected) $opts(-expected)}
default {
error "Unknown option: $option"
}
}
}
puts -nonewline "$name ."
flush stdout
# Figure out the complete HTML test document
#
set html {<HTML><HEAD><SCRIPT src="/get_framework"></SCRIPT></HEAD>}
append html $opts(-html)
# Figure out the complete javascript test function
#
set javascript "function browser_test () {\n"
append javascript $opts(-javascript)
append javascript "\n}\n"
foreach browser $opts(-browsers) {
set res [run $browser $opts(-timeout) $html $javascript]
set results($browser) $res
puts -nonewline "."
flush stdout
}
set ok 1
foreach browser [array names results] {
if {$results($browser) ne $res} {set ok 0}
}
if {$ok} {
puts " Ok ($opts(-browsers))"
} else {
puts " Error:"
foreach browser [lsort [array names results]] {
puts [format { %-10s {%s}} ${browser}: $results($browser)]
}
}
}
}
proc usage {} {
puts stderr "Usage: "
puts stderr " $::argv0 ?PATTERN?"
exit
}
proc main {args} {
if {[llength $args] > 1} usage
set ::browsertest::pattern [lindex $args 0]
source [file join [file dirname [info script]] tree1.bt]
source [file join [file dirname [info script]] node.bt]
source [file join [file dirname [info script]] events.bt]
source [file join [file dirname [info script]] style.bt]
source [file join [file dirname [info script]] form.bt]
}
eval main $argv
|
