Config-Model-TkUI

 view release on metacpan or  search on metacpan

lib/Config/Model/TkUI.pm  view on Meta::CPAN

#
# 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.381;

use 5.20.1;
use strict;
use warnings;
use Carp;

use feature qw/postderef signatures/;
no warnings qw/experimental::postderef experimental::signatures/;

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.135; # reset config clears changes

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;

lib/Config/Model/TkUI.pm  view on Meta::CPAN

    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;

    $cw->add_file_menu($menubar, $extra_menu);
    $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 } );

    $cw->add_edit_menu($menubar);

    my $history_menu = $menubar->cascade(-label => 'History');

    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' );
    $cw->{path_history} = [];
    $cw->{path_index} = 0;

    # add button
    my $previous_btn = $loc_frame->Button (
        -image => $gnome_img{'previous'},
        -state => 'disabled',
        -command => sub { $cw->go_to_previous();},
    );
    $previous_btn->pack(-side => 'left');
    my $next_btn = $loc_frame->Button (
        -image => $gnome_img{'next'},
        -state => 'disabled',
        -command => sub { $cw->go_to_next();},
    );
    $next_btn->pack(-side => 'left');

    $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');

lib/Config/Model/TkUI.pm  view on Meta::CPAN

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 every 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->selectionClear();
    $tree->anchorClear();
    $tree->see($path);
    $tree->anchorSet($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) = @_;

lib/Config/Model/TkUI.pm  view on Meta::CPAN

    # 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 );

lib/Config/Model/TkUI.pm  view on Meta::CPAN

    my $scanner = Config::Model::ObjTreeScanner->new(
        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,
    );

    $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];