#
# This file is part of Config-Model-TkUI
#
# This software is Copyright (c) 2014 by Dominique Dumont.
#
# This is free software, licensed under:
#
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::Tk::CheckListEditor ;
$Config::Model::Tk::CheckListEditor::VERSION = '1.341';
use strict;
use warnings ;
use Carp ;
use base qw/ Tk::Frame Config::Model::Tk::CheckListViewer/;
use vars qw/$icon_path/ ;
use subs qw/menu_struct/ ;
use Tk::NoteBook;
use Config::Model::Tk::NoteEditor ;
use Log::Log4perl;
Construct Tk::Widget 'ConfigModelCheckListEditor';
my $up_img;
my $down_img;
my $logger = Log::Log4perl::get_logger("Tk::CheckListEditor");
*icon_path = *Config::Model::TkUI::icon_path;
my @fbe1 = qw/-fill both -expand 1/ ;
my @fxe1 = qw/-fill x -expand 1/ ;
my @fx = qw/-fill x / ;
sub ClassInit {
my ($cw, $args) = @_;
# ClassInit is often used to define bindings and/or other
# resources shared by all instances, e.g., images.
# cw->Advertise(name=>$widget);
}
sub Populate {
my ($cw, $args) = @_;
my $leaf = $cw->{leaf} = delete $args->{-item}
|| die "CheckListEditor: no -item, got ",keys %$args;
delete $args->{-path} ;
$cw->{store_cb} = delete $args->{-store_cb} || die __PACKAGE__,"no -store_cb" ;
my $inst = $leaf->instance ;
$cw->add_header(Edit => $leaf)->pack(@fx) ;
my $nb = $cw->Component('NoteBook','notebook')->pack(@fbe1);
my $lb ;
my @choice = $leaf->get_choice ;
my $raise_cmd = sub{
$lb->selectionClear(0,'end') ;
my %h = $leaf->get_checked_list_as_hash ;
for (my $i=0; $i<@choice; $i++) {
$lb->selectionSet($i,$i) if $h{$choice[$i]} ;
}
} ;
my $ed_frame = $nb->add('content', -label => 'Change content',
-raisecmd => $raise_cmd ,
);
$lb = $ed_frame->Scrolled ( qw/Listbox -selectmode multiple/,
-scrollbars => 'osoe',
-height => 5,
) ->pack(@fbe1) ;
$lb->insert('end',@choice) ;
# mastering perl/Tk page 160
my $b_sub = sub {
my @selected = map { $choice[$_]} $lb->curselection ;
$cw->set_value_help(@selected);
} ;
$lb->bind('<<ListboxSelect>>',$b_sub);
my $bframe = $ed_frame->Frame->pack;
$bframe -> Button ( -text => 'Clear all',
-command => sub { $lb->selectionClear(0,'end') ; },
) -> pack(-side => 'left') ;
$bframe -> Button ( -text => 'Set all',
-command => sub { $lb->selectionSet(0,'end') ; },
) -> pack(-side => 'left') ;
$bframe -> Button ( -text => 'Reset',
-command => sub { $cw->reset_value ; },
) -> pack(-side => 'left') ;
$bframe -> Button ( -text => 'Store',
-command => sub { $cw->store ( )},
) -> pack(-side => 'left') ;
$cw->ConfigModelNoteEditor( -object => $leaf )->pack(@fbe1) ;
$cw->add_summary($leaf)->pack(@fx) ;
$cw->add_description($leaf)->pack(@fx) ;
my ($help_frame, $help_widget) = $cw->add_help(value => '',1);
$help_frame->pack(@fx);
$cw->{value_help_widget} = $help_widget ;
$cw->add_info_button()->pack(@fxe1) ;
$b_sub->() ;
# Add a second page to edit the list order for ordered check list
if ($leaf->ordered) {
$cw->add_change_order_page($nb,$leaf) ;
}
$cw->Advertise('listbox' => $lb ) ;
# don't call directly SUPER::Populate as it's CheckListViewer's populate
$cw->Tk::Frame::Populate($args) ;
}
sub add_change_order_page {
my ($cw,$nb,$leaf) = @_ ;
my $order_list ;
my $raise_cmd = sub{
$order_list->delete(0,'end');
$order_list->insert( end => $leaf->get_checked_list) ;
} ;
my $order_frame = $nb->add('order', -label => 'Change order',
-raisecmd => $raise_cmd ,
);
$order_list = $order_frame ->Scrolled ( 'Listbox',
-selectmode => 'single',
-scrollbars => 'oe',
-height => 6,
)
-> pack(@fbe1) ;
$cw->{order_list} = $order_list ;
unless (defined $up_img) {
$up_img = $cw->Photo(-file => $icon_path.'up.png');
$down_img = $cw->Photo(-file => $icon_path.'down.png');
}
my $mv_up_down_frame = $order_frame->Frame->pack( -fill => 'x');
$mv_up_down_frame->Button(-image => $up_img,
-command => sub { $cw->move_selected_up ;} ,
)-> pack( -side => 'left', @fxe1);
$mv_up_down_frame->Button(-image => $down_img,
-command => sub { $cw->move_selected_down ;} ,
)-> pack( -side => 'left', @fxe1);
}
sub move_selected_up {
my $cw =shift;
my $order_list = $cw->{order_list} ;
my @idx = $order_list->curselection() ;
return unless @idx and $idx[0] > 0;
my $name = $order_list->get(@idx);
$order_list -> delete(@idx) ;
my $new_idx = $idx[0] - 1 ;
$order_list -> insert($new_idx, $name) ;
$order_list -> selectionSet($new_idx) ;
$order_list -> see($new_idx) ;
$cw->{leaf}->move_up($name) ;
$cw->reload_tree ;
}
sub move_selected_down {
my $cw =shift;
my $order_list = $cw->{order_list} ;
my @idx = $order_list->curselection() ;
my $leaf = $cw->{leaf};
my @h_idx = $leaf->get_checked_list ;
return unless @idx and $idx[0] < $#h_idx;
my $name = $order_list->get(@idx);
$logger->debug("move_selected_down: $name (@idx)");
$order_list -> delete(@idx) ;
my $new_idx = $idx[0] + 1 ;
$order_list -> insert($new_idx, $name) ;
$order_list -> selectionSet($new_idx) ;
$order_list -> see($new_idx) ;
$cw->{leaf}->move_down($name) ;
$cw->reload_tree ;
}
sub store {
my $cw = shift ;
my $lb = $cw->Subwidget('listbox') ;
my @choice = $cw->{leaf}->get_choice ;
my %set = map { $_ => 1 ; } map { $choice[$_]} $lb->curselection ;
my $cl = $cw->{leaf};
map {
if ($set{$_} and not $cl->is_checked($_) ) {
$cl->check($_) ;
}
elsif (not $set{$_} and $cl->is_checked($_) ) {
$cl->uncheck($_) ;
}
} @choice;
$cw->{store_cb}->() ;
}
sub reset_value {
my $cw = shift ;
my $h_ref = $cw->{leaf}->get_checked_list_as_hash ;
# reset also the content of the listbox
# weird behavior of tied Listbox :-/
${$cw->{tied}} = $cw->{leaf}->get_checked_list ;
# the CheckButtons have stored the reference of the hash *values*
# so we must preserve them.
map { $cw->{check_list}{$_} = $h_ref->{$_}} keys %$h_ref ;
$cw->{help} = '' ;
}
sub reload_tree {
my $cw = shift ;
$cw->parent->parent->parent->parent->reload() ;
}
1;