File: tst_main.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 (228 lines) | stat: -rw-r--r-- 6,539 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
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