FIJISettingsViewer.pm 66 KB
Newer Older
1
2
3
#-----------------------------------------------------------------------
# Fault InJection Instrumenter (FIJI)
# https://embsys.technikum-wien.at/projects/vecs/fiji
Christian Fibich's avatar
Christian Fibich committed
4
#
5
6
# Copyright (C) 2017 Christian Fibich <fibich@technikum-wien.at>
# Copyright (C) 2017 Stefan Tauner <tauner@technikum-wien.at>
Christian Fibich's avatar
Christian Fibich committed
7
#
8
9
# This module is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
Christian Fibich's avatar
Christian Fibich committed
10
#
11
12
13
14
15
16
# 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's avatar
Christian Fibich committed
17

18
## @file
Christian Fibich's avatar
Christian Fibich committed
19
# @brief Contains class \ref Tk::FIJISettingsViewer
20
21

## @class Tk::FIJISettingsViewer
Christian Fibich's avatar
Christian Fibich committed
22
# @brief A Tk::Frame widget to display all \ref FIJI::Settings
23

24
25
26
27
package Tk::FIJISettingsViewer;

use strict;
use warnings;
28
29
use utf8;

30
31
use Log::Log4perl qw(get_logger);
use Scalar::Util 'blessed';
32
use FIJI::Utils;
33
use Tk;
34
use Tk::widgets qw(LabFrame Balloon Label Entry Pane Button Dialog DialogBox Checkbutton CompleteEntry NoteBook StatusBar FIJISettingsCanvas);
35
use Tk::FIJIModalDialog;
36
use Tk::FIJINetSelection;
Stefan Tauner's avatar
Stefan Tauner committed
37
use Tk::FIJIUtils;
38

39
40
use constant RESOURCES_REGS_LOWER => 0.1;
use constant RESOURCES_LUTS_LOWER => 0.1;
Christian Fibich's avatar
Christian Fibich committed
41
use constant RESOURCES_TEXT       => "Resource factors are relative to the FIJI default configuration.\n" . "The default configuration can be obtained by starting FIJI Setup without a .cfg file";
42

43
44
45
46
47
48
49
50
51
52
53
# Test::Deep::NoTest exports Test::Deep which exports
# an undocumented blessed() which clashes with Scalar::Util's blessed().
# see http://stackoverflow.com/a/2837016
BEGIN {
    require Test::Deep;
    @Test::Deep::EXPORT = grep { $_ ne 'blessed' } @Test::Deep::EXPORT;
}

use Test::Deep::NoTest;
use Clone qw(clone);

54
use File::Spec qw (file_name_is_absolute abs2rel splitpath catpath);
55
56
57
use base qw(Tk::Frame);

use FIJI qw(:all);
58
use FIJI::Netlist;
59

60
Construct Tk::Widget 'FIJISettingsViewer';
61

Christian Fibich's avatar
Christian Fibich committed
62

Christian Fibich's avatar
Christian Fibich committed
63
64
65
## @var $widget_background stores the default background of entry widgets
# this is needed under Linux, because the default background retrievable by
# cget() is different from the actual default background
Stefan Tauner's avatar
Stefan Tauner committed
66
my $widget_background;
67
my $widget_ro_background;
68

69
70
71
72
# Remember if the user does not want to see the information message about
# automatic driver selection for nets with a single driver.
my $show_single_driver_info = 1;

73
sub ClassInit {
Christian Fibich's avatar
Christian Fibich committed
74
    my ($class, $mw) = @_;
75
76
77
78
    $class->SUPER::ClassInit($mw);

    my $self = bless {}, $class;
    return $self;
79
80
81
}

sub Populate {
82
    my $logger = get_logger("");
Christian Fibich's avatar
Christian Fibich committed
83
    my ($self, $args) = @_;
84
    my $settings = delete $args->{'-settings'};
Christian Fibich's avatar
Christian Fibich committed
85
    $self->{'changes_callback'} = delete $args->{'-changes_callback'};
86

87
    my $lib_path = delete $args->{'-lib_path'};
88

Christian Fibich's avatar
Christian Fibich committed
89
    if (!defined($settings) || !blessed($settings) || !$settings->isa("FIJI::Settings")) {
90
91
92
        $logger->error("Given settings are not of type FIJI::Settings. No way to report this back from the constructor...");
    } else {
        $self->{'settings'} = $settings;
Christian Fibich's avatar
Christian Fibich committed
93
        if (ref($self->{'settings'}->{'fius'}) ne 'ARRAY') {
94
95
96
            $logger->debug("Adding empty fius array to settings reference.");
            $self->{'settings'}->{'fius'} = [];
        }
97
98
        $self->{'original_settings'} = clone($settings);
        $self->{'original_settings'}->{'fius'} = clone($settings->{'fius'});
99
100

        # tk:trace for canvas update
Christian Fibich's avatar
Christian Fibich committed
101
102
        $self->traceVariable($self->{'settings'}->{'design'}, 'w' => [\&_update_canvas, $self]);
        $self->traceVariable($self->{'settings'}->{'fius'},   'w' => [\&_update_canvas, $self]);
103

104
105
    }

106
107
    $self->{'settings_validation_results'} = {};

Christian Fibich's avatar
Christian Fibich committed
108
    # @FIXME: add an option to store a CODE reference that is called when any field is invalid
109
    $self->{'lfsr_poly_choices'} = [];
110
111
112
    $self->SUPER::Populate($args);
    $self->_populate_widget($self);
    $self->ConfigSpecs(
Christian Fibich's avatar
Christian Fibich committed
113
114
115
        -netlist   => [qw/METHOD netlist    Netlist/,   undef],
        -settings  => [qw/METHOD settings   Settings/,  undef],
        -resources => [qw/METHOD resources  Resources/, undef],
116
117
118
    );
    $self->update();
}
119

