1# 2# test tkphoto binding 3# 4 5if {[lsearch [namespace children] ::tcltest] == -1} { 6 package require tcltest 7 namespace import -force ::tcltest::* 8} 9 10package require Ffidl 11package require Ffidlrt 12 13package require Tkphoto 0.1 14 15test ffidl-tkphoto {ffidl tkphoto tests} {} { 16 17# 18# make a checkerboard 19# photo image put argument 20# with checker width w, 21# checker height h, 22# and colors c1 and c2 23# 24proc checkerboard {w h c1 c2} { 25 set row1 {} 26 set row2 {} 27 for {set j 0} {$j < $w*2} {incr j} { 28 if {$j < $w} { 29 lappend row1 $c1 30 lappend row2 $c2 31 } else { 32 lappend row1 $c2 33 lappend row2 $c1 34 } 35 } 36 set checks {} 37 for {set i 0} {$i < $h*2} {incr i} { 38 if {$i < $h} { 39 lappend checks $row1 40 } else { 41 lappend checks $row2 42 } 43 } 44 set checks 45} 46 47 48image create photo p -width 128 -height 128 49image create photo q -width 128 -height 128 50 51pack [label .p -image p] -side left 52pack [label .q -image q] -side left 53 54p put [checkerboard 16 16 red blue] -to 0 0 128 128 55 56# 57# a little long winded, as I'm not in the mood to define 58# a new interface, but copy one image into another via 59# a binary copy of the pixels, with a blow by blow 60# commentary to stdout. 61# 62 63# find the image named "p" 64set phandle [ffidl-find-photo [ffidl::info interp] p] 65 66# find the image named "q" 67set qhandle [ffidl-find-photo [ffidl::info interp] q] 68 69# allocate a Tk_PhotoImageBlock for "p" 70set pblock [binary format x[ffidl::info sizeof Tk_PhotoImageBlock]] 71 72# get the Tk_PhotoImageBlock for "p" 73ffidl-photo-get-image $phandle pblock 74 75# copy the pixels of "p" into a bytearray 76set pbytes [ffidl-photo-get-block-bytes $pblock] 77 78# build a Tk_PhotoImageBlock describing our copy of "p" 79set qblock [binary format [ffidl::info format Tk_PhotoImageBlock] \ 80 [::ffidl::get-bytearray $pbytes] \ 81 [ffidl-photo-block.width $pblock] \ 82 [ffidl-photo-block.height $pblock] \ 83 [ffidl-photo-block.pitch $pblock] \ 84 [ffidl-photo-block.pixelSize $pblock] \ 85 [ffidl-photo-block.red $pblock] \ 86 [ffidl-photo-block.green $pblock] \ 87 [ffidl-photo-block.blue $pblock] \ 88 0] 89 90# write our copied pixel data into "q", a little bit at atime 91for {set x 16} {$x <= 128} {incr x 16} { 92 ffidl-photo-put-block $qhandle $qblock 0 0 $x $x 93 update 94 after 50 95} 96 97} {} 98 99 100# cleanup 101::tcltest::cleanupTests 102return 103