view release on metacpan or  search on metacpan

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

}

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

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

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