FIJINetSelection.pm 11.7 KB
 Stefan Tauner committed May 04, 2018 1 2 3 #----------------------------------------------------------------------- # Fault InJection Instrumenter (FIJI) # https://embsys.technikum-wien.at/projects/vecs/fiji  Christian Fibich committed May 04, 2018 4 #  Stefan Tauner committed May 04, 2018 5 6 7 8 # 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). #  Stefan Tauner committed May 04, 2018 9 10 11 # Authors: # Christian Fibich # Stefan Tauner  Christian Fibich committed May 04, 2018 12 #  Stefan Tauner committed May 04, 2018 13 14 # This module is free software; you can redistribute it and/or modify # it under the same terms as Perl itself.  Christian Fibich committed May 04, 2018 15 #  Stefan Tauner committed May 04, 2018 16 17 18 19 20 21 # 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. #-----------------------------------------------------------------------  Christian Fibich committed May 04, 2018 22 23  ## @file  Stefan Tauner committed May 04, 2018 24 # @brief Contains class \ref Tk::FIJINetSelection  Christian Fibich committed May 04, 2018 25   Stefan Tauner committed May 04, 2018 26 ## @class Tk::FIJINetSelection  Stefan Tauner committed May 04, 2018 27 28 # @brief Tk Widget to search for and select a subset of a number of strings (usually net names)  Christian Fibich committed May 04, 2018 29 30 31 32 33 34 35 36 37 38 39 package Tk::FIJINetSelection; use strict; use warnings; use utf8; use Log::Log4perl qw(get_logger); use FIJI qw(:all); use Tk;  Stefan Tauner committed May 04, 2018 40 41 use Tk::widgets qw(Listbox LabFrame Label Entry Button Checkbutton); use Tk::FIJISearchWidget;  Christian Fibich committed May 04, 2018 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 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'};  61 62 63 $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'});  Christian Fibich committed May 04, 2018 64 $self->SUPER::Populate($args);  Christian Fibich committed May 04, 2018 65 $self->{'found_netnames'} = [];  Christian Fibich committed May 04, 2018 66 67 68 69 70 71 72  $self->_populate_widget($self); $self->update(); } sub _populate_widget { my$self = shift;  Christian Fibich committed May 04, 2018 73 74  # Tab order depends on creation order. # Thus, create in the following order  Stefan Tauner committed May 04, 2018 75 76 77 78 79  # 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  Christian Fibich committed May 04, 2018 80   Stefan Tauner committed May 04, 2018 81 82  # 1. The search widget my $search_entry_widget =$self->FIJISearchWidget(-label => 'Net name filter', -callback => \&_match_nets, -userdata => $self);  Christian Fibich committed May 04, 2018 83   Stefan Tauner committed May 04, 2018 84  # 2. The found listbox  Christian Fibich committed May 04, 2018 85  my$found_listbox_labframe = $self->LabFrame(-label=>'Matching nets');  Christian Fibich committed May 04, 2018 86  my$found_listbox_scroll = $found_listbox_labframe->Scrolled('Listbox',-scrollbars=>'osre',-selectmode=>'single')->pack(-expand=>1,-fill=>'both');  Christian Fibich committed May 04, 2018 87 $self->{'found_listbox'} = $found_listbox_scroll->Subwidget('scrolled');  Christian Fibich committed May 04, 2018 88 89 90 91 92 93 $self->{'found_listbox'}->bind('',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('', sub {$self->{'found_listbox'}->selectionClear(0,'end');$self->{'found_listbox'}->selectionSet('active')} ); $self->{'found_listbox'}->bind('', sub {$self->{'found_listbox'}->selectionClear(0,'end'); $self->{'found_listbox'}->selectionSet('active')} );  Christian Fibich committed May 04, 2018 94 95   Stefan Tauner committed May 04, 2018 96  # 3. The select buttons  Christian Fibich committed May 04, 2018 97 $self->{'select_button'} = $self->Button(-text=>'>',-state=>'disabled');  Christian Fibich committed May 04, 2018 98   99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114  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; }); }  Stefan Tauner committed May 04, 2018 115  # 4. The unselect button  Christian Fibich committed May 04, 2018 116 $self->{'unselect_button'} = $self->Button(-text=>'<',-state=>'disabled');  Christian Fibich committed May 04, 2018 117   118 119  if ($self->{'select_multiple'}) { $self->{'unselect_all_button'} =$self->Button(-text=>'<<',-state=>'disabled', -command=> sub {  Christian Fibich committed May 04, 2018 120 121 122  # empty out the listref undef(@{$self->{'selected_nets_listref'}});$self->{'selected_listbox'}->configure(-listvariable=>$self->{'selected_nets_listref'});  123 124 125 126 127 128 $self->{'unselect_all_button'}->configure(-state=>'disabled'); $self->{'unselect_button'}->configure(-state=>'disabled');$self->{'selected'} = 0; }); }  Stefan Tauner committed May 04, 2018 129  # 5. The selected listbox  Christian Fibich committed May 04, 2018 130  my $selected_listbox_labframe =$self->LabFrame(-label=>'Selected net');  Christian Fibich committed May 04, 2018 131 132 133 134 135 136 137 138  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  139  if (@{$self->{'selected_nets_listref'}} > 0) {  Christian Fibich committed May 04, 2018 140 141 142 143 144 $self->{'unselect_button'}->configure(-state=>'active'); $self->{'selected'} = 1; } else {$self->{'selected'} = 0; }  Christian Fibich committed May 04, 2018 145   146 147  $self->{'selected_listbox'}->configure(-listvariable=>$self->{'selected_nets_listref'});  Christian Fibich committed May 04, 2018 148 149  # Button commands  Christian Fibich committed May 04, 2018 150 151 152 153  # 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  Christian Fibich committed May 04, 2018 154 155  # - disable the select button, enable the unselect button $self->{'select_button'}->configure(-command => sub {  Christian Fibich committed May 04, 2018 156 157  return if (@{$self->{'found_netnames'}} == 0); my $selected_index =$self->{'found_listbox'}->index('active');  158 159 160 161 162  # 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];  Christian Fibich committed May 04, 2018 163  $self->{'unselect_button'}->configure(-state=>'active');  164 165 $self->{'unselect_all_button'}->configure(-state=>'active') if ($self->{'select_multiple'});$self->{'select_button'}->configure(-state=>'disabled') if (!$self->{'select_multiple'});  Christian Fibich committed May 04, 2018 166 $self->{'selected'} = 1;  Christian Fibich committed May 04, 2018 167  });  Christian Fibich committed May 04, 2018 168 169 170 171  $self->{'found_listbox'}->bind('',sub {$self->{'found_listbox'}->focus; $self->{'select_button'}->invoke;} );  Christian Fibich committed May 04, 2018 172 $self->{'found_listbox'}->bind('',sub {$self->{'select_button'}->invoke} );  Christian Fibich committed May 04, 2018 173   Christian Fibich committed May 04, 2018 174 175 176  # if the unselect button is pressed # - unset the saved index # - set the listvariable of the right listbox to an empty list  Christian Fibich committed May 04, 2018 177 178  # - enable the select button, disable the unselect button$self->{'unselect_button'}->configure(-command => sub {  179 180 181  my $selected_index =$self->{'selected_listbox'}->index('active'); # can't use grep (segfault) my @new_selected_nets = ();  Christian Fibich committed May 04, 2018 182  return if ($selected_index >= @{$self->{'selected_nets_listref'}});  183 184 185 186 187 188 189 190 191  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;  Christian Fibich committed May 04, 2018 192 193 194 195 196  if (@{$self->{'selected_nets_listref'}} == 0) { $self->{'unselect_all_button'}->configure(-state=>'disabled');$self->{'unselect_button'}->configure(-state=>'disabled'); $self->{'selected'} = 0; }  197 198 199 200 201 202  } else {$self->{'select_button'}->configure(-state=>'active') if @{$self->{'found_netnames'}} > 0;$self->{'unselect_button'}->configure(-state=>'disabled'); $self->{'selected'} = 0; }  Christian Fibich committed May 04, 2018 203  });  Christian Fibich committed May 04, 2018 204 205 206 207 208 209  # Bind with double click$self->{'selected_listbox'}->bind('',sub {$self->{'unselect_button'}->invoke} );$self->{'selected_listbox'}->bind('',sub { $self->{'found_listbox'}->focus;$self->{'unselect_button'}->invoke;} );  Christian Fibich committed May 04, 2018 210 211  # place widgets  Stefan Tauner committed May 04, 2018 212  $search_entry_widget->grid(-column=>0,-row=>0,-columnspan=>4,-sticky=>'nsew');  Christian Fibich committed May 04, 2018 213 214 $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');  Christian Fibich committed May 04, 2018 215 216 $self->{'select_button'}->grid(-column=>1,-row=>1); $self->{'unselect_button'}->grid(-column=>1,-row=>2);  217 218 219 220  if ($self->{'select_multiple'}) { $self->{'select_all_button'}->grid(-column=>1,-row=>3);$self->{'unselect_all_button'}->grid(-column=>1,-row=>4); }  Christian Fibich committed May 04, 2018 221 222 223 224 225 226  $self->gridColumnconfigure(0, -weight => 1);$self->gridColumnconfigure(2, -weight => 1); $self->gridRowconfigure(3, -weight => 1); } sub _match_nets {  Stefan Tauner committed May 04, 2018 227  my$logger = get_logger("");  Stefan Tauner committed May 04, 2018 228  my ($regex,$self) = @_;  Christian Fibich committed May 04, 2018 229   Christian Fibich committed May 04, 2018 230 231  $self->Busy;  Stefan Tauner committed May 04, 2018 232  # TODO: check for (too many) spaces in regex?  Christian Fibich committed May 04, 2018 233   Stefan Tauner committed May 04, 2018 234  # filter nets by regex - we could use grep but that segfaults somewhere in the TCL wrapper  Christian Fibich committed May 04, 2018 235 236  my @matching_nets; for my$net (@{$self->{'nets'}}) {  Christian Fibich committed May 04, 2018 237  push @matching_nets,$net if ($net =~$regex);  Christian Fibich committed May 04, 2018 238 239 240  } my @filtered_nets = sort(@matching_nets);  Christian Fibich committed May 04, 2018 241 242 243 244 245  # 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'});  Christian Fibich committed May 04, 2018 246   247 248 249 250 251  # 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); }  252  \$self->Unbusy;  Christian Fibich committed May 04, 2018 253 254 }  255 1;