—

              
#
# This file is part of Config-Model-TkUI
#
# This software is Copyright (c) 2008-2021 by Dominique Dumont.
#
# This is free software, licensed under:
#
#   The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::TkUI 1.379;
use 5.10.1;
use strict;
use warnings;
use Carp;
use base qw/Tk::Toplevel/;
use vars qw/$icon_path $error_img $warn_img/;
use subs qw/menu_struct/;
use Scalar::Util qw/weaken/;
use Log::Log4perl 1.11;
use Path::Tiny;
use YAML::PP;
use File::HomeDir;
use Pod::POM;
use Pod::POM::View::Text;
use Tk::DoubleClick;
use Tk::Balloon;
use Tk::Photo;
use Tk::PNG;    # required for Tk::Photo to be able to load pngs
use Tk::Adjuster;
use Tk::FontDialog;
use Tk::Pod;
use Tk::Pod::Text;    # for findpod
use Config::Model 2.134; # reset config
use Config::Model::Tk::Filter qw/apply_filter/;
use Config::Model::Tk::LeafEditor;
use Config::Model::Tk::CheckListEditor;
use Config::Model::Tk::LeafViewer;
use Config::Model::Tk::CheckListViewer;
use Config::Model::Tk::ListViewer;
use Config::Model::Tk::ListEditor;
use Config::Model::Tk::HashViewer;
use Config::Model::Tk::HashEditor;
use Config::Model::Tk::NodeViewer;
use Config::Model::Tk::NodeEditor;
use Config::Model::Tk::Wizard;
use Config::Model::Tk::CmeDialog;
Construct Tk::Widget 'ConfigModelUI';
my $cust_img;
my $tool_img;
my %gnome_img;
my $mod_file = 'Config/Model/TkUI.pm';
$icon_path = $INC{$mod_file};
$icon_path =~ s/TkUI.pm//;
$icon_path .= 'Tk/icons/';
my $logger = Log::Log4perl::get_logger('TkUI');
no warnings "redefine";
sub Tk::Error {
    my ( $cw, $error, @locations ) = @_;
    my $msg = ( ref($error) && $error->can('as_string') ) ? $error->as_string : $error;
    warn $msg;
    $msg .= "Tk stack: \n@locations\n";
    $cw->CmeDialog(
        -title => 'Config::Model error',
        -text  => $msg,
    )->Show;
}
use warnings "redefine";
my $default_config = {
    font => { -family =>  'DejaVu Sans', qw/-size -13 -weight normal/ }
};
my $main_window;
my $home_str = File::HomeDir->my_home || '/tmp/';
my $config_path = path($home_str)->child('.cme/config/');
my $config_file = $config_path->child('tkui.yml');
my $ypp = YAML::PP->new;
$config_path -> mkpath;
my $config = $config_file->is_file ? $ypp->load_file($config_file) : $default_config ;
# Tk::CmdLine::SetArguments( -font => $config->{font} ) ;
sub ClassInit {
    my ( $class, $mw ) = @_;
    $main_window = $mw;
    # ClassInit is often used to define bindings and/or other
    # resources shared by all instances, e.g., images.
    # cw->Advertise(name=>$widget);
}
sub set_font {
    my $cw = shift;
    my $tk_font = $main_window->FontDialog->Show;
    if (defined $tk_font) {
        $main_window->RefontTree(-font => $tk_font);
        $config->{font} = {$tk_font->actual} ;
        $cw->ConfigSpecs( -font => ['DESCENDANTS', 'font','Font', $tk_font ]);
        $ypp->dump_file($config_file->stringify, $config);
    }
}
sub Populate {
    my ( $cw, $args ) = @_;
    unless ( defined $error_img ) {
        $error_img = $cw->Photo( -file => $icon_path . 'stop.png' );
        $cust_img  = $cw->Photo( -file => $icon_path . 'next.png' );
        # snatched from oxygen-icon-theme
        $warn_img = $cw->Photo( -file => $icon_path . 'dialog-warning.png' );
        # snatched from openclipart-png
        $tool_img = $cw->Photo( -file => $icon_path . 'tools_nicu_buculei_01.png' );
        # snatched from gnome gnome-icon-theme package
        foreach my $img_name (qw/next previous window-close gtk-execute/) {
            $gnome_img{$img_name} = $cw->Photo(
                -file => $icon_path . "gnome-$img_name.png"
            );
        }
    }
    if ($args->{-root}) {
        carp "TkUI: -root parameter is deprecated in favor of -instance";
        my $root = delete $args->{-root};
        $cw->{instance} = $root->instance;
    }
    $cw->{instance} //= delete $args->{-instance};
    foreach my $parm (qw/-store_sub -quit/) {
        my $attr = $parm;
        $attr =~ s/^-//;
        $cw->{$attr} = delete $args->{$parm};
    }
    my $extra_menu = delete $args->{'-extra-menu'} || [];
    my $title = delete $args->{'-title'}
        || $0 . " " . $cw->{instance}->config_root->config_class_name;
    # check unknown parameters
    croak "Unknown parameter ", join( ' ', keys %$args ) if %$args;
    # initialize internal attributes
    $cw->{location} = '';
    $cw->{current_mode} = 'view';
    $cw->setup_scanner();
    # create top menu
    require Tk::Menubutton;
    my $menubar = $cw->Menu;
    $cw->configure( -menu => $menubar );
    $cw->{my_menu} = $menubar;
    my $file_items = [
        [ qw/command wizard -command/, sub { $cw->wizard } ],
        [ command => 'redraw tree', -command => sub { $cw->reload } ],
        [ command => 'reload from file', -command => sub { $cw->ask_reset; } ],
        [ command => 'check for errors',     -command => sub { $cw->check(1) } ],
        [ command => 'check for warnings',   -command => sub { $cw->check( 1, 1 ) } ],
        [ command => 'show unsaved changes', -command => sub { $cw->show_changes; } ],
        [ command => 'save (Ctrl-s)', -command => sub { $cw->save } ],
        @$extra_menu,
        [
            command  => 'debug ...',
            -command => sub {
                require Tk::ObjScanner;
                Tk::ObjScanner::scan_object( $cw->{instance}->config_root );
                }
        ],
        [ command => 'quit (Ctrl-q)', -command => sub { $cw->quit } ],
    ];
    $menubar->cascade( -label => 'File', -menuitems => $file_items );
    $cw->add_help_menu($menubar);
    $cw->bind( '<Control-s>', sub { $cw->save } );
    $cw->bind( '<Control-q>', sub { $cw->quit } );
    $cw->bind( '<Control-c>', sub { $cw->edit_copy } );
    $cw->bind( '<Control-v>', sub { $cw->edit_paste } );
    $cw->bind( '<Control-f>', sub { $cw->pack_find_widget } );
    my $edit_items = [
        # [ qw/command cut   -command/, sub{ $cw->edit_cut }],
        [ command => 'copy (Ctrl-c)',  '-command', sub { $cw->edit_copy } ],
        [ command => 'paste (Ctrl-v)', '-command', sub { $cw->edit_paste } ],
        [ command => 'find (Ctrl-f)',  '-command', sub { $cw->pack_find_widget; } ],
    ];
    $menubar->cascade( -label => 'Edit', -menuitems => $edit_items );
    my $option_menu = $menubar->cascade( -label => 'Options');
    $option_menu->command( -label => 'Font', -command => sub { $cw->set_font(); });
    # create 'hide empty values'
    $cw->{hide_empty_values} = 0;
    $option_menu->checkbutton(
        -label  => "Hide empty values",
        -variable => \$cw->{hide_empty_values},
        -command  => sub { $cw->reload($cw->{location}) },
    );
    # create 'show only custom values'
    $cw->{show_only_custom} = 0;
    $option_menu->checkbutton(
        -label => 'Show only custom values',
        -variable => \$cw->{show_only_custom},
        -command  => sub { $cw->reload($cw->{location}) },
    );
    # create 'show only custom values'
    $cw->{auto_save_mode} = 0;
    $option_menu->checkbutton(
        -label => 'Auto save',
        -variable => \$cw->{auto_save_mode},
    );
    my $weak_cw = $cw;
    weaken($weak_cw);
    $cw->{instance}->on_change_cb( sub {
        $weak_cw->save if $weak_cw->{auto_save_mode};;
    });
    # create frame for location entry
    my $loc_frame =
        $cw->Frame( -relief => 'sunken', -borderwidth => 1 )->pack( -pady => 0, -fill => 'x' );
    $loc_frame->Label( -text => 'location :' )->pack( -side => 'left' );
    $loc_frame->Label( -textvariable => \$cw->{location} )->pack( -side => 'left' );
    # add bottom frame
    my $bottom_frame = $cw->Frame->pack(qw/-pady 0 -fill both -expand 1/);
    my $tree_frame = $bottom_frame->Frame->pack(qw/-fill both -expand 1 -side left/);
    my $filter_frame = $tree_frame->Frame->pack(qw/-fill x -side top/);
    # create the widget for tree navigation
    require Tk::Tree;
    my $tree = $tree_frame->Scrolled(
        qw/Tree/,
        -columns   => 4,
        -header    => 1,
        -opencmd   => sub { $cw->open_item(@_); },
        -closecmd  => sub { $cw->close_item(@_); },
    )->pack(qw/-fill both -expand 1 -side bottom/);
    $cw->{tktree} = $tree;
    my $sub_filter = sub {
        $cw->reload;
    };
    my $clear_filter = sub {
        $cw->{elt_filter_value} = '';
        $cw->reload;
    };
    my $reload_on_key = sub {
        $cw->reload;
    };
    my $filter_clear = $filter_frame->Button (
        -image => $gnome_img{'window-close'},
        -command => $clear_filter
    );
    $cw->Balloon(-state => 'balloon')->attach($filter_clear, -msg => 'clear filter');
    $filter_clear->pack(-side => 'right');
    $filter_frame->Label(-text => 'filter elements',)->pack(-side => 'left');
    $cw->{elt_filter_value} = '';
    my $element_filter_w = $filter_frame->Entry(
        -textvariable => \$cw->{elt_filter_value},
    );
    $cw->Balloon(-state => 'balloon')->attach(
        $element_filter_w,
        -msg => 'define a filter applied to element name. At least 3 character long.'
            .' This can be a Perl regexp.');
    $element_filter_w->pack(qw/-side right -fill x -expand 1/);
    $element_filter_w->bind('<KeyRelease>', $reload_on_key);
    # add adjuster
    $bottom_frame->Adjuster()->packAfter( $tree_frame, -side => 'left' );
    # add headers
    $tree->headerCreate( 0, -text => "element" );
    $tree->headerCreate( 1, -text => "status" );
    $tree->headerCreate( 2, -text => "value" );
    $tree->headerCreate( 3, -text => "standard value" );
    $cw->reload;
    # add frame on the right for entry and help
    my $eh_frame = $bottom_frame->Frame->pack(qw/-fill both -expand 1 -side right/);
    # add entry frame, filled by call-back
    # should be a composite widget
    my $e_frame = $eh_frame->Frame->pack(qw/-side top -fill both -expand 1/);
    $e_frame->Label(    #-text => "placeholder",
        -image => $tool_img,
        -width => 400,         # width in pixel for image
    )->pack( -side => 'top' );
    $e_frame->Button(
        -text    => "Run Wizard !",
        -command => sub { $cw->wizard } )->pack( -side => 'bottom' );
    my $b1_sub = sub {
        my $item = $tree->nearest( $tree->pointery - $tree->rooty );
        $cw->on_browse($item);
    };
    my $b3_sub = sub {
        my $item = $tree->nearest( $tree->pointery - $tree->rooty );
        $cw->on_select($item);
    };
    $tree->bind( '<Return>', $b3_sub );
    $tree->bind( '<ButtonRelease-3>', $b3_sub );
    bind_clicks($tree,$b1_sub, $b3_sub);
    # bind button2 to get cut buffer content and try to store cut buffer content
    my $b2_sub = sub {
        my $item = $tree->nearest( $tree->pointery - $tree->rooty );
        $cw->on_cut_buffer_dump($item);
    };
    $tree->bind( '<ButtonRelease-2>', $b2_sub );
    $tree->bind( '<Control-c>', sub { $cw->edit_copy } );
    $tree->bind( '<Control-v>', sub { $cw->edit_paste } );
    $tree->bind( '<Control-f>', sub { $cw->pack_find_widget } );
    my $find_frame = $cw->create_find_widget;
    # create frame for message
    my $msg_label = $cw->Label(
        -textvariable => \$cw->{message},
        -relief => 'sunken',
        -borderwidth => 1,
        -anchor =>'w',
    );
    $msg_label->pack( -pady => 0, -fill => 'x' );
    $args->{-title} = $title;
    $cw->SUPER::Populate($args);
    my $tk_font = $cw->Font(%{$config->{font}});
    $cw->ConfigSpecs(
        -font       => ['DESCENDANTS', 'font','Font', $tk_font ],
        #-background => ['DESCENDANTS', 'background', 'Background', $background],
        #-selectbackground => [$hlist, 'selectBackground', 'SelectBackground',
        #                      $selectbackground],
        -tree_width  => [ 'METHOD',  undef,        undef,        80 ],
        -tree_height => [ 'METHOD',  undef,        undef,        30 ],
        -width       => [ $eh_frame, qw/width Width 1280/ ],
        -height      => [ $eh_frame, qw/height Height 1024/ ],
        -selectmode  => [ $tree,     'selectMode', 'SelectMode', 'single' ],    #single',
                #-oldcursor => [$hlist, undef, undef, undef],
        DEFAULT => [$tree] );
    $cw->Advertise( tree        => $tree );
    $cw->Advertise( menubar     => $menubar );
    $cw->Advertise( right_frame => $eh_frame );
    $cw->Advertise( ed_frame    => $e_frame );
    $cw->Advertise( find_frame  => $find_frame );
    $cw->Advertise( msg_label   => $msg_label );
    $cw->OnDestroy(sub {$cw->Parent->destroy if ref($cw->Parent) eq 'MainWindow'} );
    $cw->Delegates;
}
sub show_message {
    my ( $cw, $msg ) = @_;
    # $cw->Subwidget('msg_label')->configure(-background => "red"); # does not work
    $cw->{message} = $msg;
    if (my $id = $cw->{id}) {
        $cw->afterCancel($id) ;
    } ;
    my $unshow = sub {
        delete $cw->{id};
        $cw->{message} = '';
    } ;
    $cw->{id} = $cw->after(5000,$unshow) ;
}
sub tree_width {
    my ( $cw, $value ) = @_;
    $cw->Subwidget('tree')->configure( -width => $value );
}
sub tree_height {
    my ( $cw, $value ) = @_;
    $cw->Subwidget('tree')->configure( -height => $value );
}
my $parser = Pod::POM->new();
# parse from my documentation
my $pom = $parser->parse_file(__FILE__)
    || die $parser->error();
