libconfig-model-tkui-perl 1.365-1 / usr / share / perl5 / Config / Model / Tk / ListEditor.pm

#
# This file is part of Config-Model-TkUI
#
# This software is Copyright (c) 2008-2017 by Dominique Dumont.
#
# This is free software, licensed under:
#
#   The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::Tk::ListEditor;
$Config::Model::Tk::ListEditor::VERSION = '1.365';
use strict;
use warnings;
use Carp;
use Log::Log4perl;

use base qw/Config::Model::Tk::ListViewer/;
use subs qw/menu_struct/;
use vars qw/$icon_path/;
use Tk::Dialog;
use Config::Model::Tk::NoteEditor;

Construct Tk::Widget 'ConfigModelListEditor';

my @fbe1   = qw/-fill both -expand 1/;
my @fxe1   = qw/-fill x    -expand 1/;
my @fx     = qw/-fill    x /;
my $logger = Log::Log4perl::get_logger("Tk::ListEditor");

my ( $up_img, $down_img, $rm_img, $eraser_img, $remove_img, $sort_img );
*icon_path = *Config::Model::TkUI::icon_path;

my $entry_width = 20;

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 $list = $cw->{list} = delete $args->{-item}
        || die "ListEditor: no -item, got ", keys %$args;

    delete $args->{-path};
    my $cme_font = delete $args->{-font};

    $cw->{store_cb} = delete $args->{-store_cb}
        or die __PACKAGE__, "no -store_cb";

    unless ( defined $up_img ) {
        $up_img     = $cw->Photo( -file => $icon_path . 'up.png' );
        $down_img   = $cw->Photo( -file => $icon_path . 'down.png' );
        $eraser_img = $cw->Photo( -file => $icon_path . 'eraser.png' );
        $remove_img = $cw->Photo( -file => $icon_path . 'remove.png' );
        $sort_img   = $cw->Photo( -file => $icon_path . 'dbgrun.png' );
    }

    $cw->add_header( Edit => $list )->pack(@fx);

    my $balloon = $cw->Balloon( -state => 'balloon' );

    my $inst = $list->instance;

    my $value_type = $list->get_cargo_info('value_type');    # may be undef

    my $elt_button_frame = $cw->Frame(qw/-relief raised -borderwidth 2/)->pack(@fbe1);
    my $frame_title      = $list->element_name;
    $frame_title .= ( defined $value_type and $value_type =~ /node/ ) ? ' elements' : ' list';
    $elt_button_frame->Label( -text => $frame_title )->pack();

    my $tklist = $elt_button_frame->Scrolled(
        'Listbox',
        -selectmode => 'single',
        -scrollbars => 'oe',
        -height     => 8,
    )->pack(@fbe1);

    $balloon->attach(
        $tklist,
        -msg => 'select an element and perform an action with one of the buttons below'
    );

    my $right_frame = $elt_button_frame->Frame->pack( @fxe1, qw/-side right -anchor n/ );

    $cw->ConfigModelNoteEditor( -object => $list )->pack;
    $cw->add_summary($list)->pack(@fx);
    $cw->add_description($list)->pack(@fbe1);
    $cw->add_warning( $list, 'edit' )->pack(@fx);
    $cw->add_info_button($cw)->pack(@fx);

    my $mv_rm_frame = $right_frame->Frame->pack(@fx);

    my $move_up_b = $mv_rm_frame->Button(
        -image   => $up_img,
        -command => sub { $cw->move_up; },
    )->pack( -side => 'left', @fxe1 );
    $balloon->attach( $move_up_b, -msg => 'Move selected element up the list' );

    my $move_down_b = $mv_rm_frame->Button(
        -image   => $down_img,
        -command => sub { $cw->move_down; },
    )->pack( -side => 'left', @fxe1 );
    $balloon->attach( $move_down_b, -msg => 'Move selected element down the list' );

    my $eraser_b = $mv_rm_frame->Button(
        -image   => $eraser_img,
        -command => sub { $cw->remove_selection; },
    )->pack( -side => 'left', @fxe1 );
    $balloon->attach( $eraser_b, -msg => 'Remove selected element from the list' );

    my $rm_all_b = $mv_rm_frame->Button(
        -image   => $remove_img,
        -command => sub {
            $list->clear;
            $tklist->delete( 0, 'end' );
            $cw->{store_cb}->();
        },
    )->pack( -side => 'left', @fxe1 );
    $balloon->attach( $rm_all_b, -msg => 'Remove all elements from the list' );

    my $cargo_type = $list->cargo_type;

    if ( $cargo_type eq 'leaf' ) {
        my $sort_b = $mv_rm_frame->Button(
            -image   => $sort_img,
            -command => sub { $cw->sort_content } )->pack( -side => 'left', @fxe1 );
        $balloon->attach( $sort_b, -msg => 'Sort all elements in the list' );
    }

    if (    $cargo_type eq 'leaf'
        and $value_type ne 'enum'
        and $value_type ne 'reference' ) {
        my $set_push_b_entry_frame =
            $right_frame->Frame( -borderwidth => 2, -relief => 'groove' )->pack(@fxe1);
        my $user_value;
        my $value_entry = $set_push_b_entry_frame->Entry(
            -textvariable => \$user_value,
            -width        => $entry_width
        );

        my $set_push_b_frame = $set_push_b_entry_frame->Frame->pack(@fxe1);

        $cw->add_set_entry( $set_push_b_frame, $balloon, $tklist, \$user_value )->pack(@fxe1);
        $cw->add_insort_entry( $set_push_b_frame, $balloon, \$user_value )->pack(@fxe1);
        $cw->add_insert_entry( $set_push_b_frame, $balloon, \$user_value )->pack(@fxe1);
        $cw->add_set_all_b( $set_push_b_entry_frame, $set_push_b_frame, $balloon, \$user_value )
            ->pack(@fxe1);

        $value_entry->pack(@fxe1);
        $cw->add_warning( $list, 'edit' )->pack(@fx);
    }
    else {
        my $elt_name = $list->element_name;
        my $disp     = "$elt_name ( $cargo_type ";
        $disp .= $list->config_class_name . ' )' if $cargo_type eq 'node';
        $disp .= " $value_type )" if defined $value_type;
        my $b = $right_frame->Button(
            -text    => "Push new $disp",
            -command => sub { $cw->push_entry(''); },
        )->pack(@fxe1);
        $balloon->attach( $b, -msg => "add a new $elt_name at the end of the list" );
    }

    $cw->{tklist} = $tklist;
    $cw->reset_value;

    $cw->ConfigSpecs(-font => [['SELF','DESCENDANTS'], 'font','Font', $cme_font ],);

    $cw->Tk::Frame::Populate($args);
}

