File: image.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 (324 lines) | stat: -rw-r--r-- 8,772 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
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
324

catch {memory init on}

proc usage {} {
  set prog $::argv0

  puts stderr [subst {
    $prog <html-document1> ?<html-document2>....?
    $prog -file <filename>

This program renders html documents to jpeg images. If the second syntax
above is used, then <filename> must be the name of a text file containing
the names of one or more html document files, each seperated by a newline
character. Otherwise the documents rendered are those specified directly on
the command line.

When invoked, the TKHTML_TESTDIR environment variable must be set to the
name of a directory. This directory is used by the program to store images
previously rendered. The idea is that if the user has previously inspected
and approved of the rendering of a document, then the image is saved and
may be used to verify rendering of the same document at a later stage.
Thus, automated test suites for the layout engine may be accomplished. It's
unfortunate that moving caches between machines etc. will probably generate
false-negatives, due to differences in font configuration.

}]

  exit -1
}

set IMGFMT bmp

# Load Tkhtml and if possible the Img package. The Img package is required
# for most image files formats used by web documents. Also to write jpeg
# files.
#
set auto_path [concat . $auto_path]
package require Tkhtml
catch {
  package require Img
}


# Set the global variable ::TESTDIR to the value of the cache directory. If
# the environment variable is not set, invoke the usage message proc.
#
if {![info exists env(TKHTML_TESTDIR)]}       usage
if {![file isdirectory $env(TKHTML_TESTDIR)]} usage
set TESTDIR $env(TKHTML_TESTDIR)

proc shift {listvar} {
  upvar $listvar l
  set ret [lindex $l 0]
  set l [lrange $l 1 end]
  return $ret
}

# Procedure to return the contents of a file-system entry
proc readFile {fname} {
  set ret {}
  catch {
    set fd [open $fname]
    set ret [read $fd]
    close $fd
  }
  return $ret
}

# Procedure to handle text inside a <style> tag.
proc stylecmd {style} {
  append ::STYLE_TEXT $style
  append ::STYLE_TEXT "\n"
  return ""
}

# Procedure to handle a <link> tag that imports a stylesheet.
proc linkcmd {node} {
  set rel [string tolower [$node attr rel]]
  set media [string tolower [$node attr media]]
  set media_list [list all visual screen ""]
  if {[string compare $rel stylesheet]==0 && [lsearch $media_list $media]!=-1} {
    set href [$node attr href]
    set filename [file join $::BASE $href]
    lappend ::STYLESHEET_FILES $filename
  }
}

# Procedure to handle the <title> tag.
proc titlecmd {title} {
  wm title . [string trim $title]
}

proc load_document {css document} {

  set ::STYLESHEET_FILES {}
  set ::STYLE_TEXT {}
  set parsetime [time {
      $::HTML internal parse $document
      $::HTML internal parsefinal
      $::HTML style parse agent $css
      while {[llength $::STYLESHEET_FILES]>0} {
        set ss [lindex $::STYLESHEET_FILES 0]
        set ::STYLESHEET_FILES [lrange $::STYLESHEET_FILES 1 end]
        $::HTML style parse author [readFile $ss]
      }
      $::HTML style parse author $::STYLE_TEXT
  }]

  $::HTML style parse author.1 { 
    img    { -tkhtml-replace: tcl(replace_img) }
    object { -tkhtml-replace: tcl(replace_img) }
    input  { -tkhtml-replace: tcl(replace_input) }
    select { -tkhtml-replace: tcl(replace_select) }
  }

  set styletime [time {
      $::HTML style apply
  }]
  puts -nonewline "Parse [lrange $parsetime 0 1] Style [lrange $styletime 0 1]"
}

# Procedure to handle <input> and <object> tags.
proc replace_img {node} {
  if {[$node tag]=="object"} {
    set filename [file join $::BASE [$node attr data]]
  } else {
    set filename [file join $::BASE [$node attr src]]
  }
  if [catch { set img [image create photo -file $filename] } msg] {
    # puts "Error: $msg"
    error $msg
  } 
  return $img
}

# Procedure to handle <input> tags.
set CONTROL 0
proc replace_input {node} {
  set tkname ".control[incr ::CONTROL]"
  set width [$node attr width]
  if {$width==""} {
    set width 20
  }

  switch -exact [$node attr type] {
    image {
      return [replace_img $node]
    }
    hidden {
      return ""
    }
    checkbox {
      return [checkbutton $tkname]
    }
    radio {
      return [checkbutton $tkname]
    }
    submit {
      return [button $tkname -text Submit]
    }
    default {
      entry $tkname -width $width
      return $tkname
    }
  }
  return ""
}

# Procedure to handle <select> tags
proc replace_select {node} {
  set tkname ".control[incr ::CONTROL]"
  button $tkname -text Select
  return $tkname
}

