$VERSION
=
'0.15'
;
Tk::Widget->Construct(
'GridColumns'
);
sub
ClassInit {
my
(
$class
,
$mw
) =
@_
;
$class
->SUPER::ClassInit(
$mw
);
}
sub
Populate {
my
(
$self
,
$args
) =
@_
;
$self
->{
'_gridded'
} = [0,0];
$self
->{
'_selected'
} = [];
$self
->{
'_select_mode'
} =
delete
$args
->{-selectmode} ||
'single row'
;
$self
->{
'_data'
} =
delete
$args
->{-data} || [];
$self
->{
'_columns'
} =
delete
$args
->{-columns} || [];
$self
->{
'_col_attr'
} =
delete
$args
->{-colattr} || {};
$self
->{
'_col_grid'
} =
delete
$args
->{-colgrid} || {};
$self
->{
'_item_attr'
} =
delete
$args
->{-itemattr} || {};
$self
->{
'_item_grid'
} =
delete
$args
->{-itemgrid} || {};
$self
->{
'_item_draw_cmd'
} =
delete
$args
->{-item_draw_cmd} || \
&_item_draw_cmd
;
$self
->{
'_select_cmd'
} =
delete
$args
->{-select_cmd} || \
&_select_cmd
;
$self
->{
'_deselect_cmd'
} =
delete
$args
->{-deselect_cmd} || \
&_deselect_cmd
;
$self
->{
'_item_bindings'
} = {
'<ButtonPress-1>'
=> \
&_button_press
,
'<Control-ButtonPress-1>'
=> \
&_ctrl_button_press
,
'<Shift-ButtonPress-1>'
=> \
&_shift_button_press
,
%{
delete
$args
->{-item_bindings} || {} },
};
$args
->{
'-gridded'
} =
'xy'
;
$args
->{
'-sticky'
} =
'nsew'
;
$args
->{
'-takefocus'
} = 1;
$self
->SUPER::Populate(
$args
);
$self
->ConfigSpecs(
-selectmode
=> [
'METHOD'
],
-data
=> [
'METHOD'
],
-columns
=> [
'METHOD'
],
-colattr
=> [
'METHOD'
],
-colgrid
=> [
'METHOD'
],
-itemattr
=> [
'METHOD'
],
-itemgrid
=> [
'METHOD'
],
-item_bindings
=> [
'METHOD'
],
-item_draw_cmd
=> [
'METHOD'
],
-select_cmd
=> [
'METHOD'
],
-deselect_cmd
=> [
'METHOD'
],
'DEFAULT'
=> [
'SELF'
],
);
$self
->refresh;
return
$self
;
}
sub
_button_press {
my
(
$self
,
$w
,
$row
,
$col
) =
@_
;
$w
->focus;
my
@mode
=
$self
->selectmode;
return
if
$mode
[0] eq
'none'
;
$self
->clear_selection;
if
(
$mode
[1] eq
'row'
) {
$self
->
select
(
$row
,
$_
)
for
0 .. $
}
else
{
$self
->
select
(
$row
,
$col
);
}
}
sub
_ctrl_button_press {
my
(
$self
,
$w
,
$row
,
$col
) =
@_
;
$w
->focus;
my
@mode
=
$self
->selectmode;
return
if
$mode
[0] eq
'none'
;
my
$method
=
$self
->selected->[
$row
]->[
$col
] ?
'deselect'
:
'select'
;
$self
->clear_selection
if
$mode
[0] eq
'single'
;
if
(
$mode
[1] eq
'row'
) {
$self
->
$method
(
$row
,
$_
)
for
0 .. $
}
else
{
$self
->
$method
(
$row
,
$col
);
}
}
sub
_shift_button_press {
my
(
$self
,
$w
,
$row
,
$col
) =
@_
;
$w
->focus;
my
@mode
=
$self
->selectmode;
return
if
$mode
[0] eq
'none'
;
my
@cur_sel
= @{
$self
->curselection };
if
(
$mode
[0] eq
'single'
or !
@cur_sel
) {
$self
->item_bindings->{
'<ButtonPress-1>'
}->(
@_
);
}
else
{
my
$fst_sel
=
$cur_sel
[ 0]->[0];
my
$lst_sel
=
$cur_sel
[-1]->[0];
my
$orient
=
$row
<
$fst_sel
?
$fst_sel
:
$row
>
$lst_sel
?
$lst_sel
: -1;
if
(
$orient
!= -1 ) {
for
my
$y
(
$row
>
$orient
? (
$orient
+1 ..
$row
) : (
$row
..
$orient
-1 ) ) {
for
my
$x
(
$mode
[1] eq
'row'
? ( 0 .. $
$self
->
select
(
$y
,
$x
);
}
}
}
else
{
$orient
=
abs
(
$row
-
$lst_sel
) >
abs
(
$row
-
$fst_sel
) ?
$fst_sel
:
$lst_sel
;
for
my
$y
(
$row
>
$orient
? (
$orient
..
$row
) : (
$row
..
$orient
) ) {
for
my
$x
(
$mode
[1] eq
'row'
? ( 0 .. $
$self
->deselect(
$y
,
$x
);
}
}
}
}
}
sub
_item_draw_cmd {
my
(
$self
,
$text
,
$attr
,
$row
,
$col
) =
@_
;
my
$w
=
$self
->Label(
-bg
=>
$self
->cget(-bg) );
$w
->configure(
%$attr
);
$w
->configure(
-text
=>
$text
);
return
$w
;
}
sub
_select_cmd {
my
(
$self
,
$w
,
$row
,
$col
) =
@_
;
$w
->configure(
-background
=>
'blue'
,
-foreground
=>
'white'
,
);
}
sub
_deselect_cmd {
my
(
$self
,
$w
,
$row
,
$col
) =
@_
;
$w
->configure(
-background
=>
$self
->cget(-background),
-foreground
=>
'black'
,
);
$w
->configure( %{
$self
->itemattr } );
}
sub
selectmode {
my
(
$self
,
$value
) =
@_
;
if
(
@_
> 1 ) {
$self
->{
'_select_mode'
} =
$value
;
return
$self
;
}
return
wantarray
?
split
(
' '
,
$self
->{
'_select_mode'
} )
:
$self
->{
'_select_mode'
};
}
sub
data {
my
(
$self
,
$value
) =
@_
;
if
(
@_
> 1 ) {
$self
->{
'_data'
} =
$value
;
return
$self
;
}
return
$self
->{
'_data'
};
}
sub
columns {
my
(
$self
,
$value
) =
@_
;
if
(
@_
> 1 ) {
$self
->{
'_columns'
} =
$value
;
return
$self
;
}
return
$self
->{
'_columns'
};
}
sub
colattr {
my
(
$self
,
$value
) =
@_
;
if
(
@_
> 1 ) {
$self
->{
'_col_attr'
} =
$value
;
return
$self
;
}
return
$self
->{
'_col_attr'
};
}
sub
colgrid {
my
(
$self
,
$value
) =
@_
;
if
(
@_
> 1 ) {
$self
->{
'_col_grid'
} =
$value
;
return
$self
;
}
return
$self
->{
'_col_grid'
};
}
sub
itemattr {
my
(
$self
,
$value
) =
@_
;
if
(
@_
> 1 ) {
$self
->{
'_item_attr'
} =
$value
;
return
$self
;
}
return
$self
->{
'_item_attr'
};
}
sub
itemgrid {
my
(
$self
,
$value
) =
@_
;
if
(
@_
> 1 ) {
$self
->{
'_item_grid'
} =
$value
;
return
$self
;
}
return
$self
->{
'_item_grid'
};
}
sub
selected {
my
(
$self
,
$value
) =
@_
;
if
(
@_
> 1 ) {
$self
->{
'_selected'
} =
$value
;
return
$self
;
}
return
$self
->{
'_selected'
};
}
sub
item_draw_cmd {
my
(
$self
,
$value
) =
@_
;
if
(
@_
> 1 ) {
$self
->{
'_item_draw_cmd'
} =
$value
;
return
$self
;
}
return
$self
->{
'_item_draw_cmd'
};
}
sub
select_cmd {
my
(
$self
,
$value
) =
@_
;
if
(
@_
> 1 ) {
$self
->{
'_select_cmd'
} =
$value
;
return
$self
;
}
return
$self
->{
'_select_cmd'
};
}
sub
deselect_cmd {
my
(
$self
,
$value
) =
@_
;
if
(
@_
> 1 ) {
$self
->{
'_deselect_cmd'
} =
$value
;
return
$self
;
}
return
$self
->{
'_deselect_cmd'
};
}
sub
item_bindings {
my
(
$self
,
$value
) =
@_
;
if
(
@_
> 1 ) {
$self
->{
'_item_bindings'
} =
$value
;
return
$self
;
}
return
$self
->{
'_item_bindings'
};
}
sub
select
{
my
(
$self
,
$row
,
$col
) =
@_
;
$self
->{
'_selected'
}->[
$row
]->[
$col
] = 1;
$self
->{
'_select_cmd'
}->(
$self
,
$self
->gridSlaves(
-row
=>
$row
+1,
-column
=>
$col
),
$row
,
$col
);
return
$self
;
}
sub
deselect {
my
(
$self
,
$row
,
$col
) =
@_
;
$self
->{
'_selected'
}->[
$row
]->[
$col
] = 0;
$self
->{
'_deselect_cmd'
}->(
$self
,
$self
->gridSlaves(
-row
=>
$row
+1,
-column
=>
$col
),
$row
,
$col
);
return
$self
;
}
sub
curselection {
my
(
$self
) =
@_
;
my
@selection
;
for
my
$row
( 0 .. $
for
my
$col
( 0 .. $
push
@selection
, [
$row
,
$col
]
if
$self
->{
'_selected'
}->[
$row
]->[
$col
];
}
}
splice
( @{
$self
->{
'_selected'
} }, 1 + $
return
\
@selection
;
}
sub
clear_selection {
my
(
$self
) =
@_
;
$self
->deselect(
@$_
)
for
@{
$self
->curselection };
return
$self
;
}
sub
refresh_selection {
my
(
$self
) =
@_
;
$self
->
select
(
@$_
)
for
@{
$self
->curselection };
return
$self
;
}
sub
add_column {
my
(
$self
,
%attr
) =
@_
;
push
@{
$self
->{
'_columns'
} }, \
%attr
;
return
$self
;
}
sub
add_row {
my
(
$self
,
@row
) =
@_
;
push
@{
$self
->{
'_data'
} }, \
@row
;
return
$self
;
}
sub
sort_col {
my
(
$self
,
$col
,
$sort
,
$rev
) =
@_
;
my
@sorted
=
sort
{
$sort
->(
$rev
? (
$self
->{
'_data'
}->[
$b
]->[
$col
],
$self
->{
'_data'
}->[
$a
]->[
$col
], )
: (
$self
->{
'_data'
}->[
$a
]->[
$col
],
$self
->{
'_data'
}->[
$b
]->[
$col
], )
);
} 0 .. $
@{
$self
->{
'_data'
} } =
map
{
$self
->{
'_data'
}->[
$_
] }
@sorted
;
@{
$self
->{
'_selected'
} } =
map
{
$self
->{
'_selected'
}->[
$_
] }
@sorted
;
return
$self
;
}
sub
sort_cmd {
my
(
$self
,
$col
,
$sort
) =
@_
;
my
$rev
= 0;
return
sub
{
$self
->sort_col(
$col
,
ref
$sort
?
$sort
:
$sort
eq
'num'
?
sub
{
$_
[0] <=>
$_
[1] }
:
sub
{
lc
(
$_
[0]) cmp
lc
(
$_
[1]) },
$rev
,
)->refresh_items;
$rev
= !
$rev
;
};
}
sub
draw_header {
my
(
$self
) =
@_
;
$self
->{
'_gridded'
}->[1] = $
my
@weight
=
map
{
exists
$self
->{
'_columns'
}->[
$_
]->{
'-weight'
}
? [
$_
,
delete
$self
->{
'_columns'
}->[
$_
]->{
'-weight'
} ]
: ()
} 0 .. $
for
my
$col
( 0 .. $
my
$w
=
$self
->Button( %{
$self
->{
'_col_attr'
} } )->grid(
%{
$self
->{
'_col_grid'
} },
-row
=> 0,
-column
=>
$col
,
-sticky
=>
'ew'
,
);
$w
->configure( %{
$self
->{
'_columns'
}->[
$col
] } );
}
for
my
$w
(
@weight
) {
$self
->gridColumnconfigure(
$w
->[0],
-weight
=>
$w
->[1] );
$self
->{
'_columns'
}->[
$w
->[0]]->{-weight} =
$w
->[1];
}
return
$self
;
}
sub
draw_items {
my
(
$self
) =
@_
;
$self
->{
'_gridded'
}->[0] = @{
$self
->{
'_data'
} };
for
my
$row
( 0 .. $
for
my
$col
( 0 .. $
my
$w
=
$self
->{
'_item_draw_cmd'
}->(
$self
,
$self
->{
'_data'
}->[
$row
]->[
$col
],
$self
->{
'_item_attr'
},
$row
,
$col
,
)->grid(
%{
$self
->{
'_item_grid'
} },
-row
=>
$row
+1,
-column
=>
$col
,
-sticky
=>
'nsew'
,
);
for
my
$seq
(
keys
%{
$self
->{
'_item_bindings'
} } ) {
$w
->
bind
(
$seq
,
sub
{
$self
->{
'_item_bindings'
}->{
$seq
}->(
$self
,
$w
,
$row
,
$col
) } );
}
}
}
return
$self
;
}
sub
set_filler {
my
(
$self
) =
@_
;
$self
->gridRowconfigure( 1 +
$self
->{
'_gridded'
}->[0],
-weight
=> 1 );
return
$self
;
}
sub
remove_filler {
my
(
$self
) =
@_
;
$self
->gridRowconfigure( 1 +
$self
->{
'_gridded'
}->[0],
-weight
=> 0 );
return
$self
;
}
sub
destroy_all {
my
(
$self
) =
@_
;
$_
->destroy
for
$self
->gridSlaves;
$self
->remove_filler;
$self
->gridColumnconfigure(
$_
,
-weight
=> 0 )
for
0 ..
$self
->{
'_gridded'
}->[1];
return
$self
;
}
sub
refresh {
my
(
$self
) =
@_
;
$self
->destroy_all->draw_header->draw_items->set_filler->refresh_selection;
return
$self
;
}
sub
refresh_header {
my
(
$self
) =
@_
;
$_
->destroy
for
$self
->gridSlaves(
-row
=> 0 );
$self
->gridColumnconfigure(
$_
,
-weight
=> 0 )
for
0 ..
$self
->{
'_gridded'
}->[1];
$self
->draw_header;
return
$self
;
}
sub
refresh_items {
my
(
$self
) =
@_
;
for
my
$row
( 1 ..
$self
->{
'_gridded'
}->[0] ) {
$_
->destroy
for
$self
->gridSlaves(
-row
=>
$row
);
}
$self
->remove_filler->draw_items->set_filler->refresh_selection;
return
$self
;
}
1;