#
# New subroutine "reset_value" extracted - Wed Sep 21 11:33:51 2011.
#
sub reset_value {
    my $cw   = shift;
    my $list = $cw->{list};

    my $cargo_type = $list->cargo_type;
    $cw->{tklist}->delete( 0, 'end' );
    my @insert =
          $cargo_type eq 'leaf'
        ? $list->fetch_all_values( check => 'no' )
        : $list->fetch_all_indexes;
    map { $_ = '<undef>' unless defined $_ } @insert;
    $cw->{tklist}->insert( end => @insert );

    return ( $cargo_type, \@insert );
}

sub add_set_entry {
    my ( $cw, $frame, $balloon, $tklist, $user_value_r ) = @_;

    my $set_sub = sub { $cw->set_entry($$user_value_r); };

    my $set_b = $frame->Button(
        -text    => "set selected",
        -command => $set_sub,
    )->pack( -side => 'left', @fxe1 );

    $balloon->attach( $set_b,
              -msg => 'enter a value, select an element on the left '
            . 'and click the button to replace the selected '
            . 'element with this value.' );

    my $b_sub = sub {
        my $idx = $tklist->curselection;
        $$user_value_r = $tklist->get($idx) if $idx;
    };

    $tklist->bind( '<<ListboxSelect>>', $b_sub );

    return $set_b;
}