proc docname_to_imgname {docname} {
  file join $::TESTDIR [string map {{ } _ / _} [file tail $docname]].$::IMGFMT
}
proc docname_to_primname {docname} {
  return [file join $::TESTDIR [string map {{ } _ / _} $docname].primitives]
}

proc compare_document_image {docname} {
  $::HTML layout force -width 800
  set layouttime [time {set img [$::HTML layout image]}]
  puts " Layout [lrange $layouttime 0 1]"
  set filename [docname_to_imgname $docname]
  $img write tmp.$::IMGFMT -format $::IMGFMT
  image delete $img

  set data [readFile tmp.$::IMGFMT]
  set data2 [readFile $filename]
  if {$data2==""} {
    return NOIMAGE
  }
  if {$data2==$data} {
    return MATCH
  }
  return NOMATCH
}

proc correct {docname img} {
  set filename [docname_to_imgname $docname]
  catch {
    file delete -force $filename
  }
  $img write $filename -format $::IMGFMT
  set ::CONTINUEFLAG 1
}
proc incorrect {docname img} {
  set filename [docname_to_primname $docname]
  set fd [open $filename w]
  puts $fd [join [$::HTML layout primitives] "\n"]
  close $fd
  set ::CONTINUEFLAG 1
}

wm geometry . 800x600

set ::HTML [html .h]
$::HTML handler script script dummycmd
$::HTML handler script style stylecmd
$::HTML handler script title titlecmd
$::HTML handler node link linkcmd

if {[lindex $argv 0]=="-file"} {
  set fname [lindex $argv 1]
  set fdir [file dirname $fname]
  set fd [open $fname]
  set ::DOCUMENT_LIST {}
  while {![eof $fd]} {
    set doc [gets $fd]
    if {$doc!="" && ![regexp {^ *#} $doc]} {
      lappend ::DOCUMENT_LIST [file join $fdir $doc]
    }
  }
  close $fd
} else {
  set ::DOCUMENT_LIST $argv
}
set ::DEFAULT_CSS [readFile [file join [file dirname [info script]] html.css]]

frame .buttons
button .buttons.correct    -text Correct
button .buttons.incorrect  -text Incorrect
button .buttons.oldimage  -text {Old Image}
button .buttons.newimage  -text {New Image}

pack .buttons.correct .buttons.incorrect -side left
pack .buttons.oldimage .buttons.newimage -side right
pack .buttons -side bottom -fill x

scrollbar .s -orient vertical
scrollbar .s2 -orient horizontal
canvas .c -background white
pack .s -side right -fill y
pack .s2 -side bottom -fill x
pack .c -fill both -expand true

.c configure -yscrollcommand {.s set}
.c configure -xscrollcommand {.s2 set}
.s configure -command {.c yview}
.s2 configure -command {.c xview}

bind .c <KeyPress-Down> {.c yview scroll 1 units} 
bind .c <KeyPress-Up> {.c yview scroll -1 units} 
focus .c

foreach document $::DOCUMENT_LIST {
  set ::BASE [file dirname $document]
  load_document $::DEFAULT_CSS [readFile $document]
  set res [compare_document_image $document]

  if {$res=="MATCH"} {
      puts "$document - MATCH"
  }
  if {$res=="NOIMAGE"} {
      .c delete all
      set img [$::HTML layout image]
      .c create image 0 0 -anchor nw -image $img
      catch {
        .c configure -scrollregion [.c bbox all]
      }
      .buttons.correct configure -command "correct $document $img"
      .buttons.incorrect configure -command "incorrect $document $img"
      .buttons.oldimage configure -state disabled
      .buttons.newimage configure -state disabled
      vwait ::CONTINUEFLAG

      .c delete all
      image delete $img
  }
  if {$res=="NOMATCH"} {
      set img [$::HTML layout image]
      set imgold [image create photo -file [docname_to_imgname $document]]

      .c delete all
      .c create image 0 0 -anchor nw -image $img
      catch { .c configure -scrollregion [.c bbox all] }

      .buttons.correct configure -command "correct $document $img"
      .buttons.incorrect configure -command "incorrect $document $img"
      .buttons.oldimage configure -state normal -command [subst -nocommands {
         .c delete all
         .c create image 0 0 -anchor nw -image $imgold
         catch { .c configure -scrollregion [.c bbox all] }
      }]
      .buttons.newimage configure -state normal -command [subst -nocommands {
         .c delete all
         .c create image 0 0 -anchor nw -image $img
         catch { .c configure -scrollregion [.c bbox all] }
      }]
      vwait ::CONTINUEFLAG
      .c delete all
      image delete $img
      image delete $imgold
  }

  $::HTML internal reset
}

rename $::HTML {}
exit