FIJINetSelection.pm 11.7 KB
Newer Older
1
2
3
#-----------------------------------------------------------------------
# Fault InJection Instrumenter (FIJI)
# https://embsys.technikum-wien.at/projects/vecs/fiji
4
#
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).
#
9
10
11
# Authors:
# Christian Fibich <fibich@technikum-wien.at>
# Stefan Tauner <tauner@technikum-wien.at>
12
#
13
14
# This module is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
15
#
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.
#-----------------------------------------------------------------------
22
23

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

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

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;
40
41
use Tk::widgets qw(Listbox LabFrame Label Entry Button Checkbutton);
use Tk::FIJISearchWidget;
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'});
64
    $self->SUPER::Populate($args);
65
    $self->{'found_netnames'} = [];
66
67
68
69
70
71
72
    $self->_populate_widget($self);
    $self->update();
}

sub _populate_widget {
    my $self = shift;

73
74
    # Tab order depends on creation order.
    # Thus, create in the following order
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's avatar
Christian Fibich committed
80

81
82
    # 1. The search widget
    my $search_entry_widget = $self->FIJISearchWidget(-label => 'Net name filter', -callback => \&_match_nets, -userdata => $self);
Christian Fibich's avatar
Christian Fibich committed
83

84
    # 2. The found listbox
85
    my $found_listbox_labframe    = $self->LabFrame(-label=>'Matching nets');
86
    my $found_listbox_scroll      = $found_listbox_labframe->Scrolled('Listbox',-scrollbars=>'osre',-selectmode=>'single')->pack(-expand=>1,-fill=>'both');
87
    $self->{'found_listbox'}      = $found_listbox_scroll->Subwidget('scrolled');
88
89
90
91
92
93
    $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')} );
94
95


96
    # 3. The select buttons
97
    $self->{'select_button'}   = $self->Button(-text=>'>',-state=>'disabled');
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;
        });
    }


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

118
119
    if ($self->{'select_multiple'}) {
        $self->{'unselect_all_button'}   = $self->Button(-text=>'<<',-state=>'disabled', -command=> sub {
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;
        });
    }

129
    # 5. The selected listbox
130
    my $selected_listbox_labframe = $self->LabFrame(-label=>'Selected net');
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) {
140
141
142
143
144
        $self->{'unselect_button'}->configure(-state=>'active');
        $self->{'selected'} = 1;
    } else {
        $self->{'selected'} = 0;
    }
145

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

148
149
    # Button commands
    
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
154
155
    # - disable the select button, enable the unselect button
    $self->{'select_button'}->configure(-command => sub {
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];
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'});
166
                                $self->{'selected'} = 1;
167
                              });
168
169
170
171
    $self->{'found_listbox'}->bind('<Double-Button-1>',sub {
                                                                $self->{'found_listbox'}->focus;
                                                                $self->{'select_button'}->invoke;}
                                  );
172
    $self->{'found_listbox'}->bind('<Return>',sub {$self->{'select_button'}->invoke} );
173

174
175
176
    # if the unselect button is pressed
    # - unset the saved index
    # - set the listvariable of the right listbox to an empty list
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 = ();
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;
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;
                                }
                                
203
                              });
204
205
206
207
208
209
    # 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;}
                                  );
210
211

    # place widgets
212
    $search_entry_widget->grid(-column=>0,-row=>0,-columnspan=>4,-sticky=>'nsew');
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');
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);
    }
221
222
223
224
225
226
    $self->gridColumnconfigure(0, -weight => 1);
    $self->gridColumnconfigure(2, -weight => 1);
    $self->gridRowconfigure(3, -weight => 1);
}

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

230
231
    $self->Busy;

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

234
    # filter nets by regex - we could use grep but that segfaults somewhere in the TCL wrapper
235
236
    my @matching_nets;
    for my $net (@{$self->{'nets'}}) {
237
        push @matching_nets, $net if ($net =~ $regex);
238
239
240
    }
    
    my @filtered_nets = sort(@matching_nets);
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'});
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;
253
254
}

255
1;