sub add_push_entry {
    my ( $cw, $frame, $balloon, $user_value_r ) = @_;

    my $push_sub = sub { $cw->push_entry($$user_value_r); $$user_value_r = ''; };
    my $push_b = $frame->Button(
        -text    => "push item",
        -command => $push_sub,
    )->pack( -side => 'left', @fxe1 );

    $balloon->attach( $push_b,
        -msg => 'enter a value, and click the push button to add '
            . 'this value at the end of the list' );
    return $push_b;
}

sub push_entry {
    my $cw     = shift;
    my $add    = shift;
    my $tklist = $cw->{tklist};
    my $list   = $cw->{list};

    $logger->debug("push_entry: $add");

    # create new item in list (may auto create node object)
    my @idx = $list->fetch_all_indexes;
    eval { $list->fetch_with_id( scalar @idx ) };

    if ($@) {
        $cw->Dialog(
            -title => "List index error",
            -text  => $@->as_string,
        )->Show;
    }
    else {
        # trigger redraw of Tk Tree
        $cw->{store_cb}->();

        my @new_idx = $list->fetch_all_indexes;
        $logger->debug( "new list idx: " . join( ',', @new_idx ) );

        my $insert = length($add) ? $add : $#new_idx;
        $tklist->insert( 'end', $insert );
    }

    return 1;
}

sub add_insert_entry {
    my ( $cw, $frame, $balloon, $user_value_r ) = @_;

    my $insert_sub = sub { $cw->insert_entry($$user_value_r); $$user_value_r = ''; };
    my $insert_b = $frame->Button(
        -text    => "insert item",
        -command => $insert_sub,
    )->pack( -side => 'left', @fxe1 );

    $balloon->attach( $insert_b,
        -msg => 'enter a value, and click the insert button to add '
            . 'this value before the selected item or at the end of the list (push)' );
    return $insert_b;
}

sub insert_entry {
    my $cw     = shift;
    my $add    = shift;
    my $tklist = $cw->{tklist};
    my $list   = $cw->{list};

    my $idx_ref = $tklist->curselection || [];
    my $idx = $idx_ref->[0];

    $logger->debug( "insert_entry: $add insert at index ", $idx || 'end' );
    print( "insert_entry: $add insert at index ", $idx || 'end', "\n" );

    return unless length($add);
    my $try_sub =
        defined $idx ? sub { $list->insert_at( $idx, $add ); } : sub { $list->push($add) };
    $cw->try_and_redraw($try_sub);

}

sub set_entry {
    my $cw   = shift;
    my $data = shift;

    my $tklist  = $cw->{tklist};
    my $idx_ref = $tklist->curselection();
    return unless defined $idx_ref;
    return unless @$idx_ref;

    my $idx = $idx_ref->[0];
    return unless $idx;
    $tklist->delete($idx);
    $tklist->insert( $idx, $data );
    $tklist->selectionSet($idx);
    $cw->{list}->fetch_with_id($idx)->store($data);
    $cw->{store_cb}->();
}

sub add_insort_entry {
    my ( $cw, $frame, $balloon, $user_value_r ) = @_;

    my $insort_sub = sub { $cw->insort_entry($$user_value_r); $$user_value_r = ''; };
    my $insort_b = $frame->Button(
        -text    => "insort",
        -command => $insort_sub,
    )->pack( -side => 'left', @fxe1 );

    $balloon->attach( $insort_b,
        -msg => 'enter a value, and click the insort button to insert '
            . 'this value while keeping the list sorted' );
    return $insort_b;
}

sub insort_entry {
    my $cw  = shift;
    my $add = shift;

    $logger->debug("insort_entry: $add");

    return unless length($add);
    $cw->try_and_redraw( sub { $cw->{list}->insort($add); } );
}

sub try_and_redraw {
    my $cw     = shift;
    my $to_try = shift;
    my $tklist = $cw->{tklist};
    my $list   = $cw->{list};

    eval { $to_try->(); };

    if ($@) {
        $cw->Dialog(
            -title => "List index error",
            -text  => $@->as_string,
        )->Show;
    }
    else {
        # trigger redraw of Tk Tree
        $cw->{store_cb}->();

        my @list = $list->fetch_all_values;

        $tklist->delete( 0, 'end' );
        $tklist->insert( 0, @list );
    }

    return 1;
}

