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
|
# Usage message. This is printed to standard error if the script
# is invoked incorrectly.
#
set ::usage [string trim [subst {
Usage: $argv0 OPTIONS
Options are:
-dir <test-dir>
-cache <cache-file>
-pattern <glob-pattern>
}]]
# Load required packages. As well as Tk and Tkhtml this script needs
# Img (to do image compression, otherwise the images are all very large
# blobs) and sqlite3 (to store saved images in a database file).
#
if {[info exists auto_path]} {
set auto_path [concat . $auto_path]
}
package require Tk
package require Tkhtml 3.0
package require Img
package require sqlite3
# Load hv3 to do the rendering
source [file join [file dirname [info script]] hv3.tcl]
#--------------------------------------------------------------------------
# A little database API for use within this app. This API serves to
# encapsulate the use of SQLite:
#
# dbInit
# dbRetrieve
# dbStore
# dbClose
#
proc dbInit {filename} {
for {set n 0} {[llength [info commands hv3_db_$n]]>0} {incr n} {}
set db "hv3_db_$n"
sqlite3 $db $filename
catch {
$db eval {CREATE TABLE hv3_images(url TEXT PRIMARY KEY, image BLOB)}
}
return $db
}
proc dbRetrieve {db url} {
$db onecolumn {SELECT image FROM hv3_images WHERE url = $url}
}
proc dbStore {db url data} {
$db eval {REPLACE INTO hv3_images(url, image) VALUES($url, $data)}
}
proc dbClose {db} {
$db close
}
#--------------------------------------------------------------------------
# This proc uses the hv3 object $hv3 to render the document at URL
# $url. It then creates an image from the rendered document and returns
# the binary image data.
#
proc snapshot {hv3 url} {
# Use a temp file to write the image data to instead of returning
# it directly to Tcl. For whatever reason, this seems to be about
# thirty percent faster.
set tmp_file_name "/tmp/tst_hv3[pid].jpeg"
# Load the document at $url into .hv3
hv3Goto $hv3 $url
# This block sets variable $data to contain the binary image data
# for the rendered document - via a Tk image and temp file entry.
set img [${hv3}.html image]
$img write $tmp_file_name -format jpeg
image delete $img
set fd [open $tmp_file_name]
fconfigure $fd -encoding binary -translation binary
set data [read $fd]
close $fd
file delete -force $tmp_file_name
# Return the image data.
return $data
}
# Create an hv3 object. Configure the width of the html window to 800
# pixels. Because the .hv3 object will never actually be packed into
# the gui, the configured width is used as the viewport width by the
# [.hv3.html image] command. (If .hv3 were packed, then the actual
# viewport width would be used instead.)
#
hv3Init .hv3
.hv3.html configure -width 800
# Create the application gui:
#
# .main -> frame
# .main.canvas -> canvas widget
# .main.vsb -> vertical scrollbar for canvas widget
#
# .control -> frame
# .control.displayold -> button
# .control.displaynew -> button
# .control.copynewtodb -> button
# .control.next -> button
#
frame .main
canvas .main.canvas
scrollbar .main.vsb
.main.canvas configure -width 800 -height 600 -yscrollcommand ".main.vsb set"
.main.vsb configure -command ".main.canvas yview" -orient vertical
pack .main.canvas -fill both -expand true -side left
pack .main.vsb -fill y -expand true
pack .main -fill both -expand true
frame .control
foreach {b t} [list \
displayold "Display Old" \
displaynew "Display New" \
copynewtodb "Copy New Image to Db" \
skip "Skip to next test" \
] {
button .control.$b
.control.$b configure -command [list click $b]
.control.$b configure -text $t
pack .control.$b -side left -expand true -fill x
}
pack .control -fill x -expand true
# This proc is called when one of the buttons is clicked. The argument
# is the unqualified name of the widget (i.e. "displayold").
#
proc click {b} {
switch -- $b {
displayold {
.main.canvas itemconfigure oldimage -state normal
.main.canvas itemconfigure newimage -state hidden
.control.displayold configure -state disabled
.control.displaynew configure -state normal
}
displaynew {
.main.canvas itemconfigure oldimage -state hidden
.main.canvas itemconfigure newimage -state normal
.control.displaynew configure -state disabled
if {[llength [info commands oldimage]]>0} {
.control.displayold configure -state normal
} else {
.control.displayold configure -state disabled
}
}
copynewtodb {
set ::continue 2
}
skip {
set ::continue 1
}
}
}
proc do_image_test {db url} {
# Create a snapshot of the URL.
set newdata [snapshot .hv3 $url]
# Retrieve the cached version, if any
set olddata [dbRetrieve $db $url]
# If the cached data matches the new snapshot, there is no need for
# user interaction. Just print a message to stdout to say we're happy
# with this rendering.
if {$newdata==$olddata} {
puts "SUCCESS $url"
return
}
.control.skip configure -state normal
.control.copynewtodb configure -state normal
.control.displayold configure -state normal
.control.displaynew configure -state normal
image create photo newimage -data $newdata
.main.canvas create image 0 0 -image newimage -anchor nw -tag newimage
if {$olddata!={}} {
image create photo oldimage -data $olddata
.main.canvas create image 0 0 -image oldimage -anchor nw -tag oldimage
}
set dim [.main.canvas bbox all]
.main.canvas configure -scrollregion $dim
.control.displaynew invoke
set ::continue 0
vwait ::continue
if {$::continue==2} {
puts "SUCCESS $url"
dbStore $db $url $newdata
} else {
puts "FAILURE $url"
}
image delete newimage
catch { image delete oldimage }
}
swproc main_args {{cache {}} {dir {}} {pattern *.htm}} {
if {$cache=={}} {
error "Error: Required -cache option not specified"
}
if {$dir=={}} {
error "Error: Required -dir option not specified"
}
set dir [file normalize $dir]
uplevel [list set cache $cache]
uplevel [list set dir $dir]
uplevel [list set pattern $pattern]
}
proc main {argv} {
if {[catch {eval main_args $argv} msg]} {
puts stderr $msg
puts stderr $::usage
exit -1
}
set db [dbInit $cache]
set url_list [lsort [glob [file join $dir $pattern]]]
foreach url $url_list {
do_image_test $db $url
}
}
main $argv
|