120
sub netlist {
121
    my $logger = get_logger("");
Christian Fibich's avatar
Christian Fibich committed
122
123
124
    my ($self, $netlist) = @_;
    if (defined($netlist)) {
        if (ref($netlist) ne 'FIJI::Netlist') {
125
126
127
            $logger->error("Ignoring invalid Netlist");
            return undef;
        }
128

129
        my $nets = $netlist->get_nets();
130

Christian Fibich's avatar
Christian Fibich committed
131
        if (ref($nets) ne 'ARRAY') {
132
            $logger->error("Ignoring invalid nets array");
133
134
            return undef;
        }
135
136
137
138
139

        my $old_netlist = $self->{'netlist'};
        my $old_nets    = $self->{'nets'};

        # generates a list of all nets with full paths from the nets hashref
140
        my @n = map { $_->{'path'} . FIJI::Netlist::HIERSEP . $_->{'name'} } @{$nets};
141
142
143
        $self->{'nets'}    = \@n;
        $self->{'netlist'} = $netlist;
        $self->update();
144
    }
145
    return $self->{'netlist'};
146
147
}

148
sub settings {
149
    my $logger = get_logger("");
Christian Fibich's avatar
Christian Fibich committed
150
151
152
    my ($self, $settings) = @_;
    if (defined($settings)) {
        if (!blessed($settings) || !$settings->isa("FIJI::Settings")) {
153
154
155
156
            $logger->error("Given settings are not of type FIJI::Settings.");
            return undef;
        }
        my $old_settings = $self->{'settings'};
157
158
        $self->{'settings'}                    = $settings;
        $self->{'original_settings'}           = clone($settings);
159
        $self->{'original_settings'}->{'fius'} = clone($settings->{'fius'});
160
161

        # tk:trace for canvas update
Christian Fibich's avatar
Christian Fibich committed
162
163
        $self->traceVariable($self->{'settings'}->{'design'}, 'w' => [\&_update_canvas, $self]);
        $self->traceVariable($self->{'settings'}->{'fius'},   'w' => [\&_update_canvas, $self]);
164
        $self->update();
165
    }
166
    return $self->{'settings'};
167
168
}

169
sub resources {
Christian Fibich's avatar
Christian Fibich committed
170
    my ($self, $resources) = @_;
171
172
173
174
175
    if (defined($resources)) {
        $self->{'resources'} = $resources;
        $self->update();
    }
    return $self->{'resources'};
176
177
}