sub add_set_all_b {
    my ( $cw, $frame, $b_frame, $balloon, $user_value_r ) = @_;

    my $regexp = '\s*,\s*';
    my $set_all_sub = sub { $cw->set_all_items( $$user_value_r, $regexp ); };

    #my $set_all_frame = $frame->Frame;
    #my $set_top       = $set_all_frame->Frame->pack(@fxe1);
    my $set_bottom = $frame->Frame->pack( @fxe1, -side => 'bottom' );

    my $set_b = $b_frame->Button(
        -text    => "set all",
        -command => $set_all_sub,
    )->pack( -side => 'left', @fx );

    $balloon->attach( $set_b,
        -msg => 'set all elements with a single string that '
            . 'will be split by the regexp displayed below' );

    my $split_lb = $set_bottom->Label( -text => 'split regexp' )->pack( -side => 'left', @fxe1 );
    $set_bottom->Entry( -textvariable => \$regexp )->pack( -side => 'left', @fxe1 );

    $balloon->attach( $split_lb,
        -msg => 'regexp used to split the entry above when "set all" button is pressed' );

    return $set_bottom;
}

sub set_all_items {
    my $cw     = shift;
    my $data   = shift;
    my $regexp = shift;

    return unless $data;
    my $tklist = $cw->{tklist};

    my @list = split /$regexp/, $data;

    $tklist->delete( 0, 'end' );
    $tklist->insert( 0, @list );
    $cw->{list}->load_data( \@list );
    $cw->{store_cb}->();
}

sub sort_content {
    my $cw = shift;

    my $tklist = $cw->{tklist};
    my $list   = $cw->{list};
    $list->sort;

    my @list = $list->fetch_all_values;

    $tklist->delete( 0, 'end' );
    $tklist->insert( 0, @list );
    $cw->{store_cb}->();
}

sub move_up {
    my $cw = shift;

    my $tklist       = $cw->{tklist};
    my $from_idx_ref = $tklist->curselection();

    return unless defined $from_idx_ref;
    return unless @$from_idx_ref;

    my $from_idx = $from_idx_ref->[0];
    return unless $from_idx;
    return unless $from_idx > 0;

    $cw->swap( $from_idx, $from_idx - 1 );
}

sub move_down {
    my $cw = shift;

    my $tklist       = $cw->{tklist};
    my $from_idx_ref = $tklist->curselection();

    return unless defined $from_idx_ref;
    return unless @$from_idx_ref;

    my $from_idx = $from_idx_ref->[0];
    my $max_idx  = $cw->{list}->fetch_size - 1;
    return unless $from_idx < $max_idx;

    $cw->swap( $from_idx, $from_idx + 1 );
}

sub swap {
    my ( $cw, $ida, $idb ) = @_;

    my $tklist = $cw->{tklist};

    my $list = $cw->{list};
    $list->swap( $ida, $idb );

    my $cargo_type = $list->cargo_type;

    $tklist->selectionClear($ida);

    if ( $cargo_type ne 'node' ) {
        my $old = $tklist->get($ida);
        $tklist->delete($ida);

        while ( $idb > $tklist->size ) {
            $tklist->insert( 'end', '<undef>' );
        }
        $tklist->insert( $idb, $old );
    }

    $tklist->selectionSet($idb);
    $cw->{store_cb}->();
}

sub remove_selection {
    my $cw     = shift;
    my $tklist = $cw->{tklist};
    my $list   = $cw->{list};

    foreach ( $tklist->curselection() ) {
        $logger->debug("remove_selection: removing index $_");
        $list->remove($_);
    }
    $cw->{store_cb}->();

    # redraw the list content
    $tklist->delete( 0, 'end' );
    my $cargo_type = $list->cargo_type;
    my @insert =
          $cargo_type eq 'leaf'
        ? $list->fetch_all_values( check => 'no' )
        : $list->fetch_all_indexes;
    map { $_ = '<undef>' unless defined $_ } @insert;
    $tklist->insert( end => @insert );
    $cw->update_warning($list);
}

1;