Config-Model-TkUI

 view release on metacpan or  search on metacpan

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

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

    $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

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

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

    return;
}

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

sub add_edit_menu($cw, $menubar) {
    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 );
    return;
}

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

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

    }

    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->update_history($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];
    my $loc = $cw->{location} = $obj->location_short;
    return $loc;
}

sub update_history ($cw, $loc) {
    my $history = $cw->{path_history};

    # avoid consecutive duplicated entries
    if ($history->@* > 1 and $loc eq $history->[-1]) {
        return;
    }

    push $history->@*, $loc;
    my $path_idx = $cw->{path_index} = $history->$#*;

    # enable previous button when history has more than one item
    $cw->Subwidget('prev_btn')->configure(-state => $path_idx > 0 ? 'normal' : 'disabled');

    my $h_cascade = $cw->Subwidget('history');

    my $max_count = 20;
    $cw->{history_count} //= 0;

    if ($cw->{history_count}++ > $max_count) {
        # delete all history entries from the menu
        $h_cascade->menu->delete(0, 'end');

        # Add the last $max_count history entries to the menu
        for (my $i = 0; $i <= $max_count; $i++) {
            my $entry_idx = $path_idx - $i;
            $h_cascade->menu->add(
                'command',
                -label => $history->[$entry_idx],
                -command =>sub { $cw->go_to_loc($path_idx); }
            );
        }
    }
    else {
        # add a menu entry
        $h_cascade->command(
            -label => $loc,
            -command => sub { $cw->go_to_loc($path_idx); }
        );
    }

    return;
}

sub go_to_loc ($cw, $idx) {
    my $path = $cw->{path_history}[$idx];
    my $loc = $cw->update_loc_bar($path);
    # enable previous button when history has more than one item
    $cw->Subwidget('prev_btn')->configure(-state => $idx > 0 ? 'normal' : 'disabled');
    # when jumping into history, the next location does not make
    # sense, hence next button is disabled
    $cw->Subwidget('next_btn')->configure(-state => 'disabled');
    $cw->force_display($path, $loc);
    $cw->create_element_widget('view', $path);
}

sub go_to_previous ($cw) {
    my $idx = --$cw->{path_index};
    my $path = $cw->{path_history}[$idx];
    my $loc = $cw->update_loc_bar($path);
    $cw->Subwidget('prev_btn')->configure(-state => $idx > 0 ? 'normal' : 'disabled');
    $cw->Subwidget('next_btn')->configure(-state => 'normal');
    $cw->force_display($path, $loc);
    $cw->create_element_widget('view', $path);
}

sub go_to_next ($cw) {
    my $idx = ++$cw->{path_index};
    my $path = $cw->{path_history}[$idx];
    my $history_last_idx = $cw->{path_history}->$#*;

    my $loc = $cw->update_loc_bar($path);
    $cw->Subwidget('prev_btn')->configure(-state => 'normal');
    $cw->Subwidget('next_btn')->configure(-state => $idx < $history_last_idx ? 'normal' : 'disabled');
    $cw->force_display($path, $loc);
    $cw->create_element_widget('view', $path);
}

sub on_select {
    my ( $cw, $path ) = @_;
    $cw->update_loc_bar($path);
    $cw->update_history($path);
    $cw->create_element_widget('edit');
}

sub on_cut_buffer_dump {
    my ( $cw, $tree_path, $selection_for_test ) = @_;
    $cw->update_loc_bar($tree_path);
    $cw->update_history($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];