178
179
180
181
## @method update()
# @brief redraws the widget on fundamental changes
#
sub update {
182
    my $self   = shift;
183
    my $logger = get_logger("");
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199

    #################
    # design panels #
    #################

    # Ugly hack to retrieve the design constants widgets.
    # Alternatively to below one could store the respective widgets separately.
    # To limit the complexity elsewhere we jump though a few hoops here.
    # 1. fetch the widgets comprising the GUI for the design constants
    # 2. loop over the tuples that represent one constant each
    # 3. fetch the internal constant name for the ini_name (stored in the first label)
    # 4. set the reference to the value of that name within the current settings instance
    #    as textvariable of the respective widget.

    my @design_widgets;

Christian Fibich's avatar
Christian Fibich committed
200
    foreach my $f (@{$self->{'pages_design'}}) {
201
202
        my @children = @{$f->children};
        push @design_widgets, @children[1..$#children]; # Ignore headline label
203
    }
204

205
    my $const_cnt             = @design_widgets;
206
    my $dut_port_choices = defined($self->{'netlist'}) ? $self->{'netlist'}->get_toplevel_port_names("i") : [];
207

208
    # Update widgets' values depending on their type
Christian Fibich's avatar
Christian Fibich committed
209
    for (my $i = 0 ; $i < $const_cnt ; $i += 3) {
210
211

        # The order of the widgets depends on their *construction* time(!)
212
        my ($namew, $unitw, $val_w) = @design_widgets[$i .. $i + 3];
213
214
215
216
        my $name = $namew->{'fiji_id'};

        # get DESIGNMAP key from stored INI Field name
        my $k = FIJI::ini2constkey($name);
Christian Fibich's avatar
Christian Fibich committed
217
        if (!defined($k)) {
218
219
            my $msg = "Could not find FIJI definition for constant named \"$name\"";
            $logger->error($msg);
220

221
222
            my $error_dialog = $self->MainWindow->FIJIModalDialog(
                -image       => Tk::FIJIUtils::error_image($self->MainWindow),
223
                -text        => 'Something went horribly wrong!',
224
225
                -wraplength  => $self->MainWindow->screenwidth,
                -title       => 'Error',
226
            );
227

228
            $error_dialog->Show();
229
230
231
232
            return;
        }

        $logger->trace("Connect widget ($name) with new settings instance hash ($k)");
233
234
235
        my $val_ref = \$self->{'settings'}->{'design'}->{$k};
        my $type    = DESIGNMAP->{$k}->{'type'};
        $val_ref    = \(sprintf("0x%x", $$val_ref)) if ($type eq 'hexadecimal' || $type eq 'lfsrpoly');
236

237
238
        if (ref($val_w) eq 'Tk::CompleteEntry') {
            # Update CompleteEntry Fields with the new choices if defined
239
            if ($type eq 'dut_port') {
240
                $val_w->configure('-choices' => $dut_port_choices,);
241
            }
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
            $val_w->configure('-textvariable' => $val_ref);
        } elsif (ref($val_w) eq 'Tk::Checkbutton') {

            # Set fields depending on checkbuttons, check if checkbutton forbids another
            $val_w->configure('-variable' => $val_ref);
        } elsif (ref($val_w) eq 'Tk::Optionmenu') {
            $val_w->configure('-textvariable' => $val_ref);
        } elsif (ref($val_w) eq 'Tk::Frame') {
            # Tk::Frames need a little extra work, because the design widget is a child widget
            if ($type eq 'dir' || $type eq 'file') {
                # If the frame is a 'dir' type Frame, it contains an "open" button as child 0
                # and a readonly entry field for the path as child 1
                (($val_w->children)[1])->configure('-text' => $$val_ref);
            } elsif ($type eq 'net') {
                my $entry =  ($val_w->children)[1];
                $entry->configure('-textvariable' => $val_ref);
            }
        } else {
            $val_w->configure('-textvariable' => $val_ref);
261
        }
262
263
264
265
266
267
268
269
270
271
272
    }

    # Validate the new settings
    for (my $i = 0 ; $i < $const_cnt ; $i += 3) {

        # The order of the widgets depends on their *construction* time(!)
        my ($namew, $unitw, $val_w) = @design_widgets[$i .. $i + 3];
        my $name = $namew->{'fiji_id'};
        my $k = FIJI::ini2constkey($name);

        my $type    = DESIGNMAP->{$k}->{'type'};
273
274

        # Update widgets depending on their type
275
        # FIXME: use isa() instead?
276
        if (ref($val_w) eq 'Tk::Checkbutton') {
277

278
            # Check if checkbutton forbids another
Christian Fibich's avatar
Christian Fibich committed
279
            if (defined($self->{'depends'}->{$k}) && defined($self->{'forbidden_by'}->{$k})) {
280
                $val_w->configure('-command' => [\&_set_fields_by_button, $self, $val_w, $self->{'depends'}->{$k}, $self->{'forbidden_by'}->{$k}]);
Christian Fibich's avatar
Christian Fibich committed
281
            } elsif (defined($self->{'depends'}->{$k})) {
282
                $val_w->configure('-command' => [\&_set_fields_by_button, $self, $val_w, $self->{'depends'}->{$k}, []]);
Christian Fibich's avatar
Christian Fibich committed
283
            } elsif (defined($self->{'forbidden_by'}->{$k})) {
284
                $val_w->configure('-command' => [\&_set_fields_by_button, $self, $val_w, [], $self->{'forbidden_by'}->{$k}]);
285
            }
286
287
288
289
            _set_fields_by_button($self, $val_w, $self->{'depends'}->{$k}, $self->{'forbidden_by'}->{$k});
        } elsif (ref($val_w) eq 'Tk::Frame') {
            if ($type eq 'net') {
                my $entry =  ($val_w->children)[1];
290
                $entry->validate();
291
292
            }
        } else {
293
            my $valid = $val_w->validate() if (ref($val_w) ne 'Tk::Optionmenu');
294
        }
295
    }
296
297
298
299
300

    ##############
    # fius panel #
    ##############

Christian Fibich's avatar
Christian Fibich committed
301
    my $parent = $self->{'fr_fius'}->parent();
302
303
    my $fiu_displaygroup = DISPLAYGROUPS_FIU_KEY;
    undef($self->{'highlit_widgets'}->{$fiu_displaygroup});
Christian Fibich's avatar
Christian Fibich committed
304
305
306
    $parent->packForget();            # This and the next line would be redundant if
    $self->{'fr_fius'}->destroy();    # the $parent->destroy() call would work.
    $self->_add_fiu_frame($parent->parent());
307
308

    # The code line below creates a segfault. It should delete all children
Christian Fibich's avatar
Christian Fibich committed
309
    # of the parent frame of self->{'fr_fius'}.
310
    # $parent->destroy();
Christian Fibich's avatar
Christian Fibich committed
311
    # @FIXME: Without this we have an obvious memory leak
312
313
314

    # An alternative solution is apparently to start destroying higher up
    # in the stack. This does not cause a segfault (but some more flickering).
Christian Fibich's avatar
Christian Fibich committed
315
316
    #             self->{'fr_fius'}<-frame   <-pane    <-frame   <-frame1  <-border  <-labframe1<-self
    # my $parent = $self->{'fr_fius'}->parent()->parent()->parent()->parent()->parent()->parent();
317
318
319
320
321
322
323
324
325
326
    # $self->_add_fiu_panel($parent->parent());
    # $parent->destroy();

    # This recreates the entire FIU list:

    my $i       = 1;
    my $hdr_row = 0;

    # Add fields for each FIU
    my $fiu_cnt = $self->_fiu_cnt();
Christian Fibich's avatar
Christian Fibich committed
327
328
    for (my $i = 0 ; $i < $fiu_cnt ; $i++) {
        my $fiu_ref = @{$self->{'settings'}->{'fius'}}[$i];
329
        $self->_add_fiu_widgets($fiu_ref, $i);
330
    }
331

Christian Fibich's avatar
Christian Fibich committed
332
    $self->{'settings_canvas'}->configure(-settings_ref => \($self->{'settings'})) if defined $self->{'settings_canvas'};
333

334
335
336
337
    # Ensure correct behavior even without any FIUs (e.g., if we just deleted the last FIU)
    if ($fiu_cnt == 0) {
        $self->_update_resources();
    }
338
    return 1;
339
340
}

341
342
## @method _update_resources()
# Calculates resource estimate and updates the "Status Bar"
343
#
344
345
sub _update_resources {
    my $self = shift;
Christian Fibich's avatar
Christian Fibich committed
346
    my $rh   = FIJI::Settings::estimate_resources($self->{'settings'});
Christian Fibich's avatar
Christian Fibich committed
347
348
    $rh->{'regs'}     = "< " . RESOURCES_REGS_LOWER if ($rh->{'regs'} < RESOURCES_REGS_LOWER);
    $rh->{'lut_calc'} = "< " . RESOURCES_LUTS_LOWER if ($rh->{'lut_calc'} < RESOURCES_LUTS_LOWER);
349
    $self->{'resources'} = "Virtual resource factors: " . $rh->{'regs'} . " registers, " . $rh->{'lut_calc'} . " combinational resources";
350
}
351

352
353
354
355
## @method _switchtab(nb, inc)
# Raises the tab $inc frames left ($inc < 0) or right ($inc > 0) of the
# currently selected tab of $nb
#
356
sub _switchtab {
Christian Fibich's avatar
Christian Fibich committed
357
    my ($dummy, $nb, $inc) = @_;
358
359
    my @pages        = $nb->pages();
    my $current_page = $nb->raised();
Christian Fibich's avatar
Christian Fibich committed
360
361
    my ($index) = grep { $pages[$_] eq $current_page } 0 .. (@pages - 1);
    my $next_page = $pages[$index + $inc];
362

Christian Fibich's avatar
Christian Fibich committed
363
364
    $nb->raise($next_page) if (($inc > 0 && defined $next_page)
        || ($inc < 0 && $index > 0));
365
366
}

367
368
369
## @method _populate_widget(self, fr)
# Creates, aranges and binds all widgets
#
370
sub _populate_widget {
371
    my $logger = get_logger("");
Christian Fibich's avatar
Christian Fibich committed
372
    my ($self, $fr) = @_;
373
374

    # Add and init Buttons to bottom frame for "Wizard-Like" navigation
Christian Fibich's avatar
Christian Fibich committed
375
    $self->{'nb'} = $fr->NoteBook()->pack(
376
377
378
        -expand => 1,
        -fill   => 'both'
    );
Christian Fibich's avatar
Christian Fibich committed
379
    my $bf = $fr->Frame(-borderwidth => 1, -relief => 'raised',)->pack(-anchor => "nw", -side => "top", -fill => 'x');
380

381
382
    # create Tk::Balloon instance for tooltips
    my $balloon = $fr->Balloon();
383
    $self->{'balloon'} = $balloon;
384
385

    # Add resources field to bottom frame
Christian Fibich's avatar
Christian Fibich committed
386
    my $rl = $bf->Label(-textvariable => \$self->{'resources'});
387
    $balloon->attach($rl, -balloonposition => 'mouse', -msg => RESOURCES_TEXT);
388
    $rl->pack(-side => "left");
389

390
391
392
393
394
    # Switch tabs by buttons in "status bar"
    my $bb = $bf->Button(
        -text    => "< Back",
        -command => [\&_switchtab, undef, $self->{'nb'}, -1],
    );
395
396
397
398
399
400
    $balloon->attach(
        $bb,
        -balloonposition => 'mouse',
        -msg             => "Previous Tab (Alt+Left)",
    );

401
402
403
404
    my $bn = $bf->Button(
        -text    => "Next >",
        -command => [\&_switchtab, undef, $self->{'nb'}, 1],
    );
405
406
407
408
409
    $balloon->attach(
        $bn,
        -balloonposition => 'mouse',
        -msg             => "Next Tab (Alt+Right)",
    );
410
411
412

    $bn->pack(-side => "right");
    $bb->pack(-side => "right");
413

Christian Fibich's avatar
Christian Fibich committed
414
    $self->{'pages_design'} = [];
415

Christian Fibich's avatar
Christian Fibich committed
416
    my $dm_ref      = DESIGNMAP;                                         # Work around Perl limitation: use constant <hash> and dereferencing does not play well together
417
    my $dg_ref      = DISPLAYGROUPS;
Christian Fibich's avatar
Christian Fibich committed
418
    my $net_choices = defined($self->{'nets'}) ? $self->{'nets'} : [];
419
    my $entry;
420

421
422
423
    # Allow to switch tabs by pressing ALT+left and ALT+right
    $self->{'nb'}->parent->parent->bind('<Alt-Key-Left>'  => [\&_switchtab, $self->{'nb'}, -1]);
    $self->{'nb'}->parent->parent->bind('<Alt-Key-Right>' => [\&_switchtab, $self->{'nb'}, 1]);
424

425
    # create canvas widget which draws a block diagram of the current settings
426
    $self->{'settings_canvas'} = $fr->FIJISettingsCanvas(-relief => "solid", -borderwidth => "1", -takefocus => "0", -settings_ref => \($self->{'settings'}))->pack(-anchor => "nw", -side => "top", -fill => "x");
427

428
    # Loop through tab descriptions ('display groups') and create the tabs
Christian Fibich's avatar
Christian Fibich committed
429
    foreach my $displaygroup (sort { DISPLAYGROUPS->{$a}->{'order'} <=> DISPLAYGROUPS->{$b}->{'order'} } keys(%{$dg_ref})) {
430

431
432
433
        # The FIU panel is generated separately
        next if $displaygroup eq DISPLAYGROUPS_FIU_KEY;

434
        # filter out just the Settings Fields in this Display group
Christian Fibich's avatar
Christian Fibich committed
435
        my @keys = map { my $foo = $_; (defined DESIGNMAP->{$foo}->{'group'} && DESIGNMAP->{$foo}->{'group'} eq $displaygroup) ? ($_) : () } keys(%{$dm_ref});
Christian Fibich's avatar
Christian Fibich committed
436

Christian Fibich's avatar
Christian Fibich committed
437
        if (@keys == 0) { next }
438

439
440
        my $title = DISPLAYGROUPS->{$displaygroup}->{'title'};
        $title .= ": " . DISPLAYGROUPS->{$displaygroup}->{'subtitle'} if DISPLAYGROUPS->{$displaygroup}->{'subtitle'} ne "";
441

442
        # add new notebook page
Christian Fibich's avatar
Christian Fibich committed
443
        my $page = $self->{'nb'}->add(
444
            $displaygroup,
445
446
447
448
            -anchor   => "ne",
            -label    => DISPLAYGROUPS->{$displaygroup}->{'title'},
            # FIXME: Menubar overrides the ALT-(Key) bindings, how can we propagate the events to the notebook?
            #-underline => 0,
449
        );
450

451
452
        # add frame for configuration widgets
        my $config_frame = $page->Frame();
453

454
455
456
457
458
459
460
461
462
463
464
        $config_frame->Label(-text => DISPLAYGROUPS->{$displaygroup}->{'description'},
            '-justify' => 'center',
            '-pady'    => "15",
            '-font'    => [ '-size' => 11 ],
        )->grid(
            '-row'        => 0,
            '-column'     => 0,
            '-sticky'     => 'nsew',
            '-columnspan' => 3,
        );

465
        # if the tab is changed, reparent the canvas widget
Christian Fibich's avatar
Christian Fibich committed
466
        $self->{'nb'}->pageconfigure(
467
468
            $displaygroup,
            -raisecmd => sub {
Christian Fibich's avatar
Christian Fibich committed
469
                $self->{'settings_canvas'}->packForget() if defined $self->{'settings_canvas'};
470
                $self->{'settings_canvas'}->pack(-anchor => "nw", -side => "top", -padx => 5, -pady => 15, -in => $page);
Christian Fibich's avatar
Christian Fibich committed
471
                $self->{'settings_canvas'}->update();
472
                $config_frame->focus;
473
474
            }
        );
475

476
        # let entries eat up all the remaining space
Christian Fibich's avatar
Christian Fibich committed
477
        $config_frame->gridColumnconfigure(2, -weight => 1);
478

479
        # add tooltip to the config frame
Christian Fibich's avatar
Christian Fibich committed
480
        if (defined DISPLAYGROUPS->{$displaygroup}->{'description'}) {
481
482
483
484
485
486
            $balloon->attach(
                $config_frame,
                -balloonposition => 'mouse',
                -msg             => DISPLAYGROUPS->{$displaygroup}->{'description'}
            );
        }
487

488
        my $row = 1;
489
        # add matching widgets for all values in this displaygroup
Christian Fibich's avatar
Christian Fibich committed
490
        foreach my $k (sort { DESIGNMAP->{$a}->{'order'} <=> DESIGNMAP->{$b}->{'order'} } @keys) {
491

492
493
            my $tooltip;

494
495
496
            # label
            my $label = $config_frame->Label(
                '-text'    => DESIGNMAP->{$k}->{'description'},
497
                '-justify' => 'left',
498
            );
499
500
501
502
            $label->{'fiji_id'} = DESIGNMAP->{$k}->{'ini_name'};
            $label->grid(
                -row      => $row,
                -column   => 0,
503
                '-sticky' => 'w',
504
            );
Christian Fibich's avatar
Christian Fibich committed
505

506
            # unit
Christian Fibich's avatar
Christian Fibich committed
507
            my $unit = $config_frame->Label('-text' => DESIGNMAP->{$k}->{'unit'},);
508
509
510
511
512
513
            $unit->grid(
                -row      => $row,
                -column   => 1,
                '-ipadx'  => ".5c",
                '-sticky' => 'w',
            );
514

515
516
            # entry
            my $type = DESIGNMAP->{$k}->{'type'};
Christian Fibich's avatar
Christian Fibich committed
517
            if (defined($type) && $type eq 'net') {
518
519

                # entry for NET
520
                $entry = $config_frame->Frame();
521
522
                my $select_button = $entry->Button(-text    => "Select");
                my $net_roentry = $entry->Entry();
523

524
525
                $net_roentry->{'displaygroup'} = $displaygroup;
                $net_roentry->{'key'}          = $k;
526

527
528
529
530
531
                $net_roentry->configure(
                              '-state' => "readonly",
                              '-validatecommand' => [\&_validate_design_entry, $self, 1, $net_roentry, $k],
                              '-textvariable' => \$self->{'settings'}->{'design'}->{$k},
                              '-takefocus' => 0);
532

533
                $select_button->configure(
534
                    -command => sub {
535
                        my $netnames   = [];
536
537
                        my $old_value = $self->{'settings'}->{'design'}->{$k};
                        # only display old value if not empty
538
                        push @{$netnames}, $old_value if (defined $old_value && !($old_value =~ /^\s*$/));
539

540
                        my $rv = $self->_select_net_dialog($netnames,"Select Net for $k");
541
                        if (defined $rv) {
542
543
544
                            Tk::FIJIUtils::show_warning($self, $rv);
                        } elsif ($old_value ne @{$netnames}[0]) {
                            $self->{'settings'}->{'design'}->{$k} = defined(@{$netnames}[0]) ? @{$netnames}[0] : "";
545
                            $self->update;
546
547
548
                            $self->_check_change();
                        } else {
                            $logger->debug("Net selection was not changed for $k");
549
550
                        }
                    }
551
                );
552
553
                $select_button->grid(-row => 0, -column => 1, -sticky => "ew");
                $net_roentry->grid(-row => 0, -column => 0, -sticky => "ew");
554

555
                $entry->gridColumnconfigure(0, -weight => 1);
556
557
558
559
560
                $entry->grid(
                    -row      => $row,
                    -column   => 2,
                    '-sticky' => 'ew'
                );
561

Christian Fibich's avatar
Christian Fibich committed
562
            } elsif (defined($type) && $type eq 'external_port') {
Christian Fibich's avatar
Christian Fibich committed
563

Christian Fibich's avatar
Christian Fibich committed
564
565
566
567
                # entry for an external port name
                $entry = $config_frame->Entry();
                $entry->configure(
                    '-validate'        => 'key',
568
                    '-validatecommand' => [\&_validate_design_entry, $self, 1, $entry, $k],
Christian Fibich's avatar
Christian Fibich committed
569
570
571
572
573
574
                );
                $entry->grid(
                    -row      => $row,
                    -column   => 2,
                    '-sticky' => 'ew'
                );
575

576
            } elsif (defined($type) && $type eq 'dut_port') {
Christian Fibich's avatar
Christian Fibich committed
577

Christian Fibich's avatar
Christian Fibich committed
578
                # entry for a DUT port name
579
580
581
                $entry = $config_frame->CompleteEntry();
                $entry->configure(
                    '-validate'        => 'key',
582
                    '-validatecommand' => [\&_validate_design_entry, $self, 1, $entry, $k],
583
584
585
586
587
588
                );
                $entry->grid(
                    -row      => $row,
                    -column   => 2,
                    '-sticky' => 'ew'
                );
589
            } elsif (defined($type) && $type eq 'lfsrpoly') {
Christian Fibich's avatar
Christian Fibich committed
590

591
592
593
                # entry for the LFSR poly
                $entry = $config_frame->CompleteEntry();
                $entry->configure(
594
595
                    '-validate'        => 'key',
                    '-validatecommand' => [\&_validate_design_entry, $self, 1, $entry, $k],
596
597
598
599
600
601
                );
                $entry->grid(
                    -row      => $row,
                    -column   => 2,
                    '-sticky' => 'ew'
                );
602
603
604
605
606
607
                my $lfsr_width = $self->{'settings'}->{'design'}->{'LFSR_WIDTH'};
                my $lpc = LFSR_POLY_CHOICES;
                my $c   = $lpc->{$lfsr_width};
                my $tmp =  FIUMAP->{'FIU_LFSR_MASK'}->{'help'} . " [" . FIUMAP->{'FIU_LFSR_MASK'}->{'ini_name'} . "]\nPossible maximum polynomials for a LFSR with a width of ".$lfsr_width.": " . join(",", @{$c});
                $tooltip = \$tmp;
                $entry->{'LFSR_tooltip'} = \$tmp;
Christian Fibich's avatar
Christian Fibich committed
608
            } elsif (defined($type) && $type eq 'boolean') {
609
610

                # checkbutton for values which can only be "enabled" or "disabled"
Christian Fibich's avatar
Christian Fibich committed
611
                $entry = $config_frame->Checkbutton('-justify' => 'left',);
612
613
614
615
616
                $entry->grid(
                    -row      => $row,
                    -column   => 2,
                    '-sticky' => 'w'
                );
Christian Fibich's avatar
Christian Fibich committed
617
            } elsif (defined($type) && ($type eq 'bit' || $type eq 'dropdown')) {
618
619
620
621
622

                # dropdown for bit levels which can be "0" or "1" and have no 'yes/no' or 'truth' value
                $entry = $config_frame->Optionmenu(
                    '-options'      => DESIGNMAP->{$k}->{'values'},
                    '-textvariable' => \$self->{'settings'}->{'design'}->{$k},
Christian Fibich's avatar
Christian Fibich committed
623
624
625
626

                    #                    '-width'        =>
                    '-anchor'  => 'w',
                    '-justify' => 'left'
627
628
629
630
                );
                $entry->grid(
                    -row      => $row,
                    -column   => 2,
631
                    '-sticky' => 'ew',
632
                );
Christian Fibich's avatar
Christian Fibich committed
633
634
            } elsif (defined($type) && ($type eq 'dir' || $type eq 'file')) {

635
                my $dialog_type = ($type eq 'dir') ? 'dir' : 'save';
636
637
638
639
640
641
642

                # complex widget (frame) for selecting directories
                $entry = $config_frame->Frame();
                my $btn = $entry->Button(
                    -justify => "left",
                    -text    => "Open",
                    -command => sub {
Stefan Tauner's avatar
Stefan Tauner committed
643
                        my $fb = $entry->FBox(
Christian Fibich's avatar
Christian Fibich committed
644
645
                            -type  => $dialog_type,
                            -title => "Select " . lc(DESIGNMAP->{$k}->{'description'}),
Stefan Tauner's avatar
Stefan Tauner committed
646
647
648
                        );
                        Tk::FIJIUtils::set_icon($fb);
                        my $val = $fb->Show();
Christian Fibich's avatar
Christian Fibich committed
649
                        if (defined $val) {
650
                            my ($basevolume, $basedirs, $file) = File::Spec->splitpath($self->{'settings'}->{'filename'});
651
                            my $nv = File::Spec->abs2rel($val, File::Spec->catpath($basevolume, $basedirs, ""));
652
653
                            $logger->info("Setting $k to relative path $nv") if (File::Spec->file_name_is_absolute($val));
                            $self->{'settings'}->{'design'}->{$k} = $nv;
654
655
656
                            $self->update;
                        }
                    }
Christian Fibich's avatar
Christian Fibich committed
657
658
659
660
661
                  )->grid(
                    -row    => 0,
                    -column => 0,
                    -sticky => "w"
                  );
662
                $entry->Entry(-state => "readonly", -takefocus => 0, -textvariable => \$self->{'settings'}->{'design'}->{$k})->grid(-row => 0, -column => 1, -sticky => "ew");
Christian Fibich's avatar
Christian Fibich committed
663
                $entry->gridColumnconfigure(1, -weight => 1);
664
665
666
667
668
669
                $entry->grid(
                    -row      => $row,
                    -column   => 2,
                    '-sticky' => 'ew'
                );
            } else {
670

671
672
673
674
                # a simple text entry for all other types
                $entry = $config_frame->Entry();
                $entry->configure(
                    '-validate'        => 'key',
675
                    '-validatecommand' => [\&_validate_design_entry, $self, 1, $entry, $k],
676
677
678
679
680
681
682
                );
                $entry->grid(
                    -row      => $row,
                    -column   => 2,
                    '-sticky' => 'ew'
                );
            }
683

684
            # set dependencies (widgets which depend on a single config value to be true or false)
Christian Fibich's avatar
Christian Fibich committed
685
686
            if (defined(DESIGNMAP->{$k}->{'depends_on'})) {
                push @{$self->{'depends'}->{DESIGNMAP->{$k}->{'depends_on'}}}, $entry;
687
            }
688

689
            # set exclusions (widgets which mutually exclude each other)
Christian Fibich's avatar
Christian Fibich committed
690
691
            if (defined(DESIGNMAP->{$k}->{'forbidden_by'})) {
                push @{$self->{'forbidden_by'}->{DESIGNMAP->{$k}->{'forbidden_by'}}}, $entry;
692
            }
693

694
            # add tooltip to widget and its label
Christian Fibich's avatar
Christian Fibich committed
695
            if (defined DESIGNMAP->{$k}->{'help'}) {
696
697
                $self->_attach_help_balloon($entry, DESIGNMAP, $k, $tooltip);
                $self->_attach_help_balloon($label, DESIGNMAP, $k, $tooltip);
698
            }
699

700
            Tk::FIJIUtils::entry_rebind($entry);
701

702
703
            # Widget description is needed for widget-based error messages such as
            # "Forbids"
704
705
706
            $entry->{'description'}  = DESIGNMAP->{$k}->{'description'};
            $entry->{'displaygroup'} = $displaygroup;
            $entry->{'key'}          = $k;
707
708
            $row++;
        }
709
        $config_frame->pack(-anchor => "nw", -side => "right", -fill => "x", -expand => 1, -padx => 5, -pady => 5);
710

Christian Fibich's avatar
Christian Fibich committed
711
        push @{$self->{'pages_design'}}, $config_frame;
712
    }
713

714
    $widget_background = $entry->cget('-bg');
715

716
717
718
719
    ##############
    # fius panel #
    ##############

Christian Fibich's avatar
Christian Fibich committed
720
    $self->{'page_fius'} = $self->{'nb'}->add(
721
        DISPLAYGROUPS_FIU_KEY,
722
        -label     => DISPLAYGROUPS->{DISPLAYGROUPS_FIU_KEY()}->{'title'},
723
724
       # FIXME: Menubar overrides the ALT-(Key) bindings, how can we propagate the events to the notebook?
       #-underline => 0
725
726
727
728
729
    );

    # add frame for Block Diagram / Description

    # add frame for configuration widgets
Christian Fibich's avatar
Christian Fibich committed
730
    my $config_frame = $self->{'page_fius'}->Frame();
731
732
733
734
735
736
737
738
    $config_frame->Label(-text => DISPLAYGROUPS->{DISPLAYGROUPS_FIU_KEY()}->{'description'},
        '-justify' => 'center',
        '-pady'    => "15",
        '-font'    => [ '-size' => 11 ],
    )->pack(
        '-fill'     => 'x',
    );
    $config_frame->pack(-anchor => "nw", -side => "right", -fill => "both", -expand => 1, -padx => 5, -pady => 5);
739
740
741

    # if the tab is changed, delete the existing canvas
    # and create a new one in the tab currently shown.
Christian Fibich's avatar
Christian Fibich committed
742
    $self->{'nb'}->pageconfigure(
743
        DISPLAYGROUPS_FIU_KEY,
744
        -raisecmd => sub {
Christian Fibich's avatar
Christian Fibich committed
745
            $self->{'settings_canvas'}->packForget() if defined $self->{'settings_canvas'};
746
            $self->{'settings_canvas'}->pack(-anchor => "nw", -side => "left", -padx => 5, -pady => 15, -in => $self->{'page_fius'});
Christian Fibich's avatar
Christian Fibich committed
747
            $self->{'settings_canvas'}->update();
748
            $config_frame->focus;
749
750
751
        }
    );
    $self->_add_fiu_panel($config_frame);
752

753

754
755
}

756
757
758
# This is the Tk::Trace callback for FIJI::Settings.
# It is needed for updating the Block Diagram whenever the Settings change
sub _update_canvas {
Christian Fibich's avatar
Christian Fibich committed
759
760
    my ($index, $value, $op, $self) = @_;
    $self->{'settings_canvas'}->update() if defined $self->{'settings_canvas'};
761
    $self->_check_change();
762
763
    return $value;
}
Stefan Tauner's avatar
Stefan Tauner committed
764

765
sub _add_fiu_panel {
Christian Fibich's avatar
Christian Fibich committed
766
    my ($self, $fr) = @_;
767

768
    my $fr_fius_main = $fr;
769

770
771
772
    my $fr_fius_buttons = $fr_fius_main->Frame()->pack('-side' => 'top', '-anchor' => 'nw');

    $fr_fius_buttons->Button(
773
        -text    => 'Append empty FIU',
774
        -command => [\&append_fiu, $self],
775
      )->pack(
776
777
778
779
780
        '-side'   => 'left',
        '-anchor' => 'nw',
      );

    $fr_fius_buttons->Button(
781
782
        -text    => 'Append FIUs for multiple nets',
        -command => [\&_add_fius, $self, 1],
783
784
      )->pack(
        '-side'   => 'left',
785
786
787
        '-anchor' => 'nw',
      );

788
    # Make the grid containing the fius scrollable
789
790
791
792
793
    my $fr_fius_scroll = $fr_fius_main->Scrolled(
        'Pane',
        '-scrollbars' => 'osre',
        '-sticky'     => 'nwse',
    );
794

795
    Tk::FIJIUtils::bind_mousewheel($self->MainWindow,$fr_fius_scroll);
796

797
798
799
800
801
802
803
    $fr_fius_scroll->pack(
        '-expand' => 1,
        '-fill'   => 'both',
        '-anchor' => 'nw',
        '-side'   => 'top',
    );
    $self->_add_fiu_frame($fr_fius_scroll);
804
805
}

806
sub _add_fiu_frame {
Christian Fibich's avatar
Christian Fibich committed
807
808
    my ($self, $parent) = @_;
    $self->{'fr_fius'} = $parent->Frame()->pack(
809
810
811
812
813
        '-fill'   => 'both',
        '-side'   => 'top',
        '-anchor' => 'nw',
    );
}
814
815

sub _fiu_cnt {
816
817
    my ($self) = @_;
    my $fius = $self->{'settings'}->{'fius'};
Christian Fibich's avatar
Christian Fibich committed
818
    return (defined($fius) && ref($fius) eq 'ARRAY') ? scalar(@{$fius}) : 0;
819
820
}

821
sub append_fiu ($) {
822
823
    my ($self) = @_;
    $self->_add_fiu_widgets();
824
    $self->{'settings_canvas'}->update(); # update Block Diagram
825
826
827
}

sub remove_fiu ($) {
Christian Fibich's avatar
Christian Fibich committed
828
    my ($self, $i) = @_;
829
    $i = 0 if !defined($i);
830
831
832
833
834
835
836
837
838
    splice(@{$self->{'settings'}->{'fius'}}, $i, 1); # actually remove it from the array
    my $fiu_cnt = @{$self->{'settings'}->{'fius'}};
    # Make sure we eliminate this FIU's (index') validation results.
    # They would be overwritten by the update function but when deleting
    # the last FIU its results would remain with no corresponding FIU
    # which could lead to false positive error messages (e.g., on saving).
    for my $name ('FIU_NET_NAME', 'FIU_DRIVER_PATH', 'FIU_LFSR_MASK') {
        delete($self->{'settings_validation_results'}->{"FIU[$fiu_cnt] $name"});
    }