my $help_text;
my $info_text;
foreach my $head1 ( $pom->head1() ) {
    $help_text = Pod::POM::View::Text->view_head1($head1)
        if $head1->title eq 'USAGE';
    $info_text = Pod::POM::View::Text->view_head1($head1)
        if $head1->title =~ /more information/i;
}
sub add_help_menu {
    my ( $cw, $menubar ) = @_;
    my $about_sub = sub {
        $cw->Dialog(
            -title => 'About',
            -text  => "Config::Model::TkUI \n"
                . "(c) 2008-2021 Dominique Dumont \n"
                . "Licensed under LGPLv2\n"
        )->Show;
    };
    my $info_sub = sub {
        $cw->CmeDialog(
            -title => 'TODO',
            -text =>  $info_text
        )->Show;
    };
    my $help_sub = sub {
        $cw->CmeDialog(
            -title => 'help',
            -text => $help_text
        )->Show;
    };
    my $class   = $cw->{instance}->config_root->config_class_name;
    my $man_sub = sub {
        $cw->Pod(
            -tree       => 0,
            -file       => "Config::Model::models::" . $class,
            -title      => $class,
            -exitbutton => 0,
        );
    };
    my $help_items = [
        [ qw/command About -command/, $about_sub ],
        [ qw/command Usage -command/, $help_sub ],
        [ command => 'More info',   -command => $info_sub ],
        [ command => "$class help", -command => $man_sub ],
    ];
    $menubar->cascade( -label => 'Help', -menuitems => $help_items );
}
# Note: this callback is called by Tk::Tree *before* changing the
# indicator. And the indicator is used by Tk::Tree to store the
# open/close/none mode. So we can't rely on getmode for path that are
# opening. Hence the parameter passed to the sub stored with each
# Tk::Tree item
sub open_item {
    my ( $cw, $path ) = @_;
    my $tktree = $cw->{tktree};
    $logger->trace("open_item on $path");
    my $data = $tktree->infoData($path);
    # invoke the scanner part (to create children)
    # the parameter indicates that we are opening this path
    $data->[0]->(1);
    $cw->show_single_list_value ($tktree, $data->[1], $path, 0);
    my @children = $tktree->infoChildren($path);
    $logger->trace("open_item show @children");
    map { $tktree->show( -entry => $_ ); } @children;
}
sub close_item {
    my ( $cw, $path ) = @_;
    my $tktree = $cw->{tktree};
    $logger->trace("close_item on $path");
    my $data = $tktree->infoData($path);
    $cw->show_single_list_value ($tktree, $data->[1], $path, 1);
    my @children = $tktree->infoChildren($path);
    $logger->trace("close_item hide @children");
    map { $tktree->hide( -entry => $_ ); } @children;
}
sub check {
    my $cw             = shift;
    my $show           = shift || 0;
    my $check_warnings = shift || 0;
    my $wiz = $cw->setup_wizard( sub { $cw->check_end( $show, @_ ); } );
    $wiz->start_wizard( stop_on_warning => $check_warnings );
}
sub check_end {
    my $cw          = shift;
    my $show        = shift;
    my $has_stopped = shift;
    $cw->reload if $has_stopped;
    if ( $show and not $has_stopped ) {
        $cw->Dialog(
            -title => 'Check',
            -text  => "No issue found"
        )->Show;
    }
}
sub save {
    my $cw = shift;
    my $cb = shift || sub {};
    my $dir       = $cw->{save_dir};
    my $trace_dir = defined $dir ? $dir : 'default';
    my @wb_args   = defined $dir ? ( config_dir => $dir ) : ();
    my $save_job = sub {
        $cw->check(); # may be long
        if ( defined $cw->{store_sub} ) {
            $logger->info("Saving data in $trace_dir directory with store call-back");
            eval { $cw->{store_sub}->($dir) };
        }
        else {
            $logger->info("Saving data in $trace_dir directory with instance write_back");
            eval { $cw->{instance}->write_back(@wb_args); };
        }
        if ($@) {
            my $err = $@ ;
            my $answer = $cw->CmeDialog(
                -title => 'Save error',
                -text  => "Cannot save: $err",
                -buttons        => [ qw/quit cancel/ ],
                -default_button => 'cancel',
            )->Show;
            $cb->($err) if $answer eq 'quit'; # indicate failure
        }
        else {
            $cw->show_message("Save done ...");
            $cb->();
        }
    };
    $cw->show_message("Saving... please wait ...");
    # use a short delay to let tk show the message above and then save
    $cw->after(100, $save_job) ;
}
sub ask_reset {
    my $text = "Discard changes and reload from file ?";
    my $cw = shift;
    if ( $cw->{instance}->needs_save ) {
        my $answer = $cw->Dialog(
            -title          => "reload from file",
            -text           => $text,
            -buttons        => [ qw/yes cancel/, 'show changes' ],
            -default_button => 'yes',
        )->Show;
        if ( $answer eq 'yes' ) {
            $cw->do_reset;
        }
        elsif ( $answer =~ /show/ ) {
            $cw->show_changes( sub { $cw->ask_reset } );
        }
    }
    else {
        $cw->do_reset;
    }
}
sub do_reset {
    my $cw = shift;
    $cw->{instance}->reset_config;
    # this line can be removed after Config::Model 2.135
    $cw->{instance}->clear_changes;
    $cw->reload;
}
sub quit {
    my $cw = shift;
    my $text = shift || "Save data ?";
    if ( $cw->{instance}->needs_save ) {
        my $answer = $cw->Dialog(
            -title          => "quit",
            -text           => $text,
            -buttons        => [ qw/yes no cancel/, 'show changes' ],
            -default_button => 'yes',
        )->Show;
        if ( $answer eq 'yes' ) {
            $cw->save( sub {$cw->self_destroy;});
        }
        elsif ( $answer eq 'no' ) {
            $cw->self_destroy;
        }
        elsif ( $answer =~ /show/ ) {
            $cw->show_changes( sub { $cw->quit } );
        }
    }
    else {
        $cw->self_destroy;
    }
}
sub self_destroy {
    my $cw = shift;
    if ( defined $cw->{quit} and $cw->{quit} eq 'soft' ) {
        $cw->destroy;
    }
    else {
        # destroy main window to exit Tk Mainloop;
        $cw->parent->destroy;
    }
}
sub show_changes {
    my $cw = shift;
    my $cb = shift;
    my $changes       = $cw->{instance}->list_changes;
    my $change_widget = $cw->Toplevel;
    $change_widget->Scrolled('ROText')->pack( -expand => 1, -fill => 'both' )
        ->insert( '1.0', $changes );
    $change_widget->Button(
        -command => sub { $change_widget->destroy; $cb->() if defined $cb; },
        -text => 'ok',
    )->pack;
}
sub reload {
    my $cw = shift;
    carp "reload: too many parameters" if @_ > 1;
    my $force_display_path = shift // '';    # force open editor on this path
    $logger->trace( "reloading tk tree"
            . ( defined $force_display_path ? " (force display $force_display_path)" : '' ) );
    my $actions = $cw->{cm_actions} //= {};
    # eval is required to trap bad regexp entered in filter widget
    my %filter_args = map { ($_ => $cw->{$_} // '') }
            qw/elt_filter_value show_only_custom hide_empty_values instance/ ;
    eval {
        apply_filter(actions => $actions, fd_path => $force_display_path, %filter_args);
    };
    if ($@) {
        my $msg = $@;
        say "filter error: $msg";
        $msg =~ s/at lib.*//s; # remove file from error message
            $cw->show_message("filter error: $msg");
    }
    my $tree = $cw->{tktree};
    my $instance_name = $cw->{instance}->name;
    my $root = $cw->{instance}->config_root;
    my $new_drawing = not $tree->infoExists($instance_name);
    my $scan_root = sub {
        my $opening = shift ;
        $tree->itemConfigure($instance_name, 2, -text => $root->fetch_gist);
        $cw->{scanner}->scan_node( [ $instance_name, $cw, $opening, $actions, $force_display_path ], $root );
    };
    if ($new_drawing) {
        $tree->add( $instance_name, -data => [ $scan_root, $root ] );
        $tree->itemCreate( $instance_name, 0, -text => $instance_name, );
        $tree->itemCreate( $instance_name, 2, -text => '' );
        $tree->setmode( $instance_name, 'close' );
        $tree->open($instance_name);
    }
    # the first parameter indicates that we are opening the root
    $scan_root->( 1 );
    $cw->{editor}->reload if defined $cw->{editor};
}
# call-back when Tree element is selected
sub on_browse {
    my ( $cw, $path ) = @_;
    $cw->update_loc_bar($path);
    $cw->create_element_widget('view');
}
sub update_loc_bar {
    my ( $cw, $path ) = @_;
    #$cw->{path}=$path ;
    my $datar = $cw->{tktree}->infoData($path);
    my $obj   = $datar->[1];
    $cw->{location} = $obj->location_short;
}
sub on_select {
    my ( $cw, $path ) = @_;
    $cw->update_loc_bar($path);
    $cw->create_element_widget('edit');
}
sub on_cut_buffer_dump {
    my ( $cw, $tree_path, $selection_for_test ) = @_;
    $cw->update_loc_bar($tree_path);
    # get cut buffer content, See Perl/Tk book p297
    my $sel = $selection_for_test // eval { $cw->SelectionGet; };
    return if $@;    # no selection
    my $obj = $cw->{tktree}->infoData($tree_path)->[1];
    my $type = $obj->get_type;
    if ( $type eq "leaf" ) {
        # if leaf store content
        $obj->store( value => $sel, callback => sub { $cw->reload; } );
    }
    elsif ( $type eq 'hash' ) {
        # if hash create keys
        my @keys = ( $sel =~ /\n/m ) ? split( /\n/, $sel ) : ($sel);
        foreach my $key (@keys) {
            $obj->fetch_with_id($key);
        };
    }
    elsif ( $type eq 'list') {
        if ( $obj->get_cargo_type =~ /node/ ) {
            $cw->show_message("cannot paste on list of node");
        }
        else {
            # if array, push values. Don't mix \n and , separators
            my @v =
                ( $sel =~ /\n/m ) ? split( /\n/, $sel )
                : ( $sel =~ /,/ ) ? split( /,/,  $sel )
                :                     ($sel);
            $obj->push(@v);
        }
    }
    else {
        $cw->show_message("cannot paste on $type parameter");
    }
    # else ignore
    # display result
    $cw->reload;
    $cw->create_element_widget($cw->{current_mode}, $tree_path);
    $cw->open_item($tree_path);
    $cw->{tktree}->setmode( $tree_path => 'close' ) if $type eq 'list' or $type eq 'hash';
}
# replace dot in str by _|_
sub to_path   { my $str  = shift; $str =~ s/\./_|_/g; return $str; }
sub force_element_display {
    my $cw      = shift;
    my $elt_obj = shift;
    $logger->trace( "force display of " . $elt_obj->location );
    $cw->reload( $elt_obj->location );
}
sub prune {
    my $cw   = shift;
    my $path = shift;
    $logger->trace("prune $path");
    my %list = map { "$path." . to_path($_) => 1 } @_;
    # remove entries that are not part of the list
    my $tkt = $cw->{tktree};
    map { $tkt->deleteEntry($_) if $_ and not defined $list{$_}; } $tkt->infoChildren($path);
    $logger->trace("prune $path done");
}
# Beware: TkTree items store tree object and not tree cds path. These
# object might become irrelevant when warp master values are
# modified. So the whole Tk Tree layout must be redone very time a
# config value is modified. This is a bit heavy, but a smarter
# alternative would need hooks in the configuration tree to
# synchronise the Tk Tree with the configuration tree :-p
my %elt_mode = (
    leaf        => 'none',
    hash        => 'open',
    list        => 'open',
    node        => 'open',
    check_list  => 'none',
    warped_node => 'open',
);
sub disp_obj_elt {
    my ( $scanner, $data_ref, $node,    @orig_element_list ) = @_;
    my ( $path,    $cw,       $opening, $actions, $force_display_path ) = @$data_ref;
    my $tkt  = $cw->{tktree};
    my $mode = $tkt->getmode($path);
    my @element_list;
    foreach my $elt (@orig_element_list) {
        my $obj = $node->fetch_element($elt);
        my $loc = $obj->location;
        my $action = $actions->{$loc} // '';
        if ($action ne 'hide') {
            push @element_list, $elt;
        }
    }
    $logger->trace( "disp_obj_elt path $path mode $mode opening $opening " . "(@element_list)" );
    $cw->prune( $path, @element_list );
    my $node_loc = $node->location;
    my $prevpath = '';
    foreach my $elt (@element_list) {
        my $newpath  = "$path." . to_path($elt);
        my $scan_sub = sub {
            $scanner->scan_element( [ $newpath, $cw,  $opening, $actions, $force_display_path ], $node, $elt );
        };
        my @data = ( $scan_sub, $node->fetch_element($elt) );
        # It's necessary to store a weakened reference of a tree
        # object as these ones tend to disappear when warped out. In
        # this case, the object must be destroyed. This does not
        # happen if a non-weakened reference is kept in Tk Tree.
        weaken( $data[1] );
        my $elt_type = $node->element_type($elt);
        my $eltmode  = $elt_mode{$elt_type};
        if ( $tkt->infoExists($newpath) ) {
            $eltmode = $tkt->getmode($newpath);    # will reuse mode below
        }
        else {
            my @opt = $prevpath ? ( -after => $prevpath ) : ( -at => 0 );
            $logger->trace("disp_obj_elt add $newpath mode $eltmode type $elt_type");
            $tkt->add( $newpath, -data => \@data, @opt );
            $tkt->itemCreate( $newpath, 0, -text => $elt );
            $tkt->setmode( $newpath => $eltmode );
        }
        my $elt_loc = $node_loc ? $node_loc . ' ' . $elt : $elt;
        $cw->setmode( 'node', $newpath, $eltmode, $elt_loc, $opening, $actions, $scan_sub );
        my $obj = $node->fetch_element($elt);
        if ($elt_type =~ 'node') {
            $tkt->itemCreate( $newpath, 2, -text => $obj->fetch_gist );
        }
        if ( $elt_type eq 'hash' ) {
            $cw->update_hash_image( $obj, $newpath );
        }
        if ($elt_type eq 'hash' or $elt_type eq 'list') {
            my $size = $obj->fetch_size;
            $tkt->entryconfigure($newpath, -text => "$elt [$size]");
        }
        $cw->show_single_list_value ($tkt, $obj, $newpath,  $tkt->getmode($newpath) eq 'open' ? 1 : 0);
        if ( $force_display_path and $force_display_path eq $elt_loc ) {
            $cw->force_display($newpath, $elt_loc);
        }
        if (not $force_display_path and $cw->{location} eq $elt_loc) {
            $cw->force_display($newpath, $elt_loc);
        }
        $prevpath = $newpath;
    }
}
sub force_display {
    my ($cw, $path, $loc) = @_;
    $logger->debug("force_display called on $path, location $loc");
    my $tree = $cw->{tktree};
    $tree->see($path);
    $tree->selectionClear();
    $tree->selectionSet($path, $path);
    $cw->{location} = $loc;
}
# show a list like a leaf value when the list contains *one* item
sub show_single_list_value {
    my ($cw, $tkt, $obj, $path, $show) = @_;
    my $elt_type = $obj->get_type;
    # leave alone element that is not a list of leaf
    return unless $elt_type eq 'list' and $obj->get_cargo_type eq 'leaf';
    my $size = $obj->fetch_size;
    $logger->trace("show_single_list_value called on ", $obj->location, " show is $show, size is $size" );
    if ($size == 1 and $show) {
        disp_leaf(undef,[ $path, $cw ], $obj->parent, $obj->element_name, 0, $obj->fetch_with_id(0));
    }
    else {
        foreach my $column (qw/1 2 3/) {
            $tkt->itemDelete( $path, $column ) if $tkt->itemExists($path, $column);
        };
    }
}
sub disp_hash {
    my ( $scanner, $data_ref, $node, $element_name, @all_idx ) = @_;
    my ( $path, $cw, $opening, $actions, $force_display_path ) = @$data_ref;
    my $tkt  = $cw->{tktree};
    my $mode = $tkt->getmode($path);
    my @idx;
    my $hash = $node->fetch_element($element_name);
    foreach my $id (@all_idx) {
        my $loc = $hash->fetch_with_id($id)->location;
        my $action = $actions->{$loc} // '';
        if ($action ne 'hide') {
            push @idx, $id;
        }
    }
    $logger->trace("disp_hash    path is $path  mode $mode (@idx)");
    $cw->prune( $path, @idx );
    my $elt      = $node->fetch_element($element_name);
    my $elt_type = $elt->get_cargo_type();
    # need to keep track myself of previous sibling as
    # $tkt->entrycget($path,'-after') dies
    # and $tkt->info('prev',$path) return the path above in the displayed tree, which
    # is not necessarily a sibling :-(
    my $prev_sibling = '';
    my %tk_previous_path;
    foreach ( $tkt->info( 'children', $path ) ) {
        $tk_previous_path{$_} = $prev_sibling;
        $prev_sibling = $_;
    }
    my $prevpath = '';
    foreach my $idx (@idx) {
        my $newpath  = $path . '.' . to_path($idx);
        my $scan_sub = sub {
            $scanner->scan_hash(
                [ $newpath, $cw,  $opening, $actions, $force_display_path ],
                $node, $element_name, $idx
            );
        };
        my $eltmode = $elt_mode{$elt_type};
        my $sub_elt = $elt->fetch_with_id($idx);
        # check for display order mismatch
        if ( $tkt->infoExists($newpath) ) {
            if ( $prevpath ne $tk_previous_path{$newpath} ) {
                $logger->trace(
                    "disp_hash deleting mismatching $newpath mode $eltmode cargo_type $elt_type");
                $tkt->delete( entry => $newpath );
            }
        }
        # check for content mismatch
        if ( $tkt->infoExists($newpath) ) {
            my $previous_data = $tkt->info( data => $newpath );
            # $previous_data is an object (or an empty string to avoid warnings)
            my $previous_elt = $previous_data->[1] || '';
            $eltmode = $tkt->getmode($newpath);    # will reuse mode below
            $logger->trace( "disp_hash reuse $newpath mode $eltmode cargo_type $elt_type"
                    . " obj $previous_elt (expect $sub_elt)" );
            # string comparison of objects is intentional to check that the tree
            # refers to the correct Config::Model object
            if ( $sub_elt ne $previous_elt ) {
                $logger->trace( "disp_hash delete $newpath mode $eltmode (got "
                        . "$previous_elt expected $sub_elt)" );
                # wrong order, delete the entry
                $tkt->delete( entry => $newpath );
            }
        }
        if ( not $tkt->infoExists($newpath) ) {
            my @opt = $prevpath ? ( -after => $prevpath ) : ( -at => 0 );
            $logger->trace(
                "disp_hash add $newpath mode $eltmode cargo_type $elt_type" . " elt $sub_elt" );
            my @data = ( $scan_sub, $sub_elt );
            weaken( $data[1] );
            $tkt->add( $newpath, -data => \@data, @opt );
            $tkt->itemCreate( $newpath, 0, -text => $node->shorten_idx($idx) );
            $tkt->setmode( $newpath => $eltmode );
        }
        # update the node gist
        my $gist = $elt_type =~ /node/ ? $elt->fetch_with_id($idx)->fetch_gist : '';
        $tkt->itemCreate( $newpath, 2, -text => $gist );
        my $elt_loc = $sub_elt->location;
        # hide new entry if hash is not yet opened
        $cw->setmode( 'hash', $newpath, $eltmode, $elt_loc, $opening, $actions, $scan_sub );
        if ( $force_display_path and $force_display_path eq $elt_loc ) {
            $cw->force_display($newpath, $elt_loc)
        }
        $prevpath = $newpath;
    }
}
sub update_hash_image {
    my ( $cw, $elt, $path ) = @_;
    my $tkt = $cw->{tktree};
    # check hash status and set warning image if necessary
    my $img;
    {
        no warnings qw/uninitialized/;
        $img = $warn_img if $elt->warning_msg;
    }
    if ( defined $img ) {
        $tkt->itemCreate( $path, 1, -itemtype => 'image', -image => $img );
    }
    else {
        $tkt->itemDelete( $path, 1 ) if $tkt->itemExists( $path, 1 );
    }
}
sub setmode {
    my ( $cw, $type, $newpath, $eltmode, $elt_loc, $opening, $actions, $scan_sub ) = @_;
    my $tkt = $cw->{tktree};
    $actions->{$elt_loc} //= '';
    my $force_open = $actions->{$elt_loc} eq 'show' ? 1 : 0;
    my $force_close = $actions->{$elt_loc} eq 'hide' ? 1 : 0;
    $logger->trace( "$type: elt_loc '$elt_loc', opening $opening "
                        . "eltmode $eltmode force_open $force_open");
    if ( not $force_close and ($eltmode ne 'open' or $force_open or $opening )) {
        $tkt->show( -entry => $newpath );
        # counter-intuitive: want to display [-] if force opening and not leaf item
        $tkt->setmode( $newpath => 'close' ) if ( $force_open and $eltmode ne 'none' );
    }
    elsif ($force_close and $eltmode eq 'open') {
        $tkt->hide( -entry => $newpath );
    }
    else {
        $tkt->close($newpath);
    }
    # counterintuitive but right: scan will be done when the entry
    # is opened. mode can be open, close, none
    $scan_sub->( $force_open ) if ( ( $eltmode ne 'open' ) or $force_open );
}
sub trim_value {
    my $cw    = shift;
    my $value = shift;
    # undef value required lest Tk dies with:
    # value for "-text" missing at /usr/lib/x86_64-linux-gnu/perl5/5.28/Tk.pm line 251
    return undef unless defined $value; ## no critic(Subroutines::ProhibitExplicitReturnUndef)
    $value =~ s/\n/ /g;
    $value = substr( $value, 0, 15 ) . '...' if length($value) > 15;
    return $value;
}
sub disp_check_list {
    my ( $scanner, $data_ref, $node, $element_name, $index, $leaf_object ) = @_;
    my ( $path, $cw, $opening, $actions ) = @$data_ref;
    $logger->trace("disp_check_list    path is $path");
    my $value = $leaf_object->fetch;
    my $tkt = $cw->{tktree};
    $tkt->itemCreate( $path, 2, -text => $cw->trim_value($value) );
    my $std_v = $leaf_object->fetch('standard');
    $tkt->itemCreate( $path, 3, -text => $cw->trim_value($std_v) );
    if ( $leaf_object->has_data ) {
        $tkt->itemCreate( $path, 1, -itemtype => 'image', -image => $cust_img );
    }
    else {
        # remove image when value is identical to standard value
        $tkt->itemDelete( $path, 1 ) if $tkt->itemExists( $path, 1 );
    }
}
sub disp_leaf {
    my ( $scanner, $data_ref, $node, $element_name, $index, $leaf_object ) = @_;
    my ( $path, $cw, $opening, $actions ) = @$data_ref;
    $logger->trace("disp_leaf    path is $path");
    my $std_v = $leaf_object->fetch(qw/mode standard check no silent 1/);
    my $value = $leaf_object->fetch( check => 'no', silent => 1 );
    my $tkt   = $cw->{tktree};
    my $img;
    if ($leaf_object->has_error) {
        $img = $error_img;
    }
    elsif ($leaf_object->has_warning) {
        $img = $warn_img;
    }
    elsif ($leaf_object->has_data) {
        $img = $cust_img;
    }
    if ( defined $img ) {
        $tkt->itemCreate(
            $path, 1,
            -itemtype => 'image',
            -image    => $img
        );
    }
    elsif ($tkt->itemExists( $path, 1 )) {
        # remove image
        $tkt->itemDelete( $path, 1 ) ;
    }
    $tkt->itemCreate( $path, 2, -text => $cw->trim_value($value) );
    $tkt->itemCreate( $path, 3, -text => $cw->trim_value($std_v) );
}
sub disp_node {
    my ( $scanner, $data_ref, $node, $element_name, $key, $contained_node ) = @_;
    my ( $path, $cw, $opening, $actions ) = @$data_ref;
    $logger->trace("disp_node    path is $path");
    my $curmode = $cw->{tktree}->getmode($path);
    $cw->{tktree}->setmode( $path, 'open' ) if $curmode eq 'none';
    # explore next node
    $scanner->scan_node( $data_ref, $contained_node );
}
sub setup_scanner {
    my ($cw) = @_;
    require Config::Model::ObjTreeScanner;
    my $scanner = Config::Model::ObjTreeScanner->new(
        fallback => 'node',
        check    => 'no',
        # node callback
        node_content_cb => \&disp_obj_elt,
        # element callback
        list_element_cb       => \&disp_hash,
        check_list_element_cb => \&disp_check_list,
        hash_element_cb       => \&disp_hash,
        node_element_cb       => \&disp_node,
        # leaf callback
        leaf_cb            => \&disp_leaf,
        enum_value_cb      => \&disp_leaf,
        integer_value_cb   => \&disp_leaf,
        number_value_cb    => \&disp_leaf,
        boolean_value_cb   => \&disp_leaf,
        string_value_cb    => \&disp_leaf,
        uniline_value_cb   => \&disp_leaf,
        reference_value_cb => \&disp_leaf,
        # call-back when going up the tree
        up_cb => sub { },
    );
    $cw->{scanner} = $scanner;
}
my %widget_table = (
    edit => {
        leaf       => 'ConfigModelLeafEditor',
        check_list => 'ConfigModelCheckListEditor',
        list       => 'ConfigModelListEditor',
        hash       => 'ConfigModelHashEditor',
        node       => 'ConfigModelNodeEditor',
    },
    view => {
        leaf       => 'ConfigModelLeafViewer',
        check_list => 'ConfigModelCheckListViewer',
        list       => 'ConfigModelListViewer',
        hash       => 'ConfigModelHashViewer',
        node       => 'ConfigModelNodeViewer',
    },
);
sub create_element_widget {
    my $cw        = shift;
    my $mode      = shift;
    my $tree_path = shift;    # optional
    my $obj       = shift;    # optional if tree is not opened to path
    my $tree = $cw->{tktree};
    unless ( defined $tree_path ) {
        # pointery and rooty are common widget method and must called on
        # the right widget to give accurate results
        $tree_path = $tree->nearest( $tree->pointery - $tree->rooty );
    }
    if ( $tree->info( exists => $tree_path ) ) {
        $tree->selectionClear();    # clear all
        $tree->selectionSet($tree_path);
        my $data_ref = $tree->infoData($tree_path);
        unless ( defined $data_ref->[1] ) {
            $cw->reload;
            return;
        }
        $obj = $data_ref->[1];
        weaken($obj);
    }
    my $loc  = $obj->location;
    my $type = $obj->get_type;
    $logger->trace("item $loc to $mode (type $type)");
    my $e_frame = $cw->Subwidget('ed_frame');
    # cleanup existing widget contained in this frame
    delete $cw->{editor};
    map { $_->destroy if Tk::Exists($_) } $e_frame->children;
    my $widget = $widget_table{$mode}{$type}
        || die "Cannot find $mode widget for type $type";
    my $weak_cw = $cw;
    weaken($weak_cw);
    my @store = $mode eq 'edit' ? ( -store_cb => sub { $weak_cw->reload(@_) } ) : ();
    $cw->{current_mode} = $mode;
    my $tk_font = $cw->cget('-font');
    $cw->{editor} = $e_frame->$widget(
        -item => $obj,
        -path => $tree_path,
        -font => $tk_font,
        @store,
    );
    $cw->{editor}->ConfigSpecs( -font => ['DESCENDANTS', 'font','Font', $tk_font ]);
    $cw->{editor}->pack( -expand => 1, -fill => 'both' );
    return $cw->{editor};
}
sub edit_copy {
    my $cw  = shift;
    my $tkt = $cw->{tktree};
    my @selected = @_ ? @_ : $tkt->info('selection');
    #print "edit_copy @selected\n";
    my @res;
    foreach my $selection (@selected) {
        my $data_ref = $tkt->infoData($selection);
        my $cfg_elt   = $data_ref->[1];
        my $type      = $cfg_elt->get_type;
        my $cfg_class = $type eq 'node' ? $cfg_elt->config_class_name : '';
        #print "edit_copy '",$cfg_elt->location, "' type '$type' class '$cfg_class'\n";
        push @res,
            [
            $cfg_elt->element_name, $cfg_elt->index_value, $cfg_elt->composite_name,
            $type,                  $cfg_class,            $cfg_elt->dump_as_data() ];
    }
    $cw->{cut_buffer} = \@res;
    #use Data::Dumper; print "cut_buffer: ", Dumper( \@res ) ,"\n";
    return \@res;    # for tests
}
sub edit_paste {
    my $cw  = shift;
    my $tkt = $cw->{tktree};
    my @selected = @_ ? @_ : $tkt->info('selection');
    return unless @selected;
    #print "edit_paste in @selected\n";
    my @res;
    my $selection = $selected[0];
    my $data_ref = $tkt->infoData($selection);
    my $cfg_elt = $data_ref->[1];
    #print "edit_paste '",$cfg_elt->location, "' type '", $cfg_elt->get_type,"'\n";
    my $t_type  = $cfg_elt->get_type;
    my $t_class = $t_type eq 'node' ? $cfg_elt->config_class_name : '';
    my $t_name  = $cfg_elt->element_name;
    my $cut_buf = $cw->{cut_buffer} || [];
    foreach my $data (@$cut_buf) {
        my ( $name, $index, $composite, $type, $cfg_class, $dump ) = @$data;
        #print "from composite name '$composite' type $type\n";
        #print "t_name '$t_name' t_type '$t_type'  class '$t_class'\n";
        if ( ( $name eq $t_name and $type eq $t_type )
            or $t_class eq $cfg_class ) {
            $cfg_elt->load_data($dump);
        }
        elsif ( ( $t_type eq 'hash' or $t_type eq 'list' ) and defined $index ) {
            $cfg_elt->fetch_with_id($index)->load_data($dump);
        }
        elsif ( $t_type eq 'hash' or $t_type eq 'list' or $t_type eq 'leaf' ) {
            $cfg_elt->load_data($dump);
        }
        else {
            $cfg_elt->grab($composite)->load_data($dump);
        }
    }
    $cw->reload() if @$cut_buf;
    $cw->create_element_widget($cw->{current_mode}, $selection);
}
sub wizard {
    my $cw = shift;
    my $wiz = $cw->setup_wizard( sub { $cw->deiconify; $cw->raise; $cw->reload; } );
    # hide main window while wizard is running
    # end_cb callback will raise the main window
    $cw->withdraw;
    $wiz->prepare_wizard();
}
sub setup_wizard {
    my $cw      = shift;
    my $end_sub = shift;
    # when wizard is run, there's no need to update editor window in
    # main widget
    my $tk_font = $cw->cget('-font');
    return $cw->ConfigModelWizard(
        -root   => $cw->{instance}->config_root,
        -end_cb => $end_sub,
        -font => $tk_font,
    );
}
# FIXME: need to be able to search different types.
# 2 choices
# - destroy and re-create the searcher when it's modified
# - change the searcher (TreeSearcher) to accept type modif
# For the latter: it would be better to accept a set of types instead of
# all or just one type (to implement a set of check buttons)
sub create_find_widget {
    my $cw         = shift;
    my $f          = $cw->Frame( -relief => 'ridge', -borderwidth => 1, );
    my $remove_img = $cw->Photo( -file => $icon_path . 'remove.png' );
    $f->Button(
        -image   => $remove_img,
        -command => sub { $f->packForget(); },
        -relief  => 'flat',
    )->pack( -side => 'left' );
    my $searcher = $cw->{instance}->config_root->tree_searcher( type => 'all' );
    my $search = '';
    my @result;
    $f->Label( -text => 'Find: ' )->pack( -side => 'left' );
    my $e = $f->Entry(
        -textvariable => \$search,
        -validate     => 'key',
        # ditch the search results when find entry is modified.
        -validatecommand => sub { @result = (); return 1; },
    )->pack( -side => 'left' );
    $cw->Advertise( find_entry => $e );
    foreach my $direction (qw/previous next/) {
        my $s = sub { $cw->find_item( $direction, $searcher, \$search, \@result ); };
        $f->Button(
            -compound => 'left',
            -image    => $gnome_img{$direction},
            -text     => ucfirst($direction),
            -command  => $s,
            -relief   => 'flat',
        )->pack( -side => 'left' );
    }
    # bind Return (or Enter) key
    $e->bind( '<Key-Return>', sub { $cw->find_item( 'next', $searcher, \$search, \@result ); } );
    return $f;
}
sub pack_find_widget {
    my $cw = shift;
    $cw->Subwidget('find_frame')->pack( -anchor => 'w', -fill => 'x' );
    $cw->Subwidget('find_entry')->focus;
}
sub find_item {
    my ( $cw, $direction, $searcher, $search_ref, $result ) = @_;
    my $find_frame = $cw->Subwidget('find_frame');
    # search the tree, store the result
    if (not @$result) {
        $logger->debug("Running search on $$search_ref");
        @$result = $searcher->search($$search_ref);
        $logger->trace("Search on $$search_ref result: @$result");
    }
    # and jump in the list widget any time next is hit.
    if (@$result) {
        if ( defined $cw->{old_path} and $direction eq 'next' ) {
            push @$result, shift @$result;
        }
        elsif ( defined $cw->{old_path} ) {
            unshift @$result, pop @$result;
        }
        my $path = $result->[0];
        $cw->{old_path} = $path;
        $cw->force_element_display( $cw->{instance}->config_root->grab($path) );
    }
}
1;
# ABSTRACT: a GUI to edit configuration data with Config::Model framework
__END__
HideShow 191 lines of Pod
=head1 NAME
Config::Model::TkUI - Tk GUI to edit config data through Config::Model
=head1 SYNOPSIS
 use Config::Model::TkUI;
 # init trace
 Log::Log4perl->easy_init($WARN);
 # create configuration instance
 my $model = Config::Model -> new ;
 my $inst = $model->instance (root_class_name => 'a_config_class',
                              instance_name   => 'test');
 # Tk part
 my $mw = MainWindow-> new ;
 $mw->withdraw ;
 $mw->ConfigModelUI (-instance => $inst) ;
 MainLoop ;
=head1 DESCRIPTION
This class provides a GUI for L<Config::Model>.
With this class, L<Config::Model> and an actual configuration
model (like L<Config::Model::Xorg>), you get a tool to
edit configuration files (e.g. C</etc/X11/xorg.conf>).
=head1 USAGE
=head2 Left side tree
=over
=item *
Click on '+' and '-' boxes to open or close content
=item *
Left-click on item to open a viewer widget.
=item *
Double-click or hit "return" on any item to open an editor widget
=item *
Use Ctrl-C to copy configuration data in an internal buffer
=item *
Use Ctrl-V to copy configuration data from the internal buffer to the
configuration tree. Beware, there's no "undo" operation.
=item *
Before saving your modifications, you can review the change list with the 
menu entry C<< File -> show unsaved changes >>. This list is cleared after 
performing a C<< File -> save >>.
=item *
Pasting cut buffer into:
=over
=item *
a leaf element will store the content of the
buffer into the element.
=item *
a list element will split the content of the
buffer with /\n/ or /,/ and push the resulting array at the 
end of the list element. 
=item *
a hash element will use the content of the cut buffer to create a new key 
in the hash element. 
=back
=back
=head2 Font size and big screens
Font type and size can be adjusted using menu: "Options -> Font" menu. This setup is saved in file
C<~/.cme/config/tkui.yml>.
=head2 Search
Hit C<Ctrl-F> or use menu C<< Edit -> Search >> to open a search widget at the bottom 
of the window.
Enter a keyword in the entry widget and click on C<Next> button.
The keyword will be searched in the configuration tree, in element name, in element value and 
in documentation.
=head2 Editor widget
The right side of the widget is either a viewer or an editor. When
clicking on store in the editor, the new data is stored in the tree
represented on the left side of TkUI. The new data will be stored in
the configuration file only when C<File->save> menu is invoked.
=head2 Wizard
A wizard can be launched either with C<< File -> Wizard >> menu entry
or with C<Run Wizard> button.
The wizard will scan the configuration tree and stop on all items
flagged as important in the model. It will also stop on all erroneous
items (mostly missing mandatory values).
=head1 Methods
=head2 save(callback)
Save modified data in configuration file. The callback function is
called only if the save was done without error. The callback is called
with C<$@> in case of failed save.
=head1 TODO
- add tabular view ?
- expand the whole tree at once
- add plug-in mechanism so that dedicated widget
  can be used for some config Class (Could be handy for
  Xorg::ServerLayout)
=head1 More information
=over
=item *
See L<Config::Model home page|https://github.com/dod38fr/config-model/wiki>
=item *
Or L<Author's blog|http://ddumont.wordpress.com> where you can find many post about L<Config::Model>.
=back
=head1 FEEDBACK and HELP wanted
This project needs feedback from its users. Please send your
feedbacks, comments and ideas to the author.
=over
=item *
Look and feel of Perl/Tk interface can be improved
=item *
A nicer logo (maybe a penguin with a wrench...) would be welcomed
=item *
Config::Model could use a web interface
=item *
May be also an interface based on Gtk or Wx for better integration in
Desktop
=back
=head1 SEE ALSO
=over
=item *
L<Config::Model>, L<cme>
=item *
https://github.com/dod38fr/config-model-tkui/wiki
=back