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    set retVal [catch {image create photo -format window -data $canvId} ph]
223    if { $retVal != 0 } {
224	P "\n\tFATAL ERROR: Cannot create photo from canvas window"
225	exit 1
226    }
227    return $ph
228}
229
230proc delayedUpdate {} {
231    update
232    after 200
233}
234
235proc drawInfo { x y color font } {
236    set size 10
237    set tx [expr $x + $size * 2]
238    .t.c create rectangle $x $y [expr $x + $size] [expr $y + $size] -fill $color
239    .t.c create text $tx $y -anchor nw -fill black -text "$color box" -font $font
240    delayedUpdate
241}
242
243proc drawTestCanvas { imgVersion} {
244    toplevel .t
245    wm title .t "Canvas window"
246    wm geometry .t "+0+30"
247
248    canvas .t.c -bg gray -width 240 -height 220
249    pack .t.c
250
251    P "Loading uuencoded GIF image into canvas .."
252    set retVal [catch {image create photo -data [pwrdLogo]} phImg]
253    if { $retVal != 0 } {
254	P "FATAL ERROR: Cannot load uuencode GIF image into canvas."
255	P "             Test will be cancelled."
256	exit 1
257    }
258
259    .t.c create image 0 0 -anchor nw -tags MyImage
260    .t.c itemconfigure MyImage -image $phImg
261
262    P "Drawing text and rectangles into canvas .."
263    .t.c create rectangle 1 1 239 219 -outline black
264    .t.c create rectangle 3 3 237 217 -outline green -width 2
265    delayedUpdate
266
267    set font {-family {Courier} -size 9}
268
269    drawInfo 140  10 black   $font
270    drawInfo 140  30 white   $font
271    drawInfo 140  50 red     $font
272    drawInfo 140  70 green   $font
273    drawInfo 140  90 blue    $font
274    drawInfo 140 110 cyan    $font
275    drawInfo 140 130 magenta $font
276    drawInfo 140 150 yellow  $font
277
278    .t.c create text 140 170 -anchor nw -fill black -text "Created with:" -font $font
279    delayedUpdate
280    .t.c create text 140 185 -anchor nw -fill black -text "Tcl [info patchlevel]" -font $font
281    .t.c create text 140 200 -anchor nw -fill black -text "Img $imgVersion" -font $font
282    update
283}
284