BEGIN { plan
tests
=> 15 }
ok($@,
''
,
'loading Tk module'
);
my
$mwin
;
eval
{
$mwin
= Tk::MainWindow->new() };
ok($@,
''
,
"Can't create MainWindow"
);
ok(Tk::Exists(
$mwin
), 1,
"MainWindow creation failed"
);
eval
{
$mwin
->geometry(
'+10+10'
) };
my
$widg
;
undef
(
$widg
);
my
$clas
=
'AbstractCanvas'
;
eval
"require Tk::$clas"
;
ok($@,
''
,
"Error loading Tk::$clas"
);
eval
{
$widg
=
$mwin
->
$clas
(
-width
=>
'6i'
,
-height
=>
'6i'
)};
ok($@,
''
,
"can't create $clas widget"
);
skip($@, Tk::Exists(
$widg
), 1,
"$clas instance does not exist"
);
if
(Tk::Exists(
$widg
)) {
eval
{
$widg
->
pack
() };
ok($@,
''
,
"Can't pack a $clas widget"
);
eval
{
$mwin
->update() };
ok($@,
''
,
"Error during 'update' for $clas widget"
);
eval
{
my
@dumy
=
$widg
->configure() };
ok($@,
''
,
"Error: configure list for $clas"
);
eval
{
$mwin
->update() };
ok($@,
''
,
"Error: 'update' after configure for $clas widget"
);
my
$id01
=
$widg
->createOval( 1, 5, 3, 3,
-fill
=>
'green'
,
-tags
=>
'blue'
);
my
$id02
=
$widg
->createOval( 1, 13, 3, 11,
-fill
=>
'green'
);
my
$id03
=
$widg
->createOval( 5, 9, 7, 7,
-fill
=>
'green'
);
my
$id04
=
$widg
->createOval( 9, 5, 11, 3,
-fill
=>
'green'
);
my
$id05
=
$widg
->createOval(13, 13, 15, 11,
-fill
=>
'green'
);
my
$idll
=
$widg
->createOval(-1, -1, 1, 1,
-fill
=>
'green'
,
-tags
=>
'up'
);
my
$idul
=
$widg
->createOval(-1, 7, 1, 9,
-fill
=>
'green'
,
-tags
=>
'up'
);
my
$idlr
=
$widg
->createOval(15, 7, 17, 9,
-fill
=>
'green'
,
-tags
=>
'down'
);
my
$idur
=
$widg
->createOval(15, 15, 17, 17,
-fill
=>
'green'
,
-tags
=>
'down'
);
my
$idlt
=
$widg
->createOval(-1, 15, 1, 17,
-fill
=>
'green'
,
-tags
=>
'right'
);
my
$idrt
=
$widg
->createOval( 7, 15, 9, 17,
-fill
=>
'green'
,
-tags
=>
'right'
);
my
$idlb
=
$widg
->createOval( 7, -1, 9, 1,
-fill
=>
'green'
,
-tags
=>
'left'
);
my
$idrb
=
$widg
->createOval(15, -1, 17, 1,
-fill
=>
'green'
,
-tags
=>
'left'
);
$widg
->viewAll();
$mwin
->update();
my
$dirr
= 1;
for
(
my
$jndx
= 0;
$jndx
< 110;
$jndx
++) {
if
(
$jndx
>= 21 &&
$jndx
< 46) {
$widg
->zoom(0.9);
}
elsif
(
$jndx
>= 46 &&
$jndx
< 66) {
$widg
->zoom(1 / 0.9);
}
elsif
(
$jndx
>=80) {
$widg
->zoom(0.9);
}
if
(
$jndx
== 45) {
$widg
->itemconfigure(
'blue'
,
-fill
=>
'blue'
); }
if
(
$jndx
== 65) {
my
@crds
=
$widg
->coords(
$id05
);
ok(
@crds
, 4,
"Error: wrong number of args returned from 'coords'"
);
my
$crct
= 0;
if
(
abs
(
$crds
[0] - 13) < 0.01 &&
abs
(
$crds
[1] - 3) < 0.01 &&
abs
(
$crds
[2] - 15) < 0.01 &&
abs
(
$crds
[3] - 5) < 0.01) {
$crct
= 1;
}
ok(
$crct
, 1,
"Error: object not in correct place"
);
}
if
(
$jndx
== 72) {
my
$absx
=
$widg
->abstractx(
$widg
->width() / 2);
my
$absy
=
$widg
->abstracty(
$widg
->height() / 2);
my
$crct
= 0;
$crct
= 1
if
(
abs
(
$absx
- 2.0) < 0.01 &&
abs
(
$absy
- 4.0) < 0.01);
ok(
$crct
, 1,
"Error: center is not at the correct location"
);
}
for
(
my
$indx
= 0;
$indx
< 8;
$indx
++) {
$widg
->move(
'up'
, 0, 1);
$widg
->move(
'down'
, 0, -1);
$widg
->move(
'right'
, 1, 0);
$widg
->move(
'left'
, -1, 0);
$widg
->move(
$id01
, 0, 1);
$widg
->move(
$id04
, 0,
$dirr
);
if
(
$indx
< 4) {
$widg
->move(
$id02
, 1, 0);
$widg
->move(
$id03
, 0, -1);
$widg
->move(
$id05
, -1, -
$dirr
);
}
else
{
$widg
->move(
$id02
, 0, -1);
$widg
->move(
$id03
, -1, 0);
$widg
->move(
$id05
, 1, -
$dirr
);
if
(
$jndx
== 70) {
$widg
->panAbstract(-0.5, 0);
sleep
(1);
}
}
$widg
->centerTags(
-exact
=> 1,
'blue'
)
if
(
$jndx
> 70);
$mwin
->update();
}
(
$id01
,
$id02
,
$id03
) = (
$id03
,
$id01
,
$id02
);
$dirr
= -
$dirr
;
$widg
->move(
'up'
, 0, -8);
$widg
->move(
'down'
, 0, 8);
$widg
->move(
'right'
, -8, 0);
$widg
->move(
'left'
, 8, 0);
}
eval
{
$widg
->destroy() };
ok($@,
''
,
"can't destroy $clas widget"
);
ok(!Tk::Exists(
$widg
), 1,
"$clas: widget not really destroyed"
);
}
else
{
for
(1..9) {
skip(1, 1, 1,
"skipped because widget couldn't be created"
);
}
}