diff options
author | William Joye <wjoye@cfa.harvard.edu> | 2019-01-08 21:02:55 (GMT) |
---|---|---|
committer | William Joye <wjoye@cfa.harvard.edu> | 2019-01-08 21:02:55 (GMT) |
commit | dbbb38af9cefef9e9e1a03c97945ee59063aa782 (patch) | |
tree | deefc089aa3327ebd4daa943b47c0d8f34af6bc7 /tkimg/tests/visualtests | |
parent | 54ae0375ebd9242bdf2eeceacee4c5b2de914bc1 (diff) | |
download | blt-dbbb38af9cefef9e9e1a03c97945ee59063aa782.zip blt-dbbb38af9cefef9e9e1a03c97945ee59063aa782.tar.gz blt-dbbb38af9cefef9e9e1a03c97945ee59063aa782.tar.bz2 |
update tkimg 1.4.7
Diffstat (limited to 'tkimg/tests/visualtests')
-rwxr-xr-x | tkimg/tests/visualtests/Readme.txt | 28 | ||||
-rwxr-xr-x | tkimg/tests/visualtests/testFrom.tcl | 116 | ||||
-rwxr-xr-x | tkimg/tests/visualtests/testFull.tcl | 129 | ||||
-rwxr-xr-x | tkimg/tests/visualtests/testSmall.tcl | 137 | ||||
-rwxr-xr-x | tkimg/tests/visualtests/testTo.tcl | 117 | ||||
-rwxr-xr-x | tkimg/tests/visualtests/utils/testGUI.tcl | 279 | ||||
-rwxr-xr-x | tkimg/tests/visualtests/utils/testImgs.tcl | 147 | ||||
-rwxr-xr-x | tkimg/tests/visualtests/utils/testReadWrite.tcl | 287 | ||||
-rwxr-xr-x | tkimg/tests/visualtests/utils/testUtil.tcl | 59 |
9 files changed, 0 insertions, 1299 deletions
diff --git a/tkimg/tests/visualtests/Readme.txt b/tkimg/tests/visualtests/Readme.txt deleted file mode 100755 index 9add1b5..0000000 --- a/tkimg/tests/visualtests/Readme.txt +++ /dev/null @@ -1,28 +0,0 @@ - Description of the tests - ======================== - -testFull.tcl: Read and write full images -testFrom.tcl: Read and write images with option "-from" -testTo.tcl: Read and write images with option "-to" -testSmall.tcl: Read and write images with sizes from 1x1 to 4x4 - -Each test performs the following operations: - -For each image format "fmt": - 1. Draw the test canvas, store it in a photo image - and write it to a file in format "fmt". - - 2. Read the image from file in different ways and display it. - - -The following ways to read image data are tested: -Read from file 1: image create photo -file $fileName -Read from file 2: set ph [image create photo] ; $ph read $fileName -Read as binary 1: image create photo -data $imgData -Read as binary 2: set ph [image create photo] ; $ph put $imgData -Read as uuencoded string: set ph [image create photo] ; $ph put $imgData - -The following ways to write image data are tested: -Write to file: $ph write $fileName -format $fmt -Write to uuencoded string: $ph data -format $fmt - diff --git a/tkimg/tests/visualtests/testFrom.tcl b/tkimg/tests/visualtests/testFrom.tcl deleted file mode 100755 index 3a3c60f..0000000 --- a/tkimg/tests/visualtests/testFrom.tcl +++ /dev/null @@ -1,116 +0,0 @@ -package require Tk - -proc initPackages { args } { - global gPkg - - foreach pkg $args { - set retVal [catch {package require $pkg} gPkg(ext,$pkg,version)] - set gPkg(ext,$pkg,avail) [expr !$retVal] - } -} - -initPackages img::bmp img::gif img::ico img::jpeg img::pcx \ - img::png img::ppm img::raw img::sgi img::sun \ - img::tga img::tiff img::xbm img::xpm img::window - -set retVal [catch {package require Img} version] -if { $retVal } { - error "Trying to load package Img: $version" -} - -cd [file dirname [info script]] - -source [file join "utils" "testUtil.tcl"] -source [file join "utils" "testGUI.tcl"] -# We get the global variable ui_enable_tk from above Tcl module. - -source [file join "utils" "testImgs.tcl"] -source [file join "utils" "testReadWrite.tcl"] - -if { $argc != 1 } { - set testMode [expr $modeFile | $modeBin | $modeUU] -} else { - set testMode [lindex $argv 0] -} - -PH "Image Read/Write (Using -from option)" - -P "This test tries to store the content of a canvas window in image files" -P "using all file formats available in the tkImg package." -P "After writing we try to read the image back into a photo by using the" -P "auto-detect mechanism of tkImg. If that fails, we use the \"-format\" option." -P "" -if { $ui_enable_tk } { - P "Set the environment variable UI_TK to 0 before running this test," - P "to run this test in batch mode without displaying the images." - P "" -} - -if { $tcl_platform(platform) eq "windows" && $ui_enable_tk } { - catch { console show } -} - -ui_init "testFrom.tcl: Read/Write (Using -from option)" "+320+30" -SetFileTypes - -drawTestCanvas $version - -P "" -set sep "" -if { $ui_enable_tk } { - set sep "\n\t" -} -set count 1 -set phCanvas [getCanvasPhoto .t.c] -foreach elem $fmtList { - set ext [lindex $elem 0] - set fmt [lindex $elem 1] - set opt [lindex $elem 2] - catch { file mkdir out } - set fname [file join out testFrom$ext] - set msg "Image $count: $fname Format: $fmt $sep (Options: $opt)" - P $msg - - PN "\t" - writePhotoFile $phCanvas $fname "$fmt $opt" 0 - if { $testMode & $modeFile } { - set ph [readPhotoFile2 $fname "$fmt $opt" -1 -1 -from 140 50 200 110] - if { $ph eq "" } { - set ph [createErrImg] - } - set msg "Image $count.1: $fname Format: $fmt $sep (Read from file 2)" - ui_addphoto $ph $msg - } - if { $testMode & $modeBin } { - set str [writePhotoFile $phCanvas $fname "$fmt $opt" 0 -from 140 50 200 110] - set ph [readPhotoBinary1 $fname "$fmt $opt"] - if { $ph eq "" } { - set ph [createErrImg] - } - set msg "Image $count.2: $fname Format: $fmt $sep (Read as binary 1)" - ui_addphoto $ph $msg - } - if { $testMode & $modeUU } { - set str [writePhotoString $phCanvas "$fmt $opt" 0 -from 140 50 200 110] - if { $str eq "" } { - set ph [createErrImg] - } else { - set ph [readPhotoString $str "$fmt $opt" -1 -1] - if { $ph eq "" } { - set ph [createErrImg] - } - } - set msg "Image $count.3: $fname Format: $fmt $sep (Read as uuencoded string)" - ui_addphoto $ph $msg - } - - P "" - incr count -} - -PS -P "End of test" - -P "" -P "Package tkImg: $version" -ui_show diff --git a/tkimg/tests/visualtests/testFull.tcl b/tkimg/tests/visualtests/testFull.tcl deleted file mode 100755 index d07056f..0000000 --- a/tkimg/tests/visualtests/testFull.tcl +++ /dev/null @@ -1,129 +0,0 @@ -package require Tk - -proc initPackages { args } { - global gPkg - - foreach pkg $args { - set retVal [catch {package require $pkg} gPkg(ext,$pkg,version)] - set gPkg(ext,$pkg,avail) [expr !$retVal] - } -} - -initPackages img::bmp img::gif img::ico img::jpeg img::pcx \ - img::png img::ppm img::raw img::sgi img::sun \ - img::tga img::tiff img::xbm img::xpm img::window - -set retVal [catch {package require Img} version] -if { $retVal } { - error "Trying to load package Img: $version" -} - -cd [file dirname [info script]] - -source [file join "utils" "testUtil.tcl"] -source [file join "utils" "testGUI.tcl"] -# We get the global variable ui_enable_tk from above Tcl module. - -source [file join "utils" "testImgs.tcl"] -source [file join "utils" "testReadWrite.tcl"] - -if { $argc != 1 } { - set testMode [expr $modeFile | $modeBin | $modeUU] -} else { - set testMode [lindex $argv 0] -} - -PH "Image Read/Write (Full Images)" - -P "This test tries to store the content of a canvas window in image files" -P "using all file formats available in the tkImg package." -P "After writing we try to read the image back into a photo by using the" -P "auto-detect mechanism of tkImg. If that fails, we use the \"-format\" option." -P "" -if { $ui_enable_tk } { - P "Set the environment variable UI_TK to 0 before running this test," - P "to run this test in batch mode without displaying the images." - P "" -} - -if { $tcl_platform(platform) eq "windows" && $ui_enable_tk } { - catch { console show } -} - -ui_init "testFull.tcl: Read/Write (Full Images)" "+320+30" -SetFileTypes - -drawTestCanvas $version - -P "" -set sep "" -if { $ui_enable_tk } { - set sep "\n\t" -} -set count 1 -set phCanvas [getCanvasPhoto .t.c] -foreach elem $fmtList { - set ext [lindex $elem 0] - set fmt [lindex $elem 1] - set opt [lindex $elem 2] - catch { file mkdir out } - set fname [file join out testFull$ext] - set msg "Image $count: $fname Format: $fmt $sep (Options: $opt)" - P $msg - - PN "\t" - writePhotoFile $phCanvas $fname "$fmt $opt" 0 - if { $testMode & $modeFile } { - set ph [readPhotoFile1 $fname "$fmt $opt"] - if { $ph eq "" } { - set ph [createErrImg] - } - set msg "Image $count.1: $fname Format: $fmt $sep (Read from file 1)" - ui_addphoto $ph $msg - - set ph [readPhotoFile2 $fname "$fmt $opt" -1 -1] - if { $ph eq "" } { - set ph [createErrImg] - } - set msg "Image $count.2: $fname Format: $fmt $sep (Read from file 2)" - ui_addphoto $ph $msg - } - if { $testMode & $modeBin } { - set ph [readPhotoBinary1 $fname "$fmt $opt"] - if { $ph eq "" } { - set ph [createErrImg] - } - set msg "Image $count.3: $fname Format: $fmt $sep (Read as binary 1)" - ui_addphoto $ph $msg - - set ph [readPhotoBinary2 $fname "$fmt $opt" -1 -1] - if { $ph eq "" } { - set ph [createErrImg] - } - set msg "Image $count.4: $fname Format: $fmt $sep (Read as binary 2)" - ui_addphoto $ph $msg - } - if { $testMode & $modeUU } { - set str [writePhotoString $phCanvas "$fmt $opt" 0] - if { $str eq "" } { - set ph [createErrImg] - } else { - set ph [readPhotoString $str "$fmt $opt" -1 -1] - if { $ph eq "" } { - set ph [createErrImg] - } - } - set msg "Image $count.5: $fname Format: $fmt $sep (Read as uuencoded string)" - ui_addphoto $ph $msg - } - - P "" - incr count -} - -PS -P "End of test" - -P "" -P "Package tkImg: $version" -ui_show diff --git a/tkimg/tests/visualtests/testSmall.tcl b/tkimg/tests/visualtests/testSmall.tcl deleted file mode 100755 index 565e518..0000000 --- a/tkimg/tests/visualtests/testSmall.tcl +++ /dev/null @@ -1,137 +0,0 @@ -package require Tk - -proc initPackages { args } { - global gPkg - - foreach pkg $args { - set retVal [catch {package require $pkg} gPkg(ext,$pkg,version)] - set gPkg(ext,$pkg,avail) [expr !$retVal] - } -} - -initPackages img::bmp img::gif img::ico img::jpeg img::pcx \ - img::png img::ppm img::raw img::sgi img::sun \ - img::tga img::tiff img::xbm img::xpm img::window - -set retVal [catch {package require Img} version] -if { $retVal } { - error "Trying to load package Img: $version" -} - -cd [file dirname [info script]] - -source [file join "utils" "testUtil.tcl"] -source [file join "utils" "testGUI.tcl"] -# We get the global variable ui_enable_tk from above Tcl module. - -source [file join "utils" "testImgs.tcl"] -source [file join "utils" "testReadWrite.tcl"] - -if { $argc != 1 } { - set testMode [expr $modeFile | $modeBin | $modeUU] -} else { - set testMode [lindex $argv 0] -} - -PH "Image Read/Write (Different sizes)" - -P "This test tries to store the content of a canvas window in image files" -P "using all file formats available in the tkImg package." -P "After writing we try to read the image back into a photo by using the" -P "auto-detect mechanism of tkImg. If that fails, we use the \"-format\" option." -P "" -if { $ui_enable_tk } { - P "Set the environment variable UI_TK to 0 before running this test," - P "to run this test in batch mode without displaying the images." - P "" -} - -if { $tcl_platform(platform) eq "windows" && $ui_enable_tk } { - catch { console show } -} - -ui_init "testSmall.tcl: Read/Write (Different small sizes)" "+320+30" -SetFileTypes - -P "" -set sep "" -if { $ui_enable_tk } { - set sep "\n\t" -} -set count 1 -foreach elem $fmtList { - set ext [lindex $elem 0] - set fmt [lindex $elem 1] - set opt [lindex $elem 2] - catch { file mkdir out } - set prefix [file join out testSmall] - - P "Format $fmt :" - for { set w 1 } { $w <=4 } { incr w } { - for { set h 1 } { $h <=4 } { incr h } { - P "Creating a photo of size: $w x $h" - set ph [image create photo -width $w -height $h] - set imgData {} - for { set y 1 } { $y <= $h } { incr y } { - set imgLine {} - for { set x 1 } { $x <= $w } { incr x } { - set col 0 - if { $x % 2 == 1 && $y % 2 == 1 || - $x % 2 == 0 && $y % 2 == 0 } { - set col 255 - } - set val [format "#%02x%02x%02x" $col $col $col] - lappend imgLine $val - if { $fmt eq "xbm" } { - $ph put -to [expr $x-1] [expr $y-1] $val - $ph transparency set [expr $x-1] [expr $y-1] [expr $col] - } - } - lappend imgData $imgLine - } - set zoom 8 - if { $fmt ne "xbm" } { - $ph put $imgData - } - set fname [format "%s_w%d_h%d%s" $prefix $w $h $ext] - # Write the image to a file and read it back again. - writePhotoFile $ph $fname "$fmt $opt" 1 - set ph [readPhotoFile1 $fname "$fmt $opt"] - if { $ph eq "" } { - set ph [createErrImg] - set zoom 1 - } - # Write the image to a uuencoded string and read it back again. - set str [writePhotoString $ph "$fmt $opt" 1] - if { $str eq "" } { - set ph [createErrImg] - set zoom 1 - } else { - set ph [readPhotoString $str "$fmt $opt" -1 -1] - if { $ph eq "" } { - set ph [createErrImg] - set zoom 1 - } - } - # Write the image to a uuencoded string and read it back again. - set zw [expr [image width $ph] * $zoom] - set zh [expr [image height $ph] * $zoom] - set zoomPh [image create photo -width $zw -height $zh] - $zoomPh copy $ph -zoom $zoom $zoom - image delete $ph - set msg "Image: $fname Format: $fmt $sep (Width: $w Height: $h)" - ui_addphoto $zoomPh $msg - P "" - } - } - - P "" - incr count -} - -PS -P "End of test" - -P "" -P "Package tkImg: $version" -ui_show diff --git a/tkimg/tests/visualtests/testTo.tcl b/tkimg/tests/visualtests/testTo.tcl deleted file mode 100755 index 2ac23f2..0000000 --- a/tkimg/tests/visualtests/testTo.tcl +++ /dev/null @@ -1,117 +0,0 @@ -package require Tk - -proc initPackages { args } { - global gPkg - - foreach pkg $args { - set retVal [catch {package require $pkg} gPkg(ext,$pkg,version)] - set gPkg(ext,$pkg,avail) [expr !$retVal] - } -} - -initPackages img::bmp img::gif img::ico img::jpeg img::pcx \ - img::png img::ppm img::raw img::sgi img::sun \ - img::tga img::tiff img::xbm img::xpm img::window - -set retVal [catch {package require Img} version] -if { $retVal } { - error "Trying to load package tkImg: $version" -} - -cd [file dirname [info script]] - -source [file join "utils" "testUtil.tcl"] -source [file join "utils" "testGUI.tcl"] -# We get the global variable ui_enable_tk from above Tcl module. - -source [file join "utils" "testImgs.tcl"] -source [file join "utils" "testReadWrite.tcl"] - -if { $argc != 1 } { - set testMode [expr $modeFile | $modeBin | $modeUU] -} else { - set testMode [lindex $argv 0] -} - -PH "Image Read/Write (Using -to option)" - -P "This test tries to store the content of a canvas window in image files" -P "using all file formats available in the tkImg package." -P "After writing we try to read the image back into a photo by using the" -P "auto-detect mechanism of tkImg. If that fails, we use the \"-format\" option." -P "" -if { $ui_enable_tk } { - P "Set the environment variable UI_TK to 0 before running this test," - P "to run this test in batch mode without displaying the images." - P "" -} - -if { $tcl_platform(platform) eq "windows" && $ui_enable_tk } { - catch { console show } -} - -ui_init "testTo.tcl: Read/Write (Using -to option)" "+320+30" -SetFileTypes - -drawTestCanvas $version - -P "" -set sep "" -if { $ui_enable_tk } { - set sep "\n\t" -} -set count 1 -set phCanvas [getCanvasPhoto .t.c] -foreach elem $fmtList { - set ext [lindex $elem 0] - set fmt [lindex $elem 1] - set opt [lindex $elem 2] - catch { file mkdir out } - set fname [file join out testTo$ext] - set msg "Image $count: $fname Format: $fmt $sep (Options: $opt)" - P $msg - - PN "\t" - writePhotoFile $phCanvas $fname "$fmt $opt" 0 - if { $testMode & $modeFile } { - set ph [readPhotoFile2 $fname "fmt $opt" 200 100 \ - -from 140 50 200 110 -to 10 30] - if { $ph eq "" } { - set ph [createErrImg] - } - set msg "Image $count.1: $fname Format: $fmt $sep (Read from file 2)" - ui_addphoto $ph $msg - } - if { $testMode & $modeBin } { - set str [writePhotoFile $phCanvas $fname "$fmt $opt" 0 -from 140 50 200 110] - set ph [readPhotoBinary2 $fname "$fmt $opt" 200 100 -to 10 30] - if { $ph eq "" } { - set ph [createErrImg] - } - set msg "Image $count.2: $fname Format: $fmt $sep (Read as binary 2)" - ui_addphoto $ph $msg - } - if { $testMode & $modeUU } { - set str [writePhotoString $phCanvas "$fmt $opt" 0 -from 140 50 200 110] - if { $str eq "" } { - set ph [createErrImg] - } else { - set ph [readPhotoString $str "$fmt $opt" 200 100 -to 10 30] - if { $ph eq "" } { - set ph [createErrImg] - } - } - set msg "Image $count.3: $fname Format: $fmt $sep (Read as uuencoded string)" - ui_addphoto $ph $msg - } - - P "" - incr count -} - -PS -P "End of test" - -P "" -P "Package tkimg: $version" -ui_show diff --git a/tkimg/tests/visualtests/utils/testGUI.tcl b/tkimg/tests/visualtests/utils/testGUI.tcl deleted file mode 100755 index 4ddc825..0000000 --- a/tkimg/tests/visualtests/utils/testGUI.tcl +++ /dev/null @@ -1,279 +0,0 @@ -# Set this variable to 0, if Tk should not be used for testing. -if { [info exists env(UI_TK)] && $env(UI_TK) == 0 } { - set ui_enable_tk 0 -} else { - set ui_enable_tk 1 -} - -proc bmpFirst {} { - return { - #define first_width 16 - #define first_height 16 - static unsigned char first_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x1c, 0x04, 0x1c, 0x06, - 0x1c, 0x07, 0x9c, 0x3f, 0xdc, 0x3f, 0x9c, 0x3f, 0x1c, 0x07, 0x1c, 0x06, - 0x1c, 0x04, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; - } -} - -proc bmpLast {} { - return { - #define last_width 16 - #define last_height 16 - static unsigned char last_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x20, 0x38, 0x60, 0x38, - 0xe0, 0x38, 0xfc, 0x39, 0xfc, 0x3b, 0xfc, 0x39, 0xe0, 0x38, 0x60, 0x38, - 0x20, 0x38, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; - } -} - -proc bmpLeft {} { - return { - #define left_width 16 - #define left_height 16 - static unsigned char left_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x01, 0x80, 0x01, - 0xc0, 0x01, 0xe0, 0x0f, 0xf0, 0x0f, 0xe0, 0x0f, 0xc0, 0x01, 0x80, 0x01, - 0x00, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; - } -} - -proc bmpRight {} { - return { - #define right_width 16 - #define right_height 16 - static unsigned char right_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x00, 0x80, 0x01, - 0x80, 0x03, 0xf0, 0x07, 0xf0, 0x0f, 0xf0, 0x07, 0x80, 0x03, 0x80, 0x01, - 0x80, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; - } -} - -proc bmpPlay {} { - return { - #define play_width 16 - #define play_height 16 - static unsigned char play_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x60, 0x00, 0xe0, 0x00, - 0xe0, 0x01, 0xe0, 0x03, 0xe0, 0x07, 0xe0, 0x03, 0xe0, 0x01, 0xe0, 0x00, - 0x60, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; - } -} - -proc bmpHalt {} { - return { - #define halt_width 16 - #define halt_height 16 - static unsigned char halt_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x18, 0x18, 0x30, 0x0c, - 0x60, 0x06, 0xc0, 0x03, 0x80, 0x01, 0xc0, 0x03, 0x60, 0x06, 0x30, 0x0c, - 0x18, 0x18, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; - } -} - -proc ui_initToolhelp { w { bgColor yellow } { fgColor black } } { - global ui_helpWidget - - # Create Toolbar help window with a simple label in it. - if { [winfo exists $w] } { - destroy $w - } - toplevel $w - set ui_helpWidget $w - label $w.l -text "??" -bg $bgColor -fg $fgColor -relief ridge - pack $w.l - wm overrideredirect $w true - if {[string equal [tk windowingsystem] aqua]} { - ::tk::unsupported::MacWindowStyle style $w help none - } - wm geometry $w [format "+%d+%d" -100 -100] -} - -proc ui_showToolhelp { x y str } { - global ui_helpWidget - - $ui_helpWidget.l configure -text $str - raise $ui_helpWidget - wm geometry $ui_helpWidget [format "+%d+%d" $x [expr $y +10]] -} - -proc ui_hideToolhelp {} { - global ui_helpWidget - - wm geometry $ui_helpWidget [format "+%d+%d" -100 -100] -} - -proc ui_button { btnName bmpData cmd helpStr } { - set imgData [image create bitmap -data $bmpData] - eval button $btnName -image $imgData -command [list $cmd] -relief flat - bind $btnName <Enter> "ui_showToolhelp %X %Y [list $helpStr]" - bind $btnName <Leave> { ui_hideToolhelp } - bind $btnName <Button> { ui_hideToolhelp } -} - -proc ui_init {title {winPos "+0+0"} } { - global ui_enable_tk ui_curImgNo ui_noImgs ui_top - - catch {wm withdraw .} - if { $ui_enable_tk } { - set ui_top .testWindow - ui_initToolhelp .testToolhelp - toplevel $ui_top - wm title $ui_top $title - wm geometry $ui_top $winPos - frame $ui_top.imgfr -bg lightgrey - frame $ui_top.menufr -relief raised -bg lightgrey - - label $ui_top.imgfr.img -bg white - text $ui_top.imgfr.txt -height 2 -width 60 -state disabled - pack $ui_top.imgfr.txt -side top - pack $ui_top.imgfr.img -side top - - ui_button $ui_top.menufr.quit [bmpHalt] ui_exit "Quit test (Esc)" - pack $ui_top.menufr.quit -in $ui_top.menufr -side left - pack $ui_top.menufr $ui_top.imgfr -side top -pady 2 -anchor w - bind $ui_top <Key-Escape> ui_exit - wm protocol $ui_top WM_DELETE_WINDOW ui_exit - - P "Visual: [winfo screenvisual $ui_top]" - P "Depth: [winfo depth $ui_top]" - } - set ui_curImgNo 0 - set ui_noImgs 0 -} - -proc showimg { imgNo } { - global ui_enable_tk ui_strings ui_top ui_photos - - if { $ui_enable_tk } { - $ui_top.imgfr.img config -image $ui_photos($imgNo) - - $ui_top.imgfr.txt configure -state normal - $ui_top.imgfr.txt delete 1.0 end - $ui_top.imgfr.txt insert end $ui_strings($imgNo) - $ui_top.imgfr.txt configure -state disabled - update - } -} - -proc ui_addimg { poImg str { chanMap {} } } { - global ui_enable_tk ui_curImgNo ui_noImgs ui_strings ui_images ui_photos - - set ui_strings($ui_curImgNo) $str - set ui_images($ui_curImgNo) $poImg - if { $ui_enable_tk } { - set ui_photos($ui_curImgNo) [image create photo] - $poImg img_photo $ui_photos($ui_curImgNo) $chanMap - showimg $ui_curImgNo - } - incr ui_curImgNo - set ui_noImgs $ui_curImgNo -} - -proc ui_addphoto { phImg str } { - global ui_enable_tk ui_curImgNo ui_noImgs ui_strings ui_images ui_photos - - set ui_strings($ui_curImgNo) $str - set ui_images($ui_curImgNo) "none" - if { $ui_enable_tk } { - set ui_photos($ui_curImgNo) $phImg - showimg $ui_curImgNo - } - incr ui_curImgNo - set ui_noImgs $ui_curImgNo -} - -proc show_first {} { - global ui_curImgNo ui_noImgs - - set ui_curImgNo 0 - showimg $ui_curImgNo -} - -proc show_last {} { - global ui_curImgNo ui_noImgs - - set ui_curImgNo [expr ($ui_noImgs -1)] - showimg $ui_curImgNo -} - -proc show_play {} { - global ui_curImgNo ui_noImgs - - while { $ui_curImgNo < [expr ($ui_noImgs -1)] } { - incr ui_curImgNo - showimg $ui_curImgNo - } -} - -proc show_prev {} { - global ui_curImgNo - - if { $ui_curImgNo > 0 } { - incr ui_curImgNo -1 - showimg $ui_curImgNo - } -} - -proc show_next {} { - global ui_curImgNo ui_noImgs - - if { $ui_curImgNo < [expr ($ui_noImgs -1)] } { - incr ui_curImgNo 1 - showimg $ui_curImgNo - } -} - -proc ui_show {} { - global ui_enable_tk ui_curImgNo ui_noImgs ui_strings ui_top - - PrintMachineInfo - - set ui_noImgs $ui_curImgNo - incr ui_curImgNo -1 - if { $ui_enable_tk } { - if { $ui_noImgs > 0 } { - set fr $ui_top.menufr - ui_button $fr.first [bmpFirst] show_first "Show first image" - ui_button $fr.prev [bmpLeft] show_prev "Show previous image (<-)" - ui_button $fr.next [bmpRight] show_next "Show next image (->)" - ui_button $fr.last [bmpLast] show_last "Show last image" - ui_button $fr.play [bmpPlay] show_play "Play image sequence (p)" - pack $fr.first $fr.prev $fr.next $fr.last \ - -in $fr -side left -padx 0 - pack $fr.play -in $fr -side left -padx 0 - - bind $ui_top <Key-Right> show_next - bind $ui_top <Key-Left> show_prev - bind $ui_top <Key-p> show_play - } - } else { - ui_exit - } -} - -proc ui_delete {} { - global ui_enable_tk ui_noImgs ui_strings ui_images ui_photos ui_top - - for { set i 0 } { $i < $ui_noImgs } { incr i } { - if { $ui_enable_tk } { - image delete $ui_photos($i) - } - if { [info commands $ui_images($i)] != {} } { - deleteimg $ui_images($i) - } - set ui_strings($i) {} - } - if { $ui_enable_tk } { - destroy $ui_top.imgfr - destroy $ui_top.menufr - } -} - -proc ui_exit {} { - ui_delete - if { [info commands memcheck] != {} } { - memcheck - } - exit -} diff --git a/tkimg/tests/visualtests/utils/testImgs.tcl b/tkimg/tests/visualtests/utils/testImgs.tcl deleted file mode 100755 index 1144365..0000000 --- a/tkimg/tests/visualtests/utils/testImgs.tcl +++ /dev/null @@ -1,147 +0,0 @@ -proc unsupportedImg {} { -return { -R0lGODlhAAEAAeMAAP////8AAP9VVf+qqv85Of9ycv/Hx/+Ojv8dHf/j4/// -/////////////////////ywAAAAAAAEAAQAE/hDISau9OOvNu/9gKI5kaZ5o -qq5s675wLM90bd94ru987//AoHBILBqPyKRyyWw6n9CodEqtWq/YrHbL7Xq/ -4LB4TC6bz+i0es1uu9/wuHxOr9vv+Lx+z+/7/4CBgoOEhYaHiImKi4yNjo+Q -kZKTlJWWl5iZmpucnZ6foKGio6SlpqeoqaqrrK2ur7CxsrO0tba3uLm6u7y9 -vr/AwcLDxMXGx8jJysvMzc7P0NHS09TV1tfY2drb3N3e3+Dh4uPk5ebn6Onq -6+zt7u/w8fLz9PX291sBAR36/fsU/vqh0GeK4A2DABBqCPhvAsOGJRSKkoiD -YgaCFi2O0OiJIw2P/hUwQnQ4MmJJUCBlpCQpgaLGhxcf+mvBsGVIgTclzmy5 -M2fDgBxgYgBKEmdRmScBEl3YcyXPpzcvID051Sm/qT4t9OQpUujRhDJjhtW6 -cyxXpGK9kq1pFaHOkkaLDk2qIi5XqUkzbgULd6/duzlj8gWIF8Tfv4OP0iXL -UmnUuVQXD8wbeS5eum8xj+SImK/kxlcFP177QaFpiJ2hjn7BubDr1YwdiwZs -+XLpz6BfJybt4bRs1bNzu0it+7dx3SDdftZrGDfYDb6DQ9/8E/XyvjPMFhcO -HLlk5UEr3+5dNa7HttRzp3Tp/ATa2PCPx09ePfx2puTLW8dPPnZ0/vKx/vAS -e7XBNt939U13n3QMKthggYQ9J1eDVm2kWXwBppZZcMQN2Fx+Hz54n0gGTlji -Cp0ROOKA1FGWHmQQ2tdfiLyFdlmLfbk41GTsiffVWhv61CKQNWI4XV5ZFWfX -Ukwx6dmNNaWlFgldRQkkViy9F5WWVzrpmXZQWqkUlmOytZeQPUJ2pprE0ejl -lWftF+dsb6LpIpdS0lenYv/sWUiFEuIT6IyCAgooOnjaeag4iZbpp6CQRirp -pJRWaumlmGaq6aacdurpp6CGKuqopJZq6qmopqrqqqy26uqrsMYq66y01mrr -rbjmquuuvPbq66/ABivssMQWa+yxyCar7LLMQzbr7LPQRivttNRWa+212Gar -7bbcduvtt+CGK+645JZr7rnopqvuuuy26+678MYr77z01mvvvfjmq+++/Pbr -77/hRAAAOw==} -} - -proc errorImg {} { -return { -R0lGODlhAAEAAeMAAP////8AAP9VVf+qqv85Of9ycv/Hx/+Ojv8dHf/j4/// -/////////////////////ywAAAAAAAEAAQAE/hDISau9OOvNu/9gKI5kaZ5o -qq5s675wLM90bd94ru987//AoHBILBqPyKRyyWw6n9CodEqtWq/YrHbL7Xq/ -4LB4TC6bz+i0es1uu9/wuHxOr9vv+Lx+z+/7/4CBgoOEhYaHiImKi4yNjo+Q -kZKTlJWWl5iZmpucnZ6foKGio6SlpqeoqaqrrK2ur7CxsrO0tba3uLm6u7y9 -vr/AwcLDxMXGx8jJysvMzc7P0NHS09TV1tfY2drb3N3e3+Dh4uPk5ebn6Onq -6+zt7u/w8WwD9PImCQUEAfv8AQQFBuz0G0iwoMF+Ai4MOMiQHwIBAEM0nChA -wIAVBvRNRHAAxMKJ/gcfRkQCsmTBhBY+mgwZ0MPKhh3vCXiJoCUHlS8J1jyS -cyXKCjh7Dvy5QahBBAlIGEAwkMCBAUkB0Js58OJNoyeN0Ns6QGMArmDDgi3A -j+iEBGC9igV7QADTfgU6jOVXYC1XAV73IRgRtEDUCwkODOWAlqtau/TavqW7 -hGoAEirNYnD8YWk/mx5UWiXsOEBcj/12Es77+QNlD5b5YTZyWkTkDq09OCYQ -QjNofn8JLxaQm0PnzbD5hZitJDYIA2WD7wuRYPHqDbZBOC7NwSttEY6RmhYO -ornqJMZBJPfNHYTgfTEz8wPeIQG/6xzOB9A+wqvkDOHj80vPuryI8Rvk/scB -gHKth51/GizGXneXyYagS/vcJ4SAHRCI34MdeHXbVyLIt6AF8sFHQogOLieC -hkhQOGCEyj12oInq7fMhdAZu4BwKi/U2GYbkwdifj8Ox2KOLQQJJo4yu1ZgB -cvuIWIJ81F1oZIvg8ThBWxVZQJWEFaiYAYoxchiChxuQhSQK7ulF5YlWAuFl -eAbQ89wFXgJm4ZFiggDml20WGYCOWvZpp5BHvClogIdWIB9/V535QZr+rBip -CmQiOuUGi1Z56QR1WkqkB5D+ueGMfKKHZ5QmMBkAl5wmelY/gE7YZ6ca0CrB -AIuhiiepFiTg1V67snBnoJsqlGtx6yG25wi0/mYUWqwZRLcBPlVxYGYAc5bw -FrC1JuqsQ9AG0VlJJziG2AAV6RQuBirVZVcBbhHEa6vFMiuouYilOxB9mq5U -rlH8btjTvPR+mkKd464UcIo5/ZsTRyUEZZJf29X7osF09gRxE4Za7ClIBFh0 -gsQMPXTAusRi7LDKXa4UMsFEdMxyxSp3NSxfSk5gwLUL09wCwhjaTCgUMq8s -5aopSAsUuCNcC/MHDg15NKsM12vrjsWai4LSSw/9Adcn3EyBiloTPaurWM8s -wbYoB5uB0yKoSvWGurZcL9tme3xwn3KPnPMFeEukJqV/Z1xv309cXYEBFc0N -QJ1wR1z44mKXKmoK/l6hDPnkVavt6Zo26tU2u5xTEPkHmaL5HugJiu6E4mMf -2mm7kjuagXfzMRc1CtcymnaB+9T9o+fdekyrV9k2mqcGUIbgle+648a6Bshz -jLbdxD+eKKROfl16BZkft3sJ1wqPPairMwF7wdNr0DvOtmugavcbeGX+Bqpe -LrUH7zd2fezGQ1vgRvWB03Ugf0+rAO4847MPDLBzJejU1ZpXm+8pcHz860cC -JbBAbrWPeYxBlt4Mlz3FVY+AqAuhAzX4qMX0rHjZo8AJIUgCCV5vfhWMHwdy -1J3FMDA+Ptyg9kYoARwOoXGN2w0Sl8jEJS7mAoxDohKRmDwJWIeJXULi/hWR -CD0KyOchS6ziAudzMgwcIC/Lw0AUk1iWMNbvPVjkAVZAohCTzCt/BKmASebm -w2ppIAEJC9lT0JWwF6bEjvhjSA/mOJE6loRgaOyHHksyN/nIqwMH6GND7kcB -khkEkgfpQRNHScpS3meNphRAFYtIyiymUgBddCUTV+lFTe6LYpV5ZUVoicol -LsMAWGrjAWhpj2Ia85jITKYyl8nMZjrzmdCMpjSnSc1qWvOa2MymNrfJzW56 -85vgDKc4x0nOcprznOhMpzrXyc52uvOd8IynPOdJz3ra8574zKc+98nPfvrz -nwANqEAHStCCGvSgCE2oQhfK0IY69KEQjahEJidK0Ypa9KIYzahGN8rRjnr0 -oyANqUhHStKSmvSkKE2pSlfKgggAADs=} -} - -proc pwrdLogo {} { -return { -R0lGODlhggDIAPUAAP//////zP//mf//AP/MzP/Mmf/MAP+Zmf+ZZv+ZAMz/ -/8zM/8zMzMyZzMyZmcyZZsyZAMxmZsxmM8xmAMwzM8wzAJnM/5nMzJmZzJmZ -mZlmmZlmZpkzZpkzM5kzAGaZzGZmzGZmmWZmZmYzZmYzMzNmzDNmmTMzmTMz -ZgAzmQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH+BSAtZGwtACH5BAEKAAIALAAA -AACCAMgAAAb+QIFwSCwaj8ikcslsOp/QqFT6qEYkWElly+1WJNOweKysVrNa -r3rN9kbIcHhkfqXY2/i8Hg+O+417gYKDg29/f4SJbBOKexRiCJEPaGlbfVCN -axMJCXkGA6CMmXkRZpSjX1KoXJ8Dopqgsa6rtIKGmKutnW2tsga1wHkPqqgJ -sXi9sQa7wc1ew1GrscxqE76vztlcU5WKELHYXrLU2uXco62/bMag5OXa55mt -4V3K7/db8Y3H66Dq+O/0KfLXBhzAewITheo3wN3BYJegPBgFqmDFh+UiPpmY -acA/L98GQKgV4QABAgW6AdTohOM+hxVa0XpAAIDNmwcwQovicuD+yGrtVtW8 -SRRAgYc7JVL86YUdKgkBikqNcBBBGHT0KhDMJEEqAAwfPmCoGeCgGKxAZzVC -UJRBiRRw4aJ4AKCnuauZEtCTuZboAhBxA6c4sYEAwLOZINALqigCUQyCI6fA -QAEf4kYTwllTS6jrTcCSI2+wjBeY00SebZoILfmEB4Sla336GIhCVAALVrOO -3OEeyyfNGA8aymC3ZBL4fjsJtjkrngM2ixsXPGLlZVqnBXleMF0wioNJowGb -Pcg2AAW6u8N9DTA8rlrC9wxNr763WTEqMzW3ZfOD+rjV1WKMAc5VMEZ+mC0U -SFQX/AfXCYJsMptz6bBxYC3f0PbceQ7+wmWfHhOEZFBaDa2RAX4CelSbTaD9 -F6AgInLmRS9rnCCZEwgq8glMakAnnYMDxcKUF5sNUGNkJuAom4xteEZfdx8O -IkuB/HghGQgtLVlgF9BB5uCLhPRCZYlqSPZBlrRcpIdqHcqzFRufZHUjmtIY -qQddXv6H3D7xqaGiGh3M2YRdHWm4Rk1PGvddkzluMSIsWQUa2UbwGepFV9w5 -GOUWERQwVFmLVLkGBEN2IWlgJbyHikh6QOefi13Q5FWOIVm6BY8jRHYmcGmW -eigAbW7RQQgYFLtAUQgwtCUeuQomnjTLdvVjdyiMYGNkJ3yggE05rcGXIs0G -9iwqBJICwKv+HbKWgU2GrdHnIChMqio6rQJwbbqhedYukQoqEm9gSc6blx4E -ZIqvZCjou8aAo9wLF5YCY6ZHAHkeLBgJdAGwbxef+DqIvBFrA0CLFgfWAVsA -dNvFZqiAzGtyACRacgUFcKuGMTzucWpcxODjWMmRfTcUoXGOsjNcPd8TgcFA -w4XcTSpZY2sgR6c67jsHVNx0B6ndzGQiJAi2KxSNBpN104FVAJ3GahgwdSDh -Ii1F2cAcgG7TQttklzXL7hF3CglpcwDJQJNAwU1qQPB2IP/yPDdAB8h8sAeO -GdV233s0nkLAUdBdCwKSpwvhUFEvzjiqgWcTQegdVsfuzZjv4ez+FFT5zDpc -t3uYMaEeNzK7FLX7drvDu1VA1j2/RxH8PbcTHlrCNi3vzNFhSF/O7XezNgJd -G2ezM+fKH6S5d5NBWZPnqOw8dtLv/A1gByVkn2/K+ITteGzth0aCBxg4H/QB -oLqH/eSGv3IMUDAe6MACiCeZEQAAfauI2xgOcrQHVcCB3XGAyu7ROPCxDxjJ -6oIHGliBECigO917R+MgVsBaHGCDFThOBTDQIONsAIK0aNz6PliLmvVEMr1h -QA21h5EY3q+FtBgaF8aXggp04Fy7WRRGxDXBbAwFAA0YAQnG950nys9kRTQi -AZEolKJ8gHjV2UDMWLMnjJzKgzxMok3+FFAsEBCuN+uSnBTdGJcdxrGMUAxN -bxoArNCogQI4zMSp4KCNobzFkBU4lv62YJKTPLB+RyQjKobCQAtWwCZRHMGx -bAKQATLSiqB8nhNxM50TQCeF2fjXCU7pjJowjToVcMwQtVcTGGrjXywMQwgE -x8pJ0mWXoXHgJTGZAj9GYZjZ8BEbK+CAr0xHAzZJZCbsBwdoOqNLrHkNIb8o -mGoC4CDcJIM3mwHO0LymJuQMDAPYVsoxhsEE2nCMA1izhXnG80FR8aU2wgZH -KYggnwDYJyRt8kjWnEBvFGwmHA6aja4cIDQQ+uQad6NMbSoScBPVxuEOwMQU -dJFNu1HjMvH+Eag4gCkYhytASb/jJONg85wRdWk5AkCAAwLoCyhlTeUwMks4 -vDQYPPWp0yqg0ts5BpblCKYYjgoMT1UwBchR6XSeihEMxKGN3wTAVZGTMUVx -9SF+2FQw6CLGwJA1ldrrClThEQe1AqMrEmAicsxpHMPR8z5wsGst8MpEPMJV -kMabazbS+g4ARMB9hi0ka3pTE4wwthwEOABkK7AuyUISOpaFwwcE60ICVDCy -UdyCp0JLBhCwJ5+m5Q1nDxu0LQTgKA+xChlM8NqKnlO2nd0NcroSwqrAwTX3 -eCBwaXuxCrAVI7odQwp6a8W8Cga1kzUebnMLh+neIxLjw64huxL+RvdIwbvv -kEAB/oac4PKTANZLDhn8A5CeNte9xylJGFMxBvriowBHay9z49IBQh1EOU9Y -TXskcN8Bm7QyXDBwRnbbxOQoNC7IuSliI4xTtEq3wvg4gMO+E4KgxiWjEnjA -bYpIBriAR3MkNrHTKLA2xLE2DCY9cAgC852mRqYLCBgKi6W7x3uIgMdMlXGA -PLDFh3YYsFPwT5HfcbQLKjluD1XsYsXwlimXo8pPDKRD/wplKXQ5I8WtwAjT -1oFt/XMw9LvxeXNcDo1VAoEKFHNoSizhu+CYzo3klgQ6QJ/eHOvNJfYoKj4M -Vmdk7DNurYAFAIDMyFQzjIxObnSehBz+DFDaOCfBtBiWijUANDQw1fH0tCLj -QIHCZgqgabQzuqI1uVRAw6xRY3xfbWZSl5qBENIqa55bRPM2AcMAoZhkKsAB -m3TSpKEOI4KXQOD2mPrHYZacrvc7bSVUGyAFWOB1I7lRSwewiN1Owrfru2rk -wLOBAeizb/6cAtI6gwIEmFZ1qvnFCJy7iI+QArrsfW8C5Ok7xwwaARQNDFiv -+yAUYECegLrqFGzA1R6OQnoIrg0auvhwJ+QxxjMOhbTtt4Rn7A1tOX6YObv4 -5BVAgQmqg6gTw9wLUzA5zFHwnZq1SNYnz3lcbi4stQXSy0F3OYiJ7piRJx0K -dyM6F+QqdTX+SCE9GX2HpwgQgLIB4N9Vv3pckO6MbOKhslXvgtLJ3gyztwE6 -DPfzE5AMELezgS67hvna+YAAeQvC7msgbtojHAW6s4HqqwD8GuI8+Fs04W5s -RzwqFK+GaDceCqcGuiXWNoc2lOQA8qa8F0A7+FxCgT6a/wJ0AtB5NUjgJBJA -5MLZIPpYrbTqjmdCc5tE5i5IXvJeqP3U61L6gDth94fvPRdqpjLP0P72tN9u -1Y1/7EjzHqoQjXCOhM8Frhe/5NZPPvaJvwfub4Etcb/3E7KXeqCO3+9cMD9Q -4S9nJdyRD8rfQk3sEvvFQ5/2WjZkTfAk9gZ8tid9xvN86IN2aff+BMRTgF/n -XNZTM5WQEgq4B3A3eHM3bmfHU2kWKyfxQghyAAVQgiWoB11Bf2XmbRxYep+k -gi1XfWDkgsYDg6Qhg0NHgxXQdxr4eD+mgynWg0xwai8HhEK4BImigzQYXSwo -GErogsZWBMvmDAnUASRwhTzXOFm4hVp0hV5IAh0QhmIYhvsVhUQwhYkghlc4 -Ajz3bGhjHCewhVnYhV8IhmMYhtS1BmY4BLXFBmI4AoDIc284iIQIF1ZDb2PX -AYEoiIXYiI7YR2LgP484iZQoUWFAhJWYiY7oTMeniZ74iJyIg584imgTirpH -iqjYNB+WiqyIL6vYirCoHpEIhyZQi7v+YQJhETrpgS4m0Em1aItI8ous8Ysy -cwLC2B2zuBsfcBMVBxfLeBO1tjnWZAIjkwIlUI2C4WSfFhmeZhPRSI1zZCY3 -kRvTIQZu6Iym5mmJQo0LUAImME+YmAILwB3L2CCe1hrYKBmedgLzJBnUGI3o -aEfFtBujZhzLGD/l1kflZk3cCCzzBCwLUGlw1j/xeI8X4FlxQY0XAALxeJDN -lJCConSh8YwDGRgXGRgA0IzXuIyetoz+81AKsADR2I16lpE2IZPi+BYgkI+h -UZDKeC7x+JGg8Y+hMUopcBMYxZOC4WkxGRpEOZLXpo7G4ZOs4ZFO2R8lsC1B -6WkNcpESCWfDH+CO+jgyDCkYGimWunIuy9iMyQN102GVobGTkBaXUHSNkqiN -zWiRICmNSJmW0XGO9rR+3ZE7J1ACJQCYZ+SMt3iM2agbveiPjGmWwGgcBTWA -sXiZg3lPmLmZw4iInPmZuOOZoMmZlXkIogUCuTOaUmWarEkEH4CagAmLptia -tDkEr5mamjibtbmbRZCLuEmIusmbwokEr3mYlBicw5mcTMCRg6iczmmatxmb -LvOc1AmdqDmV1ZmdwhmW6aGd3vmdSxAEADs=} -} diff --git a/tkimg/tests/visualtests/utils/testReadWrite.tcl b/tkimg/tests/visualtests/utils/testReadWrite.tcl deleted file mode 100755 index df8422b..0000000 --- a/tkimg/tests/visualtests/utils/testReadWrite.tcl +++ /dev/null @@ -1,287 +0,0 @@ -# Some constants -set modeFile 0x01 -set modeBin 0x02 -set modeUU 0x04 -set modeFileStr "File IO" -set modeBinStr "Binary IO" -set modeUUStr "UUencoded IO" - -# The list of file formats to be tested. -# First entry specifies the file extension used to create the image filenames. -# Second entry specifies the image format name as used by the Img extension. -# Third entry specifies optional format options. - -set fmtList [list \ - [list ".bmp" "bmp" ""] \ - [list ".gif" "gif" ""] \ - [list ".ico" "ico" ""] \ - [list ".jpg" "jpeg" ""] \ - [list ".pcx" "pcx" ""] \ - [list ".png" "png" ""] \ - [list ".ppm" "ppm" ""] \ - [list ".raw" "raw" "-useheader true -nomap true -nchan 3"] \ - [list ".rgb" "sgi" ""] \ - [list ".ras" "sun" ""] \ - [list ".tga" "tga" ""] \ - [list ".tif" "tiff" ""] \ - [list ".xbm" "xbm" ""] \ - [list ".xpm" "xpm" ""] ] - - -# Load image data directly from a file into a photo image. -# Uses commands: image create photo -file "fileName" -proc readPhotoFile1 { name fmt } { - PN "File read 1: " - - set sTime [clock clicks -milliseconds] - set retVal [catch {image create photo -file $name} ph] - if { $retVal != 0 } { - P "\n\tWarning: Cannot detect image file format. Trying again with -format." - P "\tError message: $ph" - set retVal [catch {image create photo -file $name -format $fmt} ph] - if { $retVal != 0 } { - P "\tERROR: Cannot read image file with format option $fmt" - P "\tError message: $ph" - return "" - } - } - set eTime [clock clicks -milliseconds] - PN "[format "%.2f " [expr ($eTime - $sTime) / 1.0E3]]" - return $ph -} - -# Load image data directly from a file into a photo image. -# Uses commands: set ph [image create photo] ; $ph read "fileName" -# args maybe "-from ..." and/or "-to ..." option. -proc readPhotoFile2 { name fmt width height args } { - PN "File read 2: " - - set sTime [clock clicks -milliseconds] - if { $width < 0 && $height < 0 } { - set ph [image create photo] - } else { - set ph [image create photo -width $width -height $height] - } - set retVal [catch {eval {$ph read $name} $args} errMsg] - if { $retVal != 0 } { - P "\n\tWarning: Cannot detect image file format. Trying again with -format." - P "\tError message: $errMsg" - set retVal [catch {eval {$ph read $name -format $fmt} $args} errMsg] - if { $retVal != 0 } { - P "\tERROR: Cannot read image file with format option $fmt" - P "\tError message: $errMsg" - return "" - } - } - set eTime [clock clicks -milliseconds] - PN "[format "%.2f " [expr ($eTime - $sTime) / 1.0E3]]" - return $ph -} - -# Load binary image data from a variable into a photo image. -# Uses commands: image create photo -data $imgData -proc readPhotoBinary1 { name fmt args } { - PN "Binary read 1: " - - set sTime [clock clicks -milliseconds] - set retVal [catch {open $name r} fp] - if { $retVal != 0 } { - P "\n\tERROR: Cannot open image file $name for binary reading." - return "" - } - fconfigure $fp -translation binary - set imgData [read $fp [file size $name]] - close $fp - - set retVal [catch {image create photo -data $imgData} ph] - if { $retVal != 0 } { - P "\n\tWarning: Cannot detect image file format. Trying again with -format." - P "\tError message: $ph" - set retVal [catch {image create photo -data $imgData -format $fmt} ph] - if { $retVal != 0 } { - P "\tERROR: Cannot create photo from binary image data." - P "\tError message: $ph" - return "" - } - } - set eTime [clock clicks -milliseconds] - PN "[format "%.2f " [expr ($eTime - $sTime) / 1.0E3]]" - return $ph -} - -# Load binary image data from a variable into a photo image. -# Uses commands: set ph [image create photo] ; $ph put $imgData -# args maybe "-to ..." option. -proc readPhotoBinary2 { name fmt width height args } { - PN "Binary read 2: " - - set sTime [clock clicks -milliseconds] - set retVal [catch {open $name r} fp] - if { $retVal != 0 } { - P "\n\tERROR: Cannot open image file $name for binary reading." - return "" - } - fconfigure $fp -translation binary - set imgData [read $fp [file size $name]] - close $fp - - if { $width < 0 && $height < 0 } { - set ph [image create photo] - } else { - set ph [image create photo -width $width -height $height] - } - set retVal [catch {eval {$ph put $imgData} $args} errMsg] - if { $retVal != 0 } { - P "\n\tWarning: Cannot detect image file format. Trying again with -format." - P "\tError message: $errMsg" - set retVal [catch {eval {$ph put $imgData -format $fmt} $args} errMsg] - if { $retVal != 0 } { - P "\tERROR: Cannot create photo from binary image data." - P "\tError message: $errMsg" - return "" - } - } - set eTime [clock clicks -milliseconds] - PN "[format "%.2f " [expr ($eTime - $sTime) / 1.0E3]]" - return $ph -} - -# Load uuencoded image data from a variable into a photo image. -# Uses commands: set ph [image create photo] ; $ph put $imgData -proc readPhotoString { str fmt width height args } { - PN "String read: " - - set sTime [clock clicks -milliseconds] - if { $width < 0 && $height < 0 } { - set ph [image create photo] - } else { - set ph [image create photo -width $width -height $height] - } - set retVal [catch {eval {$ph put $str} $args}] - if { $retVal != 0 } { - P "\n\tWarning: Cannot detect image string format. Trying again with -format." - set retVal [catch {eval {$ph put $str -format $fmt} $args}] - if { $retVal != 0 } { - P "\tERROR: Cannot read image string with format option: $fmt" - return "" - } - } - set eTime [clock clicks -milliseconds] - PN "[format "%.2f " [expr ($eTime - $sTime) / 1.0E3]]" - return $ph -} - -proc writePhotoFile { ph name fmt del args } { - PN "File write: " - - set sTime [clock clicks -milliseconds] - set retVal [catch {eval {$ph write $name -format $fmt} $args} str] - set eTime [clock clicks -milliseconds] - - if { $retVal != 0 } { - P "\n\tERROR: Cannot write image file $name (Format: $fmt)" - P "\tError message: $str" - return "" - } - if { $del } { - image delete $ph - } - PN "[format "%.2f " [expr ($eTime - $sTime) / 1.0E3]]" - return $str -} - -proc writePhotoString { ph fmt del args } { - PN "String write: " - - set sTime [clock clicks -milliseconds] - set retVal [catch {eval {$ph data -format $fmt} $args} str] - set eTime [clock clicks -milliseconds] - if { $retVal != 0 } { - P "\n\tERROR: Cannot write image to string (Format: $fmt)" - P "\tError message: $str" - return "" - } - if { $del } { - image delete $ph - } - PN "[format "%.2f " [expr ($eTime - $sTime) / 1.0E3]]" - return $str -} - -proc createErrImg {} { - set retVal [catch {image create photo -data [unsupportedImg]} errImg] - if { $retVal != 0 } { - P "FATAL ERROR: Cannot load uuencode GIF image into canvas." - P " Test will be cancelled." - exit 1 - } - return $errImg -} - -proc getCanvasPhoto { canvId } { - PN "Canvas photo: " - set sTime [clock clicks -milliseconds] - set retVal [catch {image create photo -format window -data $canvId} ph] - set eTime [clock clicks -milliseconds] - if { $retVal != 0 } { - P "\n\tFATAL ERROR: Cannot create photo from canvas window" - exit 1 - } - P "[format "%.2f secs" [expr ($eTime - $sTime) / 1.0E3]]" - return $ph -} - -proc delayedUpdate {} { - update - after 200 -} - -proc drawInfo { x y color font } { - set size 10 - set tx [expr $x + $size * 2] - .t.c create rectangle $x $y [expr $x + $size] [expr $y + $size] -fill $color - .t.c create text $tx $y -anchor nw -fill black -text "$color box" -font $font - delayedUpdate -} - -proc drawTestCanvas { imgVersion} { - toplevel .t - wm title .t "Canvas window" - wm geometry .t "+0+30" - - canvas .t.c -bg gray -width 240 -height 220 - pack .t.c - - P "Loading uuencoded GIF image into canvas .." - set retVal [catch {image create photo -data [pwrdLogo]} phImg] - if { $retVal != 0 } { - P "FATAL ERROR: Cannot load uuencode GIF image into canvas." - P " Test will be cancelled." - exit 1 - } - - .t.c create image 0 0 -anchor nw -tags MyImage - .t.c itemconfigure MyImage -image $phImg - - P "Drawing text and rectangles into canvas .." - .t.c create rectangle 1 1 239 219 -outline black - .t.c create rectangle 3 3 237 217 -outline green -width 2 - delayedUpdate - - set font {-family {Courier} -size 9} - - drawInfo 140 10 black $font - drawInfo 140 30 white $font - drawInfo 140 50 red $font - drawInfo 140 70 green $font - drawInfo 140 90 blue $font - drawInfo 140 110 cyan $font - drawInfo 140 130 magenta $font - drawInfo 140 150 yellow $font - - .t.c create text 140 170 -anchor nw -fill black -text "Created with:" -font $font - delayedUpdate - .t.c create text 140 185 -anchor nw -fill black -text "Tcl [info patchlevel]" -font $font - .t.c create text 140 200 -anchor nw -fill black -text "Img $imgVersion" -font $font - update -} diff --git a/tkimg/tests/visualtests/utils/testUtil.tcl b/tkimg/tests/visualtests/utils/testUtil.tcl deleted file mode 100755 index aa82d67..0000000 --- a/tkimg/tests/visualtests/utils/testUtil.tcl +++ /dev/null @@ -1,59 +0,0 @@ -proc P { str } { - catch {puts $str ; flush stdout} -} - -proc PN { str } { - catch {puts -nonewline $str ; flush stdout} -} - -proc PP { str } { - P "" - P $str - P "" -} - -proc PS { } { - P "" - P "------------------------------------------------------------" - P "" -} - -proc PH { str } { - P "" - P "Test: $str" - PS -} - -proc PF { floatVal { prec 4 } } { - set fmtStr "%.${prec}f" - return [format $fmtStr $floatVal] -} - -proc PSec { msg sec } { - P [format "%s: %.4f seconds" $msg $sec] -} - -proc PrintMachineInfo {} { - global tcl_platform - - P "Machine specific information:" - P "platform : $tcl_platform(platform)" - P "os : $tcl_platform(os)" - P "osVersion : $tcl_platform(osVersion)" - P "machine : $tcl_platform(machine)" - P "byteOrder : $tcl_platform(byteOrder)" - P "wordSize : $tcl_platform(wordSize)" - P "user : $tcl_platform(user)" - P "hostname : [info hostname]" - P "Tcl version : [info patchlevel]" - P "Visuals : [winfo visualsavailable .]" -} - -proc SetFileTypes { } { - global fInfo env - - set fInfo(suf) ".tga" - set fInfo(fmt) "targa" - set fInfo(vsn) "int" - set fInfo(modfmt) 0 -} |