use
5.010;
our
$VERSION
=
'0.38'
;
use
constant
CHILD_WINDOWS_LATER
=>
$ENV
{TICKIT_CHILD_WINDOWS_LATER};
sub
new
{
my
$class
=
shift
;
my
(
$tickit
,
$lines
,
$cols
) =
@_
;
my
$term
=
$tickit
->term;
my
$self
=
bless
{
tickit
=>
$tickit
,
term
=>
$term
,
top
=> 0,
left
=> 0,
cols
=>
$cols
,
lines
=>
$lines
,
},
$class
;
$self
->_init;
weaken(
$self
->{tickit} );
return
$self
;
}
sub
_init
{
my
$self
=
shift
;
$self
->{visible} = 1;
$self
->{pen} = Tickit::Pen->new;
$self
->{damage} = Tickit::RectSet->new;
}
sub
_close
{
my
$self
=
shift
;
$self
->set_on_geom_changed(
undef
);
$self
->set_on_key(
undef
);
$self
->set_on_mouse(
undef
);
$self
->set_on_expose(
undef
);
$self
->set_on_focus(
undef
);
defined
and
$_
->_close
for
@{
$self
->{child_windows} };
undef
$self
->{child_windows};
@{
$self
->{pending_geom_changes} } = ();
}
sub
DESTROY
{
my
$self
=
shift
;
$self
->_close;
$self
->{parent}->_do_change_children(
remove
=>
$self
)
if
$self
->{parent};
}
sub
close
{
my
$self
=
shift
;
$self
->_close;
$self
->{parent}->_change_children(
remove
=>
$self
)
if
$self
->{parent};
}
sub
_do_change_children
{
my
$self
=
shift
;
my
$how
=
shift
;
my
$children
=
$self
->{child_windows} ||= [];
$self
->_reap_dead_children;
if
(
$how
eq
"insert"
) {
my
(
$sub
,
$index
) =
@_
;
$index
=
@$children
if
$index
== -1;
splice
@$children
,
$index
, 0, (
$sub
);
weaken
$children
->[
$index
]
if
WEAKEN_CHILDREN;
}
elsif
(
$how
eq
"remove"
) {
my
(
$child
) =
@_
;
for
(
my
$i
= 0;
$i
<
@$children
; ) {
$i
++,
next
if
defined
$children
->[
$i
] and
$children
->[
$i
] !=
$child
;
splice
@$children
,
$i
, 1, ();
}
if
(
$self
->{focused_child} and
$self
->{focused_child} ==
$child
) {
undef
$self
->{focused_child};
}
}
}
sub
_change_children
{
my
$self
=
shift
;
if
( CHILD_WINDOWS_LATER ) {
my
$queue
=
$self
->{pending_geom_changes} ||=
do
{
my
@queue
;
$self
->tickit->later(
sub
{
$self
->_do_change_children(
@$_
)
for
@queue
;
undef
$self
->{pending_geom_changes};
});
\
@queue
;
};
push
@$queue
, [
@_
];
}
else
{
$self
->_do_change_children(
@_
);
}
}
sub
make_sub
{
my
$self
=
shift
;
my
(
$top
,
$left
,
$lines
,
$cols
) =
@_
;
my
$sub
=
bless
{
parent
=>
$self
,
},
ref
$self
;
$sub
->_init;
$self
->_reap_dead_children;
$sub
->change_geometry(
$top
,
$left
,
$lines
,
$cols
);
$self
->_change_children(
insert
=>
$sub
, -1 );
return
$sub
;
}
sub
make_hidden_sub
{
my
$self
=
shift
;
my
$sub
=
$self
->make_sub(
@_
);
$sub
->{visible} = 0;
return
$sub
;
}
sub
make_float
{
my
$self
=
shift
;
my
(
$top
,
$left
,
$lines
,
$cols
) =
@_
;
my
$sub
=
bless
{
parent
=>
$self
,
},
ref
$self
;
$sub
->_init;
$self
->_reap_dead_children;
$sub
->change_geometry(
$top
,
$left
,
$lines
,
$cols
);
$self
->_change_children(
insert
=>
$sub
, 0 );
return
$sub
;
}
sub
make_popup
{
my
$win
=
shift
;
my
(
$top
,
$left
,
$lines
,
$cols
) =
@_
;
while
(
$win
->parent ) {
$top
+=
$win
->top;
$left
+=
$win
->left;
$win
=
$win
->parent;
}
my
$popup
=
$win
->make_float(
$top
,
$left
,
$lines
,
$cols
);
$popup
->{steal_input} = 1;
return
$popup
;
}
sub
raise
{
my
$self
=
shift
;
croak
"Cannot ->raise the root window"
unless
my
$parent
=
$self
->parent;
$self
->parent->_reorder_child(
$self
, -1 );
}
sub
lower
{
my
$self
=
shift
;
croak
"Cannot ->lower the root window"
unless
my
$parent
=
$self
->parent;
$self
->parent->_reorder_child(
$self
, +1 );
}
sub
raise_to_front
{
my
$self
=
shift
;
croak
"Cannot ->raise_to_front the root window"
unless
my
$parent
=
$self
->parent;
$self
->parent->_reorder_child(
$self
,
"front"
);
}
sub
lower_to_back
{
my
$self
=
shift
;
croak
"Cannot ->lower_to_back the root window"
unless
my
$parent
=
$self
->parent;
$self
->parent->_reorder_child(
$self
,
"back"
);
}
sub
_reorder_child
{
my
$self
=
shift
;
my
(
$child
,
$where
) =
@_
;
my
$children
=
$self
->{child_windows} or
return
;
my
$idx
= first { refaddr(
$child
) == refaddr(
$children
->[
$_
]) } 0 ..
$#$children
;
defined
$idx
or croak
"$child is not a child of $self"
;
splice
@$children
,
$idx
, 1, ();
if
(
$where
eq
"front"
) {
unshift
@$children
,
$child
;
}
elsif
(
$where
eq
"back"
) {
push
@$children
,
$child
;
}
else
{
splice
@$children
,
$idx
+
$where
, 0, (
$child
);
}
$self
->expose(
$child
->rect );
}
sub
_reap_dead_children
{
my
$self
=
shift
;
my
$children
=
$self
->{child_windows} or
return
;
for
(
my
$i
= 0;
$i
<
@$children
; ) {
$i
++,
next
if
defined
$children
->[
$i
];
splice
@$children
,
$i
, 1, ();
}
}
sub
parent
{
my
$self
=
shift
;
return
$self
->{parent};
}
sub
subwindows
{
my
$self
=
shift
;
return
@{
$self
->{child_windows} };
}
sub
root
{
my
$win
=
shift
;
while
(
my
$parent
=
$win
->{parent} ) {
$win
=
$parent
;
}
return
$win
;
}
sub
term
{
my
$self
=
shift
;
return
$self
->root->{term};
}
sub
tickit
{
my
$self
=
shift
;
return
$self
->root->{tickit};
}
sub
show
{
my
$self
=
shift
;
$self
->{visible} = 1;
if
(
my
$parent
=
$self
->parent ) {
if
( !
$parent
->{focused_child} and
$self
->{focused_child} ||
$self
->is_focused ) {
$parent
->{focused_child} =
$self
;
weaken
$parent
->{focused_child}
if
WEAKEN_CHILDREN;
}
}
$self
->expose;
}
sub
hide
{
my
$self
=
shift
;
$self
->{visible} = 0;
if
(
my
$parent
=
$self
->parent ) {
if
(
$parent
->{focused_child} and
$parent
->{focused_child} ==
$self
) {
undef
$parent
->{focused_child};
}
$parent
->_do_expose(
$self
->rect );
}
$self
->restore;
}
sub
is_visible
{
my
$self
=
shift
;
return
$self
->{visible};
}
sub
resize
{
my
$self
=
shift
;
my
(
$lines
,
$cols
) =
@_
;
$self
->change_geometry(
$self
->top,
$self
->left,
$lines
,
$cols
);
}
sub
reposition
{
my
$self
=
shift
;
my
(
$top
,
$left
) =
@_
;
$self
->change_geometry(
$top
,
$left
,
$self
->lines,
$self
->cols );
$self
->restore
if
$self
->is_focused;
}
sub
change_geometry
{
my
$self
=
shift
;
my
(
$top
,
$left
,
$lines
,
$cols
) =
@_
;
$lines
> 0 or croak
'lines zero or negative'
;
$cols
> 0 or croak
'cols zero or negative'
;
if
( !
defined
$self
->{top} or
$self
->{lines} !=
$lines
or
$self
->{cols} !=
$cols
or
$self
->{top} !=
$top
or
$self
->{left} !=
$left
) {
$self
->{lines} =
$lines
;
$self
->{cols} =
$cols
;
$self
->{top} =
$top
;
$self
->{left} =
$left
;
$self
->{on_geom_changed}->(
$self
)
if
$self
->{on_geom_changed};
}
}
sub
set_on_geom_changed
{
my
$self
=
shift
;
(
$self
->{on_geom_changed} ) =
@_
;
}
sub
set_on_key
{
my
$self
=
shift
;
(
$self
->{on_key} ) =
@_
;
}
sub
_handle_key
{
my
$self
=
shift
;
my
(
$args
) =
@_
;
return
0
unless
$self
->is_visible;
$self
->_reap_dead_children;
my
$children
=
$self
->{child_windows};
if
(
$children
and
@$children
and
$children
->[0]->{steal_input} ) {
$children
->[0]->_handle_key(
$args
) and
return
;
}
my
$focused_child
=
$self
->{focused_child};
if
(
$focused_child
) {
$focused_child
->_handle_key(
$args
) and
return
1;
}
if
(
my
$on_key
=
$self
->{on_key} ) {
$on_key
->(
$self
,
Tickit::Window::Event->new(
%$args
),
$args
->{str},
$args
->{mod},
) and
return
1;
}
if
(
$children
) {
foreach
my
$child
(
@$children
) {
next
unless
$child
;
next
if
$focused_child
and
$child
==
$focused_child
;
$child
->_handle_key(
$args
);
}
}
return
0;
}
sub
set_on_mouse
{
my
$self
=
shift
;
(
$self
->{on_mouse} ) =
@_
;
}
sub
_handle_mouse
{
my
$self
=
shift
;
my
(
$args
) =
@_
;
return
unless
$self
->is_visible;
my
$line
=
$args
->{line};
my
$col
=
$args
->{col};
if
(
my
$children
=
$self
->{child_windows} ) {
foreach
my
$child
(
@$children
) {
next
unless
$child
;
my
$child_line
=
$line
-
$child
->top;
my
$child_col
=
$col
-
$child
->left;
if
( !
$child
->{steal_input} ) {
next
if
$child_line
< 0 or
$child_line
>=
$child
->lines;
next
if
$child_col
< 0 or
$child_col
>=
$child
->cols;
}
my
$childargs
= {
%$args
,
line
=>
$child_line
,
col
=>
$child_col
,
};
my
$ret
=
$child
->_handle_mouse(
$childargs
);
return
$ret
if
$ret
;
}
}
if
(
my
$on_mouse
=
$self
->{on_mouse} ) {
return
$self
if
$on_mouse
->(
$self
,
Tickit::Window::Event->new(
%$args
),
$args
->{button},
$args
->{line},
$args
->{col},
$args
->{mod},
);
}
return
0;
}
sub
set_on_expose
{
my
$self
=
shift
;
(
$self
->{on_expose} ) =
@_
;
}
sub
_do_expose
{
my
$self
=
shift
;
my
(
$rect
) =
@_
;
$self
->{damage}->add(
$rect
);
my
@rects
=
$self
->{damage}->rects;
$self
->{damage}->clear;
if
(
my
$on_expose
=
$self
->{on_expose} ) {
$on_expose
->(
$self
,
$_
)
for
@rects
;
}
my
$children
=
$self
->{child_windows} or
return
;
foreach
my
$win
(
sort
{
$a
->top <=>
$b
->top ||
$a
->left <=>
$b
->left }
grep
{
defined
}
@$children
) {
foreach
my
$rect
(
@rects
) {
next
unless
my
$winrect
=
$rect
->intersect(
$win
->rect );
next
unless
$win
->{visible};
$win
->_do_expose(
$winrect
->translate( -
$win
->top, -
$win
->left ) );
}
}
}
sub
expose
{
my
$self
=
shift
;
my
(
$rect
) =
@_
;
$rect
||= Tickit::Rect->new(
top
=> 0,
left
=> 0,
lines
=>
$self
->lines,
cols
=>
$self
->cols,
);
return
if
$self
->_expose_pending(
$rect
);
$self
->{damage}->add(
$rect
);
$self
->tickit->enqueue_redraw(
sub
{
my
@rects
=
$self
->{damage}->rects;
$self
->{damage}->clear;
$self
->_expose_pending(
$_
) or
$self
->_do_expose(
$_
)
for
@rects
;
} );
}
sub
_expose_pending
{
my
$self
=
shift
;
my
(
$rect
) =
@_
;
return
1
if
$self
->{damage}->contains(
$rect
);
return
0
unless
$self
->parent;
return
$self
->parent->_expose_pending(
$rect
->translate(
$self
->top,
$self
->left ) );
}
sub
set_on_focus
{
my
$self
=
shift
;
(
$self
->{on_focus} ) =
@_
;
}
sub
set_expose_after_scroll
{
my
$self
=
shift
;
(
$self
->{expose_after_scroll} ) =
@_
;
}
sub
top
{
my
$self
=
shift
;
return
$self
->{top};
}
sub
bottom
{
my
$self
=
shift
;
return
$self
->top +
$self
->lines;
}
sub
left
{
my
$self
=
shift
;
return
$self
->{left};
}
sub
right
{
my
$self
=
shift
;
return
$self
->left +
$self
->cols;
}
sub
abs_top
{
my
$win
=
shift
;
my
$top
=
$win
->{top};
while
(
$win
=
$win
->{parent} ) {
$top
+=
$win
->{top};
}
return
$top
;
}
sub
abs_left
{
my
$win
=
shift
;
my
$left
=
$win
->{left};
while
(
$win
=
$win
->{parent} ) {
$left
+=
$win
->{left};
}
return
$left
;
}
sub
cols
{
my
$self
=
shift
;
return
$self
->{cols};
}
sub
lines
{
my
$self
=
shift
;
return
$self
->{lines};
}
sub
rect
{
my
$self
=
shift
;
return
Tickit::Rect->new(
top
=>
$self
->top,
left
=>
$self
->left,
lines
=>
$self
->lines,
cols
=>
$self
->cols,
);
}
sub
pen
{
my
$self
=
shift
;
return
$self
->{pen};
}
sub
set_pen
{
my
$self
=
shift
;
(
$self
->{pen} ) =
@_
;
defined
$self
->{pen} or
$self
->{pen} = Tickit::Pen->new;
}
sub
getpenattr
{
my
$self
=
shift
;
my
(
$attr
) =
@_
;
return
$self
->{pen}->getattr(
$attr
);
}
sub
getpenattrs
{
my
$self
=
shift
;
return
$self
->{pen}->getattrs;
}
sub
get_effective_pen
{
my
$win
=
shift
;
my
$pen
=
$win
->pen->as_mutable;
for
(
my
$parent
=
$win
->parent;
$parent
;
$parent
=
$parent
->parent ) {
$pen
->default_from(
$parent
->pen );
}
return
$pen
;
}
sub
get_effective_penattr
{
my
$win
=
shift
;
my
(
$attr
) =
@_
;
for
( ;
$win
;
$win
=
$win
->parent ) {
my
$value
=
$win
->pen->getattr(
$attr
);
return
$value
if
defined
$value
;
}
return
undef
;
}
sub
get_effective_penattrs
{
my
$self
=
shift
;
return
$self
->get_effective_pen->getattrs;
}
sub
_get_span_visibility
{
my
$win
=
shift
;
my
(
$line
,
$col
) =
@_
;
my
(
$vis
,
$len
) = ( 1,
$win
->cols -
$col
);
my
$prev
;
while
(
$win
) {
if
(
$line
< 0 or
$line
>=
$win
->lines or
$col
>=
$win
->cols ) {
return
( 0,
undef
);
}
if
(
$col
< 0 ) {
$len
= -
$col
if
$vis
or -
$col
>
$len
;
$vis
= 0;
}
elsif
(
$vis
) {
my
$remains
=
$win
->cols -
$col
;
$len
=
$remains
if
$len
>
$remains
;
}
$win
->_reap_dead_children;
foreach
my
$child
( @{
$win
->{child_windows} } ) {
last
if
$prev
and
$child
==
$prev
;
next
unless
$child
->{visible};
next
if
$child
->top >
$line
or
$child
->bottom <=
$line
;
next
if
$col
>=
$child
->right;
if
(
$child
->left <=
$col
) {
my
$child_cols_hidden
=
$child
->right -
$col
;
if
(
$vis
) {
$len
=
$child_cols_hidden
;
$vis
= 0;
}
else
{
$len
=
$child_cols_hidden
if
$child_cols_hidden
>
$len
;
}
}
elsif
(
$vis
) {
my
$remaining_visible
=
$child
->left -
$col
;
$len
=
$remaining_visible
if
$remaining_visible
<
$len
;
}
}
$line
+=
$win
->top;
$col
+=
$win
->left;
$prev
=
$win
;
$win
=
$win
->parent;
}
return
(
$vis
,
$len
);
}
sub
goto
{
my
$win
=
shift
;
my
(
$line
,
$col
) =
@_
;
$win
->{output_line} =
$line
;
$win
->{output_column} =
$col
;
$win
->{output_needs_goto} = 0;
my
(
$vis
) =
$win
->_get_span_visibility(
$line
,
$col
);
return
unless
$vis
;
while
(
$win
) {
return
if
$line
< 0 or
$line
>=
$win
->lines;
return
if
$col
< 0 or
$col
>=
$win
->cols;
return
unless
$win
->{visible};
$line
+=
$win
->top;
$col
+=
$win
->left;
my
$parent
=
$win
->parent or
last
;
$win
=
$parent
;
}
$win
->term->
goto
(
$line
,
$col
);
$win
->_needs_flush;
}
sub
print
{
my
$self
=
shift
;
my
$text
=
shift
;
my
$pen
= (
@_
== 1 ) ?
shift
->as_mutable : Tickit::Pen::Mutable->new(
@_
);
for
(
my
$win
=
$self
;
$win
;
$win
=
$win
->parent ) {
return
unless
$win
->{visible};
$pen
->default_from(
$win
->pen );
}
my
$line
=
$self
->{output_line};
my
$term
=
$self
->term;
my
$need_goto
=
$self
->{output_needs_goto};
my
(
$abs_top
,
$abs_left
);
my
$need_flush
= 0;
my
$pos
= Tickit::StringPos->zero;
my
$total_len
=
length
$text
;
while
(
$pos
->codepoints <
$total_len
) {
my
(
$vis
,
$cols
) =
$self
->_get_span_visibility(
$line
,
$self
->{output_column} +
$pos
->columns );
if
( !
$vis
and !
defined
$cols
) {
string_countmore(
$text
,
$pos
,
undef
,
$pos
->bytes );
last
;
}
my
$prev_cp
=
$pos
->codepoints;
my
$prev_col
=
$pos
->columns;
defined
string_countmore(
$text
,
$pos
, Tickit::StringPos->limit_columns(
$cols
+
$pos
->columns ),
$pos
->bytes ) or
croak
"Encountered non-Unicode text in ->print; bailing out"
;
my
$chunk
=
substr
$text
,
$prev_cp
,
$pos
->codepoints -
$prev_cp
;
if
(
$vis
) {
if
(
$need_goto
) {
$abs_top
//=
$self
->abs_top;
$abs_left
//=
$self
->abs_left;
$term
->
goto
(
$abs_top
+
$line
,
$abs_left
+
$self
->{output_column} +
$prev_col
);
$need_goto
= 0;
}
$term
->setpen(
$pen
);
$term
->
print
(
$chunk
);
$need_flush
= 1;
}
else
{
$need_goto
= 1;
}
}
$self
->{output_column} +=
$pos
->columns;
$self
->root->_needs_flush
if
$need_flush
;
$self
->{output_needs_goto} =
$need_goto
;
return
$pos
;
}
sub
erasech
{
my
$self
=
shift
;
my
$count
=
shift
;
my
$moveend
=
shift
;
my
$pen
= (
@_
== 1 ) ?
shift
->as_mutable : Tickit::Pen::Mutable->new(
@_
);
for
(
my
$win
=
$self
;
$win
;
$win
=
$win
->parent ) {
return
unless
$win
->{visible};
$pen
->default_from(
$win
->pen );
}
my
$line
=
$self
->{output_line};
my
$term
=
$self
->term;
my
$need_goto
=
$self
->{output_needs_goto};
my
(
$abs_top
,
$abs_left
);
my
$need_flush
= 0;
my
$orig_count
=
$count
;
while
(
$count
) {
my
(
$vis
,
$len
) =
$self
->_get_span_visibility(
$line
,
$self
->{output_column} );
last
if
!
$vis
and !
defined
$len
;
$len
=
$count
if
$len
>
$count
;
if
(
$vis
) {
if
(
$need_goto
) {
$abs_top
//=
$self
->abs_top;
$abs_left
//=
$self
->abs_left;
$term
->
goto
(
$abs_top
+
$line
,
$abs_left
+
$self
->{output_column} );
$need_goto
= 0;
}
$term
->setpen(
$pen
);
$term
->erasech(
$len
,
$moveend
);
$need_flush
= 1;
}
else
{
$need_goto
= 1;
}
$self
->{output_column} +=
$len
;
$count
-=
$len
;
}
$self
->root->_needs_flush
if
$need_flush
;
$self
->{output_needs_goto} =
$need_goto
;
return
if
!
defined
wantarray
;
return
Tickit::StringPos->limit_columns(
$orig_count
);
}
sub
clearrect
{
my
$self
=
shift
;
my
$rect
=
shift
;
my
$pen
= (
@_
== 1 ) ?
shift
->as_mutable : Tickit::Pen::Mutable->new(
@_
);
if
(
$rect
->top == 0 and
$rect
->left == 0 and
$rect
->bottom ==
$self
->lines and
$rect
->right ==
$self
->cols ) {
$self
->clear;
return
;
}
foreach
my
$line
(
$rect
->linerange ) {
$self
->
goto
(
$line
,
$rect
->left );
$self
->erasech(
$rect
->cols,
undef
,
$pen
);
}
}
sub
_scrollrect_inner
{
my
$self
=
shift
;
my
(
$rect
,
$downward
,
$rightward
,
@args
) =
@_
;
if
(
abs
(
$downward
) >=
$rect
->lines or
abs
(
$rightward
) >=
$rect
->cols ) {
$self
->expose(
$rect
)
if
$self
->{expose_after_scroll};
return
1;
}
my
$pen
= (
@args
== 1 ) ?
$args
[0]->as_mutable : Tickit::Pen::Mutable->new(
@args
);
my
$top
=
$rect
->top;
my
$left
=
$rect
->left;
my
$lines
=
$rect
->lines;
my
$cols
=
$rect
->cols;
my
$win
=
$self
;
while
(
$win
) {
$top
>= 0 and
$top
<
$win
->lines or croak
'$top out of bounds'
;
$left
>= 0 and
$left
<
$win
->cols or croak
'$left out of bounds'
;
$lines
> 0 and
$top
+
$lines
<=
$win
->lines or croak
'$lines out of bounds'
;
$cols
> 0 and
$left
+
$cols
<=
$win
->cols or croak
'$cols out of bounds'
;
return
unless
$win
->{visible};
$pen
->default_from(
$win
->pen );
$top
+=
$win
->top;
$left
+=
$win
->left;
my
$parent
=
$win
->parent or
last
;
$win
=
$parent
;
}
my
$term
=
$win
->term;
$term
->setpen(
bg
=>
$pen
->getattr(
'bg'
) );
unless
(
$term
->scrollrect(
$top
,
$left
,
$lines
,
$cols
,
$downward
,
$rightward
) ) {
$self
->expose(
$rect
)
if
$self
->{expose_after_scroll};
return
0;
}
if
(
$self
->{expose_after_scroll} ) {
if
(
$downward
> 0 ) {
$self
->expose( Tickit::Rect->new(
top
=>
$rect
->bottom -
$downward
,
lines
=>
$downward
,
left
=>
$rect
->left,
cols
=>
$rect
->cols,
) );
}
elsif
(
$downward
< 0 ) {
$self
->expose( Tickit::Rect->new(
top
=>
$rect
->top,
lines
=> -
$downward
,
left
=>
$rect
->left,
cols
=>
$rect
->cols,
) );
}
if
(
$rightward
> 0 ) {
$self
->expose( Tickit::Rect->new(
top
=>
$rect
->top,
lines
=>
$rect
->lines,
left
=>
$rect
->right -
$rightward
,
cols
=>
$rightward
,
) );
}
elsif
(
$rightward
< 0 ) {
$self
->expose( Tickit::Rect->new(
top
=>
$rect
->top,
lines
=>
$rect
->lines,
left
=>
$rect
->left,
cols
=> -
$rightward
,
) );
}
}
else
{
$self
->_needs_flush;
}
return
1;
}
sub
scrollrect
{
my
$self
=
shift
;
my
(
$top
,
$left
,
$lines
,
$cols
,
$downward
,
$rightward
,
@args
) =
@_
;
my
$rect
= Tickit::Rect->new(
top
=>
$top
,
left
=>
$left
,
lines
=>
$lines
,
cols
=>
$cols
,
);
my
$visible
= Tickit::RectSet->new;
$visible
->add(
$rect
);
my
$right
=
$left
+
$cols
;
foreach
my
$line
(
$top
..
$top
+
$lines
- 1 ) {
my
$col
=
$left
;
while
(
$col
<
$right
) {
my
(
$vis
,
$len
) =
$self
->_get_span_visibility(
$line
,
$col
);
$col
+=
$len
and
next
if
$vis
;
my
$until
=
defined
$len
?
$col
+
$len
:
$right
;
return
0
unless
$self
->{expose_after_scroll};
$visible
->subtract( Tickit::Rect->new(
top
=>
$line
,
bottom
=>
$line
+1,
left
=>
$col
,
right
=>
$until
,
) );
$col
=
$until
;
}
}
my
@rects
=
$self
->{damage}->rects;
$self
->{damage}->clear;
foreach
my
$r
(
@rects
) {
$self
->{damage}->add(
$r
),
next
if
$r
->bottom <
$top
or
$r
->top >
$top
+
$lines
or
$r
->right <
$left
or
$r
->left >
$left
+
$cols
;
my
$inside
=
$r
->intersect(
$rect
);
my
@outside
=
$r
->subtract(
$rect
);
$self
->{damage}->add(
$_
)
for
@outside
;
$self
->{damage}->add(
$inside
->translate( -
$downward
, -
$rightward
) )
if
$inside
;
}
my
$ret
= 1;
foreach
my
$r
(
$visible
->rects ) {
$self
->_scrollrect_inner(
$r
,
$downward
,
$rightward
,
@args
) or
$ret
= 0;
}
return
$ret
;
}
sub
scroll
{
my
$self
=
shift
;
my
(
$downward
,
$rightward
) =
@_
;
return
$self
->scrollrect(
0, 0,
$self
->lines,
$self
->cols,
$downward
,
$rightward
);
}
sub
cursor_at
{
my
$self
=
shift
;
(
$self
->{cursor_line},
$self
->{cursor_col} ) =
@_
;
$self
->tickit->enqueue_redraw
if
$self
->is_focused;
}
sub
cursor_shape
{
my
$self
=
shift
;
(
$self
->{cursor_shape} ) =
@_
;
$self
->tickit->enqueue_redraw
if
$self
->is_focused;
}
sub
take_focus
{
my
$self
=
shift
;
my
(
$focuswin
) =
@_
;
$self
->_focus_gained
}
sub
focus
{
my
$self
=
shift
;
$self
->cursor_at(
@_
);
$self
->take_focus;
}
sub
_focus_gained
{
my
$self
=
shift
;
my
(
$child
) =
@_
;
if
(
$self
->{focused_child} and
defined
$child
and
$self
->{focused_child} !=
$child
) {
$self
->{focused_child}->_focus_lost;
}
if
(
my
$parent
=
$self
->parent ) {
$parent
->_focus_gained(
$self
)
if
$self
->is_visible;
}
else
{
$self
->tickit->enqueue_redraw;
}
if
( !
$child
) {
$self
->{focused} = 1;
$self
->{on_focus}->(
$self
, 1 )
if
$self
->{on_focus};
}
$self
->{focused_child} =
$child
;
weaken
$self
->{focused_child}
if
WEAKEN_CHILDREN;
}
sub
_focus_lost
{
my
$self
=
shift
;
if
(
my
$focused_child
=
$self
->{focused_child} ) {
$focused_child
->_focus_lost;
}
if
(
$self
->{focused} ) {
undef
$self
->{focused};
$self
->{on_focus}->(
$self
, 0 )
if
$self
->{on_focus};
}
}
sub
is_focused
{
my
$self
=
shift
;
return
defined
$self
->{focused};
}
sub
restore
{
my
$self
=
shift
;
my
$root
=
$self
->root;
my
$term
=
$root
->term;
my
$win
=
$root
;
while
(
$win
) {
last
unless
$win
->is_visible;
last
unless
$win
->{focused_child};
$win
=
$win
->{focused_child};
}
if
(
$win
and
$win
->is_visible and
$win
->is_focused ) {
$term
->setctl_int(
cursorvis
=> 1 );
$win
->
goto
(
$win
->{cursor_line},
$win
->{cursor_col} );
$win
->term->setctl_int(
cursorshape
=>
$win
->{cursor_shape} // Tickit::Term::TERM_CURSORSHAPE_BLOCK );
}
else
{
$term
->setctl_int(
cursorvis
=> 0 );
}
}
sub
clearline
{
my
$self
=
shift
;
my
(
$line
) =
@_
;
return
unless
$self
->{visible};
$self
->
goto
(
$line
, 0 );
$self
->erasech(
$self
->cols );
}
sub
clear
{
my
$self
=
shift
;
return
unless
$self
->{visible};
if
(
$self
->parent ) {
$self
->clearline(
$_
)
for
0 ..
$self
->lines - 1;
}
else
{
my
$term
=
$self
->term;
$term
->setpen(
$self
->get_effective_pen );
$term
->clear;
$self
->_needs_flush;
}
}
sub
_needs_flush
{
my
$self
=
shift
;
return
if
$self
->{flush_queued};
$self
->tickit->later(
sub
{
$self
->term->flush;
undef
$self
->{flush_queued};
} );
$self
->{flush_queued}++;
}
'""'
=>
sub
{
my
$self
=
shift
;
return
sprintf
"%s[%dx%d abs@%d,%d]"
,
ref
$self
,
$self
->cols,
$self
->lines,
$self
->abs_left,
$self
->abs_top;
},
'0+'
=>
sub
{
my
$self
=
shift
;
return
$self
;
},
bool
=>
sub
{ 1 },
fallback
=> 1;
package
Tickit::Window::Event;
sub
new
{
my
$class
=
shift
;
bless
{
@_
},
$class
;
}
foreach
my
$key
(
qw( type str mod button line col )
) {
no
strict
'refs'
;
*$key
=
sub
{
exists
$_
[0]{
$key
} ?
$_
[0]{
$key
} : croak
"Event has no '$key' field"
}
}
'""'
=>
"type"
,
fallback
=> 1;
0x55AA;