libconfig-model-tkui-perl 1.340-1 / usr / share / perl5 / Config / Model / Tk / CheckListEditor.pm

#
# This file is part of Config-Model-TkUI
#
# This software is Copyright (c) 2013 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.340';
}

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;