# # test tkphoto binding # if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } package require Ffidl package require Ffidlrt package require Tkphoto 0.1 test ffidl-tkphoto {ffidl tkphoto tests} {} { # # make a checkerboard # photo image put argument # with checker width w, # checker height h, # and colors c1 and c2 # proc checkerboard {w h c1 c2} { set row1 {} set row2 {} for {set j 0} {$j < $w*2} {incr j} { if {$j < $w} { lappend row1 $c1 lappend row2 $c2 } else { lappend row1 $c2 lappend row2 $c1 } } set checks {} for {set i 0} {$i < $h*2} {incr i} { if {$i < $h} { lappend checks $row1 } else { lappend checks $row2 } } set checks } image create photo p -width 128 -height 128 image create photo q -width 128 -height 128 pack [label .p -image p] -side left pack [label .q -image q] -side left p put [checkerboard 16 16 red blue] -to 0 0 128 128 # # a little long winded, as I'm not in the mood to define # a new interface, but copy one image into another via # a binary copy of the pixels, with a blow by blow # commentary to stdout. # # find the image named "p" set phandle [ffidl-find-photo [ffidl::info interp] p] # find the image named "q" set qhandle [ffidl-find-photo [ffidl::info interp] q] # allocate a Tk_PhotoImageBlock for "p" set pblock [binary format x[ffidl::info sizeof Tk_PhotoImageBlock]] # get the Tk_PhotoImageBlock for "p" ffidl-photo-get-image $phandle pblock # copy the pixels of "p" into a bytearray set pbytes [ffidl-photo-get-block-bytes $pblock] # build a Tk_PhotoImageBlock describing our copy of "p" set qblock [binary format [ffidl::info format Tk_PhotoImageBlock] \ [::ffidl::get-bytearray $pbytes] \ [ffidl-photo-block.width $pblock] \ [ffidl-photo-block.height $pblock] \ [ffidl-photo-block.pitch $pblock] \ [ffidl-photo-block.pixelSize $pblock] \ [ffidl-photo-block.red $pblock] \ [ffidl-photo-block.green $pblock] \ [ffidl-photo-block.blue $pblock] \ 0] # write our copied pixel data into "q", a little bit at atime for {set x 16} {$x <= 128} {incr x 16} { ffidl-photo-put-block $qhandle $qblock 0 0 $x $x update after 50 } } {} # cleanup ::tcltest::cleanupTests return