1# Some constants 2set modeFile 0x01 3set modeBin 0x02 4set modeUU 0x04 5set modeFileStr "File IO" 6set modeBinStr "Binary IO" 7set modeUUStr "UUencoded IO" 8 9# The list of file formats to be tested. 10# First entry specifies the file extension used to create the image filenames. 11# Second entry specifies the image format name as used by the Img extension. 12# Third entry specifies optional format options. 13 14set fmtList [list \ 15 [list ".bmp" "bmp" ""] \ 16 [list ".gif" "gif" ""] \ 17 [list ".ico" "ico" ""] \ 18 [list ".jpg" "jpeg" ""] \ 19 [list ".pcx" "pcx" ""] \ 20 [list ".png" "png" ""] \ 21 [list ".ppm" "ppm" ""] \ 22 [list ".raw" "raw" "-useheader true -nomap true -nchan 3"] \ 23 [list ".rgb" "sgi" ""] \ 24 [list ".ras" "sun" ""] \ 25 [list ".tga" "tga" ""] \ 26 [list ".tif" "tiff" ""] \ 27 [list ".xbm" "xbm" ""] \ 28 [list ".xpm" "xpm" ""] ] 29 30 31# Load image data directly from a file into a photo image. 32# Uses commands: image create photo -file "fileName" 33proc readPhotoFile1 { name fmt } { 34 PN "File read 1: " 35 36 set sTime [clock clicks -milliseconds] 37 set retVal [catch {image create photo -file $name} ph] 38 if { $retVal != 0 } { 39 P "\n\tWarning: Cannot detect image file format. Trying again with -format." 40 P "\tError message: $ph" 41 set retVal [catch {image create photo -file $name -format $fmt} ph] 42 if { $retVal != 0 } { 43 P "\tERROR: Cannot read image file with format option $fmt" 44 P "\tError message: $ph" 45 return "" 46 } 47 } 48 set eTime [clock clicks -milliseconds] 49 PN "[format "%.2f " [expr ($eTime - $sTime) / 1.0E3]]" 50 return $ph 51} 52 53# Load image data directly from a file into a photo image. 54# Uses commands: set ph [image create photo] ; $ph read "fileName" 55# args maybe "-from ..." and/or "-to ..." option. 56proc readPhotoFile2 { name fmt width height args } { 57 PN "File read 2: " 58 59 set sTime [clock clicks -milliseconds] 60 if { $width < 0 && $height < 0 } { 61 set ph [image create photo] 62 } else { 63 set ph [image create photo -width $width -height $height] 64 } 65 set retVal [catch {eval {$ph read $name} $args} errMsg] 66 if { $retVal != 0 } { 67 P "\n\tWarning: Cannot detect image file format. Trying again with -format." 68 P "\tError message: $errMsg" 69 set retVal [catch {eval {$ph read $name -format $fmt} $args} errMsg] 70 if { $retVal != 0 } { 71 P "\tERROR: Cannot read image file with format option $fmt" 72 P "\tError message: $errMsg" 73 return "" 74 } 75 } 76 set eTime [clock clicks -milliseconds] 77 PN "[format "%.2f " [expr ($eTime - $sTime) / 1.0E3]]" 78 return $ph 79} 80 81# Load binary image data from a variable into a photo image. 82# Uses commands: image create photo -data $imgData 83proc readPhotoBinary1 { name fmt args } { 84 PN "Binary read 1: " 85 86 set sTime [clock clicks -milliseconds] 87 set retVal [catch {open $name r} fp] 88 if { $retVal != 0 } { 89 P "\n\tERROR: Cannot open image file $name for binary reading." 90 return "" 91 } 92 fconfigure $fp -translation binary 93 set imgData [read $fp [file size $name]] 94 close $fp 95 96 set retVal [catch {image create photo -data $imgData} ph] 97 if { $retVal != 0 } { 98 P "\n\tWarning: Cannot detect image file format. Trying again with -format." 99 P "\tError message: $ph" 100 set retVal [catch {image create photo -data $imgData -format $fmt} ph] 101 if { $retVal != 0 } { 102 P "\tERROR: Cannot create photo from binary image data." 103 P "\tError message: $ph" 104 return "" 105 } 106 } 107 set eTime [clock clicks -milliseconds] 108 PN "[format "%.2f " [expr ($eTime - $sTime) / 1.0E3]]" 109 return $ph 110} 111 112# Load binary image data from a variable into a photo image. 113# Uses commands: set ph [image create photo] ; $ph put $imgData 114# args maybe "-to ..." option. 115proc readPhotoBinary2 { name fmt width height args } { 116 PN "Binary read 2: " 117 118 set sTime [clock clicks -milliseconds] 119 set retVal [catch {open $name r} fp] 120 if { $retVal != 0 } { 121 P "\n\tERROR: Cannot open image file $name for binary reading." 122 return "" 123 } 124 fconfigure $fp -translation binary 125 set imgData [read $fp [file size $name]] 126 close $fp 127 128 if { $width < 0 && $height < 0 } { 129 set ph [image create photo] 130 } else { 131 set ph [image create photo -width $width -height $height] 132 } 133 set retVal [catch {eval {$ph put $imgData} $args} errMsg] 134 if { $retVal != 0 } { 135 P "\n\tWarning: Cannot detect image file format. Trying again with -format." 136 P "\tError message: $errMsg" 137 set retVal [catch {eval {$ph put $imgData -format $fmt} $args} errMsg] 138 if { $retVal != 0 } { 139 P "\tERROR: Cannot create photo from binary image data." 140 P "\tError message: $errMsg" 141 return "" 142 } 143 } 144 set eTime [clock clicks -milliseconds] 145 PN "[format "%.2f " [expr ($eTime - $sTime) / 1.0E3]]" 146 return $ph 147} 148 149# Load uuencoded image data from a variable into a photo image. 150# Uses commands: set ph [image create photo] ; $ph put $imgData 151proc readPhotoString { str fmt width height args } { 152 PN "String read: " 153 154 set sTime [clock clicks -milliseconds] 155 if { $width < 0 && $height < 0 } { 156 set ph [image create photo] 157 } else { 158 set ph [image create photo -width $width -height $height] 159 } 160 set retVal [catch {eval {$ph put $str} $args}] 161 if { $retVal != 0 } { 162 P "\n\tWarning: Cannot detect image string format. Trying again with -format." 163 set retVal [catch {eval {$ph put $str -format $fmt} $args}] 164 if { $retVal != 0 } { 165 P "\tERROR: Cannot read image string with format option: $fmt" 166 return "" 167 } 168 } 169 set eTime [clock clicks -milliseconds] 170 PN "[format "%.2f " [expr ($eTime - $sTime) / 1.0E3]]" 171 return $ph 172} 173 174proc writePhotoFile { ph name fmt del args } { 175 PN "File write: " 176 177 set sTime [clock clicks -milliseconds] 178 set retVal [catch {eval {$ph write $name -format $fmt} $args} str] 179 set eTime [clock clicks -milliseconds] 180 181 if { $retVal != 0 } { 182 P "\n\tERROR: Cannot write image file $name (Format: $fmt)" 183 P "\tError message: $str" 184 return "" 185 } 186 if { $del } { 187 image delete $ph 188 } 189 PN "[format "%.2f " [expr ($eTime - $sTime) / 1.0E3]]" 190 return $str 191} 192 193proc writePhotoString { ph fmt del args } { 194 PN "String write: " 195 196 set sTime [clock clicks -milliseconds] 197 set retVal [catch {eval {$ph data -format $fmt} $args} str] 198 set eTime [clock clicks -milliseconds] 199 if { $retVal != 0 } { 200 P "\n\tERROR: Cannot write image to string (Format: $fmt)" 201 P "\tError message: $str" 202 return "" 203 } 204 if { $del } { 205 image delete $ph 206 } 207 PN "[format "%.2f " [expr ($eTime - $sTime) / 1.0E3]]" 208 return $str 209} 210 211proc createErrImg {} { 212 set retVal [catch {image create photo -data [unsupportedImg]} errImg] 213 if { $retVal != 0 } { 214 P "FATAL ERROR: Cannot load uuencode GIF image into canvas." 215 P " Test will be cancelled." 216 exit 1 217 } 218 return $errImg 219} 220 221proc getCanvasPhoto { canvId } { 222 PN "Canvas photo: " 223 set sTime [clock clicks -milliseconds] 224 set retVal [catch {image create photo -format window -data $canvId} ph] 225 set eTime [clock clicks -milliseconds] 226 if { $retVal != 0 } { 227 P "\n\tFATAL ERROR: Cannot create photo from canvas window" 228 exit 1 229 } 230 P "[format "%.2f secs" [expr ($eTime - $sTime) / 1.0E3]]" 231 return $ph 232} 233 234proc delayedUpdate {} { 235 update 236 after 200 237} 238 239proc drawInfo { x y color font } { 240 set size 10 241 set tx [expr $x + $size * 2] 242 .t.c create rectangle $x $y [expr $x + $size] [expr $y + $size] -fill $color 243 .t.c create text $tx $y -anchor nw -fill black -text "$color box" -font $font 244 delayedUpdate 245} 246 247proc drawTestCanvas { imgVersion} { 248 toplevel .t 249 wm title .t "Canvas window" 250 wm geometry .t "+0+30" 251 252 canvas .t.c -bg gray -width 240 -height 220 253 pack .t.c 254 255 P "Loading uuencoded GIF image into canvas .." 256 set retVal [catch {image create photo -data [pwrdLogo]} phImg] 257 if { $retVal != 0 } { 258 P "FATAL ERROR: Cannot load uuencode GIF image into canvas." 259 P " Test will be cancelled." 260 exit 1 261 } 262 263 .t.c create image 0 0 -anchor nw -tags MyImage 264 .t.c itemconfigure MyImage -image $phImg 265 266 P "Drawing text and rectangles into canvas .." 267 .t.c create rectangle 1 1 239 219 -outline black 268 .t.c create rectangle 3 3 237 217 -outline green -width 2 269 delayedUpdate 270 271 set font {-family {Courier} -size 9} 272 273 drawInfo 140 10 black $font 274 drawInfo 140 30 white $font 275 drawInfo 140 50 red $font 276 drawInfo 140 70 green $font 277 drawInfo 140 90 blue $font 278 drawInfo 140 110 cyan $font 279 drawInfo 140 130 magenta $font 280 drawInfo 140 150 yellow $font 281 282 .t.c create text 140 170 -anchor nw -fill black -text "Created with:" -font $font 283 delayedUpdate 284 .t.c create text 140 185 -anchor nw -fill black -text "Tcl [info patchlevel]" -font $font 285 .t.c create text 140 200 -anchor nw -fill black -text "Img $imgVersion" -font $font 286 update 287} 288