FIJINetSelection.pm

#-----------------------------------------------------------------------
# Fault InJection Instrumenter (FIJI)
# https://embsys.technikum-wien.at/projects/vecs/fiji
#
# The creation of this file has been supported by the publicly funded
# R&D project Josef Ressel Center for Verification of Embedded Computing
# Systems (VECS) managed by the Christian Doppler Gesellschaft (CDG).
#
# Authors:
# Christian Fibich <fibich@technikum-wien.at>
# Stefan Tauner <tauner@technikum-wien.at>
#
# This module is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
#
# See the LICENSE file for more details.
#-----------------------------------------------------------------------

## @file
# @brief Contains class \ref Tk::FIJINetSelection

## @class Tk::FIJINetSelection
# @brief Tk Widget to search for and select a subset of a number of strings (usually net names)

package Tk::FIJINetSelection;

use strict;
use warnings;
use utf8;

use Log::Log4perl qw(get_logger);

use FIJI qw(:all);

use Tk;
use Tk::widgets qw(Listbox LabFrame Label Entry Button Checkbutton);
use Tk::FIJISearchWidget;
use base qw(Tk::Frame);

Construct Tk::Widget 'FIJINetSelection';

sub ClassInit {
    my ($class, $mw) = @_;
    $class->SUPER::ClassInit($mw);

    my $self = bless {}, $class;
    return $self;
}

#
# Takes the following parameters at creation:
#   -nets A list of net names as strings
#   All parameters a Tk::Frame accepts
sub Populate {
    my ($self, $args) = @_;
    $self->{'nets'}  = delete $args->{'-nets'};
    $self->{'selected_nets_listref'} = delete $args->{'-selected_nets_listref'};
    $self->{'select_multiple'} = delete $args->{'-select_multiple'};
    $self->{'select_multiple'} = 0 if (!defined $self->{'select_multiple'});
    $self->SUPER::Populate($args);
    $self->{'found_netnames'} = [];
    $self->_populate_widget($self);
    $self->update();
}

