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