$ZooZ::Generic::VERSION
=
'1.9.1'
;
sub
BindMouseWheel {
my
(
$top
,
$w
) =
@_
;
if
($^O eq
'MSWin32'
) {
$top
->
bind
(
'<MouseWheel>'
=>
[
sub
{
my
$w2
=
ref
$w
eq
'CODE'
?
$w
->() :
$w
;
$w2
->yview(
'scroll'
, -(
$_
[1] / 120) * 3,
'units'
) },
Tk::Ev(
'D'
) ]
);
}
else
{
$top
->
bind
(
'<4>'
=>
sub
{
my
$w2
=
ref
$w
eq
'CODE'
?
$w
->() :
$w
;
$w2
->yview(
'scroll'
, -3,
'units'
)
unless
$Tk::strictMotif
;
});
$top
->
bind
(
'<5>'
=>
sub
{
my
$w2
=
ref
$w
eq
'CODE'
?
$w
->() :
$w
;
$w2
->yview(
'scroll'
, +3,
'units'
)
unless
$Tk::strictMotif
;
});
}
}
my
@msgFrames
;
my
@msgLabels
;
my
(
@msgX
,
@msgY
,
@stopY
);
sub
popMessage {
my
%hash
=
@_
;
my
$over
=
delete
$hash
{-over} or
return
undef
;
my
$msg
=
delete
$hash
{-msg} or
return
undef
;
my
$msgDelay
=
delete
$hash
{-delay} || 3000;
my
$id
= 0;
$id
++
while
defined
$msgX
[
$id
];
unless
(
$msgFrames
[
$id
]) {
my
$top
=
$over
->toplevel;
my
$msgFrame
=
$top
->Frame(
qw/-bd 1 -relief solid/
);
my
$msgLabel
=
$msgFrame
->Label(
qw/-padx 20 -pady 20/
,
%hash
,
)->
pack
(
qw/-fill both/
);
$msgFrames
[
$id
] =
$msgFrame
;
$msgLabels
[
$id
] =
$msgLabel
;
}
$msgLabels
[
$id
]->configure(
%hash
,
-text
=>
$msg
);
$msgFrames
[
$id
]->idletasks;
$msgFrames
[
$id
]->raise;
_animateMsgDown(
$over
,
$id
,
$msgDelay
);
}
sub
_animateMsgDown {
my
(
$top
,
$id
,
$msgDelay
) =
@_
;
unless
(
defined
$msgX
[
$id
]) {
$msgY
[
$id
] =
$msgFrames
[
$id
]->reqheight * (
$id
-1);
$msgX
[
$id
] =
int
0.5 * (
$top
->width -
$msgFrames
[
$id
]->reqwidth);
$stopY
[
$id
] =
$msgY
[
$id
] +
$msgFrames
[
$id
]->reqheight;
}
else
{
$msgY
[
$id
]++;
}
$msgFrames
[
$id
]->place(
-x
=>
$msgX
[
$id
],
-y
=>
$msgY
[
$id
]);
if
(
$msgY
[
$id
] ==
$stopY
[
$id
]) {
$top
->
after
(
$msgDelay
=> [\
&_animateMsgUp
,
$top
,
$id
]);
return
;
}
$top
->
after
(
5
=> [\
&_animateMsgDown
,
$top
,
$id
,
$msgDelay
]);
}
sub
_animateMsgUp {
my
(
$top
,
$id
) =
@_
;
$msgY
[
$id
]--;
$msgFrames
[
$id
]->place(
-x
=>
$msgX
[
$id
],
-y
=>
$msgY
[
$id
]);
if
(
$msgY
[
$id
] == -
$msgFrames
[
$id
]->height) {
$msgX
[
$id
] =
$msgY
[
$id
] =
undef
;
$msgFrames
[
$id
]->placeForget;
return
;
}
$top
->
after
(
5
=> [\
&_animateMsgUp
,
$top
,
$id
]);
}
my
$fadeFrame
;
my
$stepSize
= 10;
sub
animateOpen_old {
my
(
$top
,
$fx
,
$fy
,
$fw
,
$fh
) =
@_
;
return
unless
$top
->viewable;
unless
(
$fadeFrame
) {
$fadeFrame
=
$top
->Frame(
qw/-bg white -relief solid -bd 1/
);
print
"Fade Frame is $fadeFrame.\n"
;
}
my
$tw
=
$top
->reqwidth;
my
$th
=
$top
->reqheight;
my
$w
=
my
$h
= 0;
my
$x
=
$fx
;
my
$y
=
$fy
;
while
(
$w
<
$tw
||
$h
<
$th
) {
$fadeFrame
->place(
-x
=>
$x
,
-y
=>
$y
,
-width
=>
$w
,
-height
=>
$h
);
$_
+=
$stepSize
for
$w
,
$h
;
$_
-=
$stepSize
/ 2
for
$x
,
$y
;
$fadeFrame
->raise;
$fadeFrame
->update;
$top
->
after
(1);
}
$fadeFrame
->placeForget;
}
sub
animateClose_old {
my
(
$top
,
$x
,
$y
) =
@_
;
unless
(
$fadeFrame
) {
$fadeFrame
=
$top
->Frame(
qw/-bg white/
);
}
}
my
$steps
= 10;
sub
animateOpen {
print
"Got >>@_<<\n"
;
my
(
$c
,
$id
) =
@_
;
my
(
$midX
,
$midY
) = (
$c
->width / 2,
$c
->height / 2);
$id
=
'ANIMATE'
;
unless
(
$c
->find(
withtag
=>
$id
)) {
$c
->createWindow(
$midX
,
$midY
,
-window
=>
$c
->Frame,
-width
=> 0,
-height
=> 0,
-tags
=> [
'ANIMATE'
],
);
}
$c
->itemconfigure(
$id
,
-width
=> 10,
-height
=> 10);
my
@oldC
=
$c
->coords(
$id
);
my
$dx
= (
$midX
-
$oldC
[0]) /
$steps
;
my
$dy
= (
$midY
-
$oldC
[1]) /
$steps
;
my
@cur
=
@oldC
;
$c
->itemconfigure(
$id
,
-state
=>
'normal'
);
my
@box
=
$c
->bbox(
$id
);
my
$w
=
$box
[2] -
$box
[0];
my
$h
=
$box
[3] -
$box
[1];
$dx
= (
$c
->width -
$w
) /
$steps
;
$dy
= (
$c
->height -
$h
) /
$steps
;
for
my
$i
(1 ..
$steps
) {
$w
+=
$dx
;
$h
+=
$dy
;
$c
->itemconfigure(
$id
,
-width
=>
$w
,
-height
=>
$h
);
$c
->update;
$c
->
after
(80);
}
$c
->itemconfigure(
$id
,
-state
=>
'hidden'
);
}
sub
lineUpCommas {
my
$len
= (
sort
{
$b
<=>
$a
}
map
length
$_
->[0] =>
@_
)[0];
return
join
"\n"
=>
map
{
sprintf
" %-$ {len}s => %s,"
=>
@$_
}
@_
;
}
'the truth'
;