sub _populate_widget {
    my $self = shift;

    # Tab order depends on creation order.
    # Thus, create in the following order
    # 1. The search widget
    # 2. The found listbox (In a Scrolled in a Labframe)
    # 3. The select button
    # 4. The unselect button
    # 5. The selected listbox

    # 1. The search widget
    my $search_entry_widget = $self->FIJISearchWidget(-label => 'Net name filter', -callback => \&_match_nets, -userdata => $self);

    # 2. The found listbox
    my $found_listbox_labframe    = $self->LabFrame(-label=>'Matching nets');
    my $found_listbox_scroll      = $found_listbox_labframe->Scrolled('Listbox',-scrollbars=>'osre',-selectmode=>'single')->pack(-expand=>1,-fill=>'both');
    $self->{'found_listbox'}      = $found_listbox_scroll->Subwidget('scrolled');
    $self->{'found_listbox'}->bind('<Button-1>',sub {$self->{'found_listbox'}->focus} );
    # make selection with keyboard arrows possible
    # the default for the arrow keys is just to set an entry 'active' (i.e., underline it)
    # the behavior below always selects one entry
    $self->{'found_listbox'}->bind('<Up>',   sub {$self->{'found_listbox'}->selectionClear(0,'end'); $self->{'found_listbox'}->selectionSet('active')} );
    $self->{'found_listbox'}->bind('<Down>', sub {$self->{'found_listbox'}->selectionClear(0,'end'); $self->{'found_listbox'}->selectionSet('active')} );


    # 3. The select buttons
    $self->{'select_button'}   = $self->Button(-text=>'>',-state=>'disabled');

    if ($self->{'select_multiple'}) {
        $self->{'select_all_button'}   = $self->Button(-text=>'>>',-state=>'disabled', -command=> sub {
            foreach my $netname (@{$self->{'found_netnames'}}) {
                my $already_in_list = 0;
                for (my $i = 0; $i < @{$self->{'selected_nets_listref'}}; $i++) {
                    $already_in_list = 1 if @{$self->{'selected_nets_listref'}}[$i] eq $netname;
                }
                push @{$self->{'selected_nets_listref'}}, $netname if (!$already_in_list);
            }
            $self->{'unselect_all_button'}->configure(-state=>'active');
            $self->{'unselect_button'}->configure(-state=>'active');
            $self->{'selected'} = 1;
        });
    }


    # 4. The unselect button
    $self->{'unselect_button'} = $self->Button(-text=>'<',-state=>'disabled');

    if ($self->{'select_multiple'}) {
        $self->{'unselect_all_button'}   = $self->Button(-text=>'<<',-state=>'disabled', -command=> sub {
            # empty out the listref
            undef(@{$self->{'selected_nets_listref'}});
            $self->{'selected_listbox'}->configure(-listvariable=>$self->{'selected_nets_listref'});
            $self->{'unselect_all_button'}->configure(-state=>'disabled');
            $self->{'unselect_button'}->configure(-state=>'disabled');
            $self->{'selected'} = 0;
        });
    }

    # 5. The selected listbox
    my $selected_listbox_labframe = $self->LabFrame(-label=>'Selected net');
    my $selected_listbox_scroll   = $selected_listbox_labframe->Scrolled('Listbox',-scrollbars=>'osre',-selectmode=>'single')->pack(-expand=>1,-fill=>'both');
    $self->{'selected_listbox'}   = $selected_listbox_scroll->Subwidget('scrolled');


    # When there is defined an initial net, add that to the selected listbox
    # and disable the select button
    # Otherwise, no net is shown in the selected listbox and the select button
    # is enabled
    if (@{$self->{'selected_nets_listref'}} > 0) {
        $self->{'unselect_button'}->configure(-state=>'active');
        $self->{'selected'} = 1;
    } else {
        $self->{'selected'} = 0;
    }

    $self->{'selected_listbox'}->configure(-listvariable=>$self->{'selected_nets_listref'});

    # Button commands
    
    # if the select button is pressed:
    # - copy the currently selected net name to a new list, and set
    #   that list as listvariable of the right listbox
    # - save the index of the selected element in the list of found nets
    # - disable the select button, enable the unselect button
    $self->{'select_button'}->configure(-command => sub {
                                return if (@{$self->{'found_netnames'}} == 0);
                                my $selected_index = $self->{'found_listbox'}->index('active');
                                # don't allow the same net to be added twice
                                foreach my $netname (@{$self->{'selected_nets_listref'}}) {
                                    return if $netname eq @{$self->{'found_netnames'}}[$selected_index];
                                }
                                push @{$self->{'selected_nets_listref'}}, @{$self->{'found_netnames'}}[$selected_index];
                                $self->{'unselect_button'}->configure(-state=>'active');
                                $self->{'unselect_all_button'}->configure(-state=>'active') if ($self->{'select_multiple'});
                                $self->{'select_button'}->configure(-state=>'disabled') if (!$self->{'select_multiple'});
                                $self->{'selected'} = 1;
                              });
    $self->{'found_listbox'}->bind('<Double-Button-1>',sub {
                                                                $self->{'found_listbox'}->focus;
                                                                $self->{'select_button'}->invoke;}
                                  );
    $self->{'found_listbox'}->bind('<Return>',sub {$self->{'select_button'}->invoke} );

    # if the unselect button is pressed
    # - unset the saved index
    # - set the listvariable of the right listbox to an empty list
    # - enable the select button, disable the unselect button
    $self->{'unselect_button'}->configure(-command => sub {
                                my $selected_index = $self->{'selected_listbox'}->index('active');
                                # can't use grep (segfault)
                                my @new_selected_nets = ();
                                return if ($selected_index >= @{$self->{'selected_nets_listref'}});
                                for (my $i = 0; $i < @{$self->{'selected_nets_listref'}}; $i++) {
                                    my $netname = @{$self->{'selected_nets_listref'}}[$i];
                                    push (@new_selected_nets, $netname) unless ($netname eq @{$self->{'selected_nets_listref'}}[$selected_index]);
                                }
                                @{$self->{'selected_nets_listref'}} = @new_selected_nets;
                                $self->{'selected_listbox'}->configure(-listvariable=>$self->{'selected_nets_listref'});

                                if ($self->{'select_multiple'}) {
                                    $self->{'select_button'}->configure(-state=>'active') if @{$self->{'found_netnames'}} > 0;
                                    if (@{$self->{'selected_nets_listref'}} == 0) {
                                        $self->{'unselect_all_button'}->configure(-state=>'disabled');
                                        $self->{'unselect_button'}->configure(-state=>'disabled');
                                        $self->{'selected'} = 0;
                                    }
                                } else {
                                    $self->{'select_button'}->configure(-state=>'active') if @{$self->{'found_netnames'}} > 0;
                                    $self->{'unselect_button'}->configure(-state=>'disabled');
                                    $self->{'selected'} = 0;
                                }
                                
                              });
    # Bind with double click
    $self->{'selected_listbox'}->bind('<Return>',sub {$self->{'unselect_button'}->invoke} );
    $self->{'selected_listbox'}->bind('<Double-Button-1>',sub {
                                                                $self->{'found_listbox'}->focus;
                                                                $self->{'unselect_button'}->invoke;}
                                  );

    # place widgets
    $search_entry_widget->grid(-column=>0,-row=>0,-columnspan=>4,-sticky=>'nsew');
    $found_listbox_labframe->grid(-column=>0,-row=>1,-columnspan=>1,-rowspan=>3,-sticky=>'nsew');
    $selected_listbox_labframe->grid(-column=>2,-row=>1,-columnspan=>2,-rowspan=>3,-sticky=>'nsew');
    $self->{'select_button'}->grid(-column=>1,-row=>1);
    $self->{'unselect_button'}->grid(-column=>1,-row=>2);
    if ($self->{'select_multiple'}) {
       $self->{'select_all_button'}->grid(-column=>1,-row=>3);
       $self->{'unselect_all_button'}->grid(-column=>1,-row=>4);
    }
    $self->gridColumnconfigure(0, -weight => 1);
    $self->gridColumnconfigure(2, -weight => 1);
    $self->gridRowconfigure(3, -weight => 1);
}

sub _match_nets {
    my $logger = get_logger("");
    my ($regex, $self) = @_;

    $self->Busy;

    # TODO: check for (too many) spaces in regex?

    # filter nets by regex - we could use grep but that segfaults somewhere in the TCL wrapper
    my @matching_nets;
    for my $net (@{$self->{'nets'}}) {
        push @matching_nets, $net if ($net =~ $regex);
    }
    
    my @filtered_nets = sort(@matching_nets);

    # save the reference to the new list
    $self->{'found_netnames'} = \@filtered_nets;
    # set this new reference as data base for the left listbox
    $self->{'found_listbox'}->configure(-listvariable=>$self->{'found_netnames'});

    # enable the select buttons when no net is selected and there are nets available
    $self->{'select_button'}->configure(-state=>'active') if (@filtered_nets > 0 && (!$self->{'selected'} || $self->{'select_multiple'}));
    if ($self->{'select_multiple'}) {
        $self->{'select_all_button'}->configure(-state=>'active') if (@filtered_nets > 0);
    }
    $self->Unbusy;
}

1;