FIJISettingsViewer.pm 72.6 KB
Newer Older
Christian Fibich's avatar
Christian Fibich committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
#-------------------------------------------------------------------------------
#  University of Applied Sciences Technikum Wien
#
#  Department of Embedded Systems
#  http://embsys.technikum-wien.at
#
#  Josef Ressel Center for Verification of Embedded Computing Systems
#  http://vecs.technikum-wien.at
#
#-------------------------------------------------------------------------------
#  Description:
#  FIJI Settings Viewer class
#-------------------------------------------------------------------------------

15
## @file
Christian Fibich's avatar
Christian Fibich committed
16
# @brief Contains class \ref Tk::FIJISettingsViewer
17
18

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

use strict;
use warnings;
24
25
use utf8;

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

35
36
use constant RESOURCES_REGS_LOWER => 0.1;
use constant RESOURCES_LUTS_LOWER => 0.1;
Christian Fibich's avatar
Christian Fibich committed
37
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";
38

39
40
41
42
43
44
45
46
47
48
49
# 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);

50
use File::Spec qw (file_name_is_absolute abs2rel splitpath catpath);
51
52
53
use base qw(Tk::Frame);

use FIJI qw(:all);
54
use FIJI::Netlist;
55

56
Construct Tk::Widget 'FIJISettingsViewer';
57

Christian Fibich's avatar
Christian Fibich committed
58

Christian Fibich's avatar
Christian Fibich committed
59
60
61
## @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
62
my $widget_background;
63
my $widget_ro_background;
64

65
66
67
68
# 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;

69
sub ClassInit {
Christian Fibich's avatar
Christian Fibich committed
70
    my ($class, $mw) = @_;
71
72
73
74
    $class->SUPER::ClassInit($mw);

    my $self = bless {}, $class;
    return $self;
75
76
77
}

sub Populate {
78
    my $logger = get_logger("");
Christian Fibich's avatar
Christian Fibich committed
79
    my ($self, $args) = @_;
80
    my $settings = delete $args->{'-settings'};
Christian Fibich's avatar
Christian Fibich committed
81
    $self->{'changes_callback'} = delete $args->{'-changes_callback'};
82
83
    $self->{'mw'}        = delete $args->{'-mw'};

84
    my $lib_path = delete $args->{'-lib_path'};
85

Christian Fibich's avatar
Christian Fibich committed
86
    if (!defined($settings) || !blessed($settings) || !$settings->isa("FIJI::Settings")) {
87
88
89
        $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
90
        if (ref($self->{'settings'}->{'fius'}) ne 'ARRAY') {
91
92
93
            $logger->debug("Adding empty fius array to settings reference.");
            $self->{'settings'}->{'fius'} = [];
        }
94
95
        $self->{'original_settings'} = clone($settings);
        $self->{'original_settings'}->{'fius'} = clone($settings->{'fius'});
96
97

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

101
102
    }

103
104
    $self->{'settings_validation_results'} = {};

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

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

127
        my $nets = $netlist->get_nets();
128

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

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

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

144
145
        if ($self->{'bad_nets'} ne "") {
            my $msg = "Some nets defined in the specified settings do not match the loaded netlist:\n$self->{'bad_nets'}";
146
            $logger->error($msg);
147

148
149
150
151
152
153
154
            my $warning_dialog = $self->{'mw'}->FIJIModalDialog(
                -image       => Tk::FIJIUtils::alert_image($self->{'mw'}),
                -text        => $msg . "\n" . "Proceed with new netlist nevertheless?",
                -wraplength  => 400,
                -title       => 'Warning',
                -buttons     => [qw/~Yes ~No/],
            );
155

156
            my $rv = $warning_dialog->Show();
157
            if (!defined $rv || $rv eq "No") {
158
159
160
161
162
163
164
165
166
167
                $logger->info("Using original netlist");
                $self->{'nets'}    = $old_nets;
                $self->{'netlist'} = $old_netlist;
                $self->update();
                return undef;
            } else {
                $logger->info("Using new nets nevertheless");
            }
        }
        $self->update();
168
    }
169
    return $self->{'netlist'};
170
171
}

172
sub settings {
173
    my $logger = get_logger("");
Christian Fibich's avatar
Christian Fibich committed
174
175
176
    my ($self, $settings) = @_;
    if (defined($settings)) {
        if (!blessed($settings) || !$settings->isa("FIJI::Settings")) {
177
178
179
180
            $logger->error("Given settings are not of type FIJI::Settings.");
            return undef;
        }
        my $old_settings = $self->{'settings'};
181
182
        $self->{'settings'}                    = $settings;
        $self->{'original_settings'}           = clone($settings);
183
        $self->{'original_settings'}->{'fius'} = clone($settings->{'fius'});
184
185

        # tk:trace for canvas update
Christian Fibich's avatar
Christian Fibich committed
186
187
        $self->traceVariable($self->{'settings'}->{'design'}, 'w' => [\&_update_canvas, $self]);
        $self->traceVariable($self->{'settings'}->{'fius'},   'w' => [\&_update_canvas, $self]);
188
        $self->{'bad_nets'} = "";
189
190
        $self->update();

191
192
        if (defined $self->{'nets'} && $self->{'bad_nets'} ne "") {
            my $msg = "Some nets defined in the specified settings do not match the loaded netlist:\n$self->{'bad_nets'}";
193
            $logger->info($msg);
194

195
196
197
198
199
200
201
            my $warning_dialog = $self->{'mw'}->FIJIModalDialog(
                -image       => Tk::FIJIUtils::alert_image($self->{'mw'}),
                -text        => $msg . "\n" . "Proceed with new netlist nevertheless?",
                -wraplength  => 400,
                -title       => 'Warning',
                -buttons     => [qw/~Yes ~No/],
            );
202

203
            my $rv = $warning_dialog->Show();
204
            if (!defined $rv || $rv eq "No") {
205
                $logger->info("Using original settings");
206
207
                $self->{'settings'}                    = $old_settings;
                $self->{'original_settings'}           = clone($old_settings);
208
                $self->{'original_settings'}->{'fius'} = clone($old_settings->{'fius'});
209
210

                # tk:trace for canvas update
Christian Fibich's avatar
Christian Fibich committed
211
212
                $self->traceVariable($self->{'settings'}->{'design'}, 'w' => [\&_update_canvas, $self]);
                $self->traceVariable($self->{'settings'}->{'fius'},   'w' => [\&_update_canvas, $self]);
213
214
215
216
217
                $self->update();
                return 0;
            } else {
                $logger->info("Using new settings nevertheless");
            }
218
219
        }
    }
220
    return $self->{'settings'};
221
222
}

223
sub resources {
Christian Fibich's avatar
Christian Fibich committed
224
    my ($self, $resources) = @_;
225
226
227
228
229
    if (defined($resources)) {
        $self->{'resources'} = $resources;
        $self->update();
    }
    return $self->{'resources'};
230
231
}

232
233
234
235
## @method update()
# @brief redraws the widget on fundamental changes
#
sub update {
236
    my $self   = shift;
237
    my $logger = get_logger("");
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253

    #################
    # 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
254
255
    foreach my $f (@{$self->{'pages_design'}}) {
        foreach my $c ($f->children) {
256
257
            push @design_widgets, $c;
        }
258
    }
259

260
    my $const_cnt             = @design_widgets;
Christian Fibich's avatar
Christian Fibich committed
261
    my $net_choices           = defined($self->{'nets'}) ? $self->{'nets'} : [];
Christian Fibich's avatar
Christian Fibich committed
262
    my $toplevel_port_choices = defined($self->{'netlist'}) ? $self->{'netlist'}->get_toplevel_port_names("i") : [];
263

Christian Fibich's avatar
Christian Fibich committed
264
    for (my $i = 0 ; $i < $const_cnt ; $i += 3) {
265
266

        # The order of the widgets depends on their *construction* time(!)
Christian Fibich's avatar
Christian Fibich committed
267
        my ($namew, $unitw, $valw) = @design_widgets[$i .. $i + 3];
268
269
270
271
        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
272
        if (!defined($k)) {
273
274
            my $msg = "Could not find FIJI definition for constant named \"$name\"";
            $logger->error($msg);
275

276
277
278
279
280
281
            my $error_dialog = $self->{'mw'}->FIJIModalDialog(
                -image       => Tk::FIJIUtils::error_image($self->{'mw'}),
                -text        => 'Something went horribly wrong!',
                -wraplength  => 200,
                -title       => 'Warning',
            );
282

283
            $error_dialog->Show();
284
285
286
287
            return;
        }

        $logger->trace("Connect widget ($name) with new settings instance hash ($k)");
Christian Fibich's avatar
Christian Fibich committed
288
289
290
291
        my $orig_ref = \$self->{'settings'}->{'design'}->{$k};
        my $type     = DESIGNMAP->{$k}->{'type'};
        my $orig     = $$orig_ref;
        my $val      = defined($type) && ($type eq 'hexadecimal' || $type eq 'lfsrpoly') ? sprintf("0x%x", $orig) : $orig;
292
293
294
295
296
297
        my $autocomplete_choices;

        if (defined $type) {
            if ($type eq 'toplevel_port') {
                $autocomplete_choices = $toplevel_port_choices;
            } elsif ($type eq 'lfsrpoly') {
Christian Fibich's avatar
Christian Fibich committed
298
                $orig_ref = \$val;
299
300
            }
        }
301
302

        # Update widgets depending on their type
303
        # FIXME: use isa() instead?
Christian Fibich's avatar
Christian Fibich committed
304
        if (ref($valw) eq 'Tk::CompleteEntry') {
305

306
            # Update CompleteEntry Fields with the new choices if defined
307
            $valw->configure(
Christian Fibich's avatar
Christian Fibich committed
308
309
310
311
                '-choices' => $autocomplete_choices,
              )
              if defined($autocomplete_choices);
            $valw->configure('-textvariable' => $orig_ref);
312
            my $valid = $valw->validate();
Christian Fibich's avatar
Christian Fibich committed
313
        } elsif (ref($valw) eq 'Tk::Checkbutton') {
314
315

            # Set fields depending on checkbuttons, check if checkbutton forbids another
Christian Fibich's avatar
Christian Fibich committed
316
317
318
319
320
321
322
            $valw->configure('-variable' => $orig_ref);
            if (defined($self->{'depends'}->{$k}) && defined($self->{'forbidden_by'}->{$k})) {
                $valw->configure('-command' => [\&_set_fields_by_button, $self, $valw, $self->{'depends'}->{$k}, $self->{'forbidden_by'}->{$k}]);
            } elsif (defined($self->{'depends'}->{$k})) {
                $valw->configure('-command' => [\&_set_fields_by_button, $self, $valw, $self->{'depends'}->{$k}, []]);
            } elsif (defined($self->{'forbidden_by'}->{$k})) {
                $valw->configure('-command' => [\&_set_fields_by_button, $self, $valw, [], $self->{'forbidden_by'}->{$k}]);
323
            }
Christian Fibich's avatar
Christian Fibich committed
324
325
326
            _set_fields_by_button($self, $valw, $self->{'depends'}->{$k}, $self->{'forbidden_by'}->{$k});
        } elsif (ref($valw) eq 'Tk::Optionmenu') {
            $valw->configure('-textvariable' => $orig_ref);
327
        } elsif (ref($valw) eq 'Tk::Frame' && defined($type)) {
328
329
330
            # Tk::Frames need a little extra work, because the design widget is
            # a child widget.

331
332

            if ($type eq 'dir' || $type eq 'file') {
333
334
                # 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
Christian Fibich's avatar
Christian Fibich committed
335
                (($valw->children)[1])->configure('-text' => (defined $val) ? $val : "");
336
            } elsif ($type eq 'net') {
337
338
339
                my $entry =  ($valw->children)[1];
                $entry->configure('-text' => (defined $val) ? $val : "");
                $entry->validate();
340
            }
341
            
342
        } else {
Christian Fibich's avatar
Christian Fibich committed
343
344
            if (defined($val)) {
                $valw->configure('-text' => $val);
345
            } else {
Christian Fibich's avatar
Christian Fibich committed
346
                $valw->delete('0', 'end');
347
348
349
            }
            my $valid = $valw->validate();
        }
350
    }
351
352
353
354
355

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

Christian Fibich's avatar
Christian Fibich committed
356
    my $parent = $self->{'fr_fius'}->parent();
357
358
    my $fiu_displaygroup = DISPLAYGROUPS_FIU_KEY;
    undef($self->{'highlit_widgets'}->{$fiu_displaygroup});
Christian Fibich's avatar
Christian Fibich committed
359
360
361
    $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());
362
363

    # The code line below creates a segfault. It should delete all children
Christian Fibich's avatar
Christian Fibich committed
364
    # of the parent frame of self->{'fr_fius'}.
365
    # $parent->destroy();
Christian Fibich's avatar
Christian Fibich committed
366
    # @FIXME: Without this we have an obvious memory leak
367
368
369

    # 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
370
371
    #             self->{'fr_fius'}<-frame   <-pane    <-frame   <-frame1  <-border  <-labframe1<-self
    # my $parent = $self->{'fr_fius'}->parent()->parent()->parent()->parent()->parent()->parent();
372
373
374
375
376
377
378
379
    # $self->_add_fiu_panel($parent->parent());
    # $parent->destroy();

    # This recreates the entire FIU list:

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

380
    # Create column headers
Christian Fibich's avatar
Christian Fibich committed
381
382
383
384
385
386
    #    foreach my $hdr ("Net Name", "Driver", "Fault Model", "LFSR Mask") {
    #        $self->{'fr_fius'}->Label(-text => $hdr,)->grid(
    #            '-row'    => $hdr_row,
    #            '-column' => $i++,
    #        );
    #    }
387

388
389
    # Add fields for each FIU
    my $fiu_cnt = $self->_fiu_cnt();
Christian Fibich's avatar
Christian Fibich committed
390
391
392
    for (my $i = 0 ; $i < $fiu_cnt ; $i++) {
        my $fiu_ref = @{$self->{'settings'}->{'fius'}}[$i];
        $self->_add_fiu($fiu_ref, $i);
393
    }
394

395
    $self->_update_warning_indicators($fiu_displaygroup);
396
    $self->_update_resources();
Christian Fibich's avatar
Christian Fibich committed
397
    $self->{'settings_canvas'}->configure(-settings_ref => \($self->{'settings'})) if defined $self->{'settings_canvas'};
398

399
    return 1;
400
401
}

402
403
## @method _update_resources()
# Calculates resource estimate and updates the "Status Bar"
404
#
405
406
sub _update_resources {
    my $self = shift;
Christian Fibich's avatar
Christian Fibich committed
407
    my $rh   = FIJI::Settings::estimate_resources($self->{'settings'});
Christian Fibich's avatar
Christian Fibich committed
408
409
    $rh->{'regs'}     = "< " . RESOURCES_REGS_LOWER if ($rh->{'regs'} < RESOURCES_REGS_LOWER);
    $rh->{'lut_calc'} = "< " . RESOURCES_LUTS_LOWER if ($rh->{'lut_calc'} < RESOURCES_LUTS_LOWER);
Stefan Tauner's avatar
Stefan Tauner committed
410
    $self->{'resources'} = "Virtual resource factors: " . $rh->{'regs'} . " Registers, " . $rh->{'lut_calc'} . " Combinational Resources";
411
}
412

413
414
415
416
## @method _switchtab(nb, inc)
# Raises the tab $inc frames left ($inc < 0) or right ($inc > 0) of the
# currently selected tab of $nb
#
417
sub _switchtab {
Christian Fibich's avatar
Christian Fibich committed
418
    my ($dummy, $nb, $inc) = @_;
419
420
    my @pages        = $nb->pages();
    my $current_page = $nb->raised();
Christian Fibich's avatar
Christian Fibich committed
421
422
    my ($index) = grep { $pages[$_] eq $current_page } 0 .. (@pages - 1);
    my $next_page = $pages[$index + $inc];
423

Christian Fibich's avatar
Christian Fibich committed
424
425
    $nb->raise($next_page) if (($inc > 0 && defined $next_page)
        || ($inc < 0 && $index > 0));
426
427
}

428
429
430
## @method _populate_widget(self, fr)
# Creates, aranges and binds all widgets
#
431
sub _populate_widget {
432
    my $logger = get_logger("");
Christian Fibich's avatar
Christian Fibich committed
433
    my ($self, $fr) = @_;
434
435

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

442
443
    # create Tk::Balloon instance for tooltips
    my $balloon = $fr->Balloon();
444
    $self->{'balloon'} = $balloon;
445
446

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

451
452
453
454
455
    # Switch tabs by buttons in "status bar"
    my $bb = $bf->Button(
        -text    => "< Back",
        -command => [\&_switchtab, undef, $self->{'nb'}, -1],
    );
456
457
458
459
460
461
    $balloon->attach(
        $bb,
        -balloonposition => 'mouse',
        -msg             => "Previous Tab (Alt+Left)",
    );

462
463
464
465
    my $bn = $bf->Button(
        -text    => "Next >",
        -command => [\&_switchtab, undef, $self->{'nb'}, 1],
    );
466
467
468
469
470
    $balloon->attach(
        $bn,
        -balloonposition => 'mouse',
        -msg             => "Next Tab (Alt+Right)",
    );
471
472
473

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

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

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

482
483
484
    # 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]);
485

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

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

492
493
494
        # The FIU panel is generated separately
        next if $displaygroup eq DISPLAYGROUPS_FIU_KEY;

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

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

500
501
        my $row = 1;
        my $i   = 0;
502

503
504
        my $title = DISPLAYGROUPS->{$displaygroup}->{'title'};
        $title .= ": " . DISPLAYGROUPS->{$displaygroup}->{'subtitle'} if DISPLAYGROUPS->{$displaygroup}->{'subtitle'} ne "";
505

506
        # add new notebook page
Christian Fibich's avatar
Christian Fibich committed
507
        my $page = $self->{'nb'}->add(
508
            $displaygroup,
509
510
511
512
            -anchor   => "ne",
            -label    => DISPLAYGROUPS->{$displaygroup}->{'title'},
            # FIXME: Menubar overrides the ALT-(Key) bindings, how can we propagate the events to the notebook?
            #-underline => 0,
513
        );
514

515
516
        # add frame for Block Diagram / Description
        my $description_frame = $page->Frame();
Christian Fibich's avatar
Christian Fibich committed
517
        $description_frame->Label(-text => DISPLAYGROUPS->{$displaygroup}->{'description'})->pack(-anchor => "nw", -side => "top", -fill => "x");
518

519
520
        # add frame for configuration widgets
        my $config_frame = $page->Frame();
521

522
        # if the tab is changed, reparent the canvas widget
Christian Fibich's avatar
Christian Fibich committed
523
        $self->{'nb'}->pageconfigure(
524
525
            $displaygroup,
            -raisecmd => sub {
Christian Fibich's avatar
Christian Fibich committed
526
                $self->{'settings_canvas'}->packForget() if defined $self->{'settings_canvas'};
Christian Fibich's avatar
Christian Fibich committed
527
                $self->{'settings_canvas'}->pack(-anchor => "nw", -in => $description_frame);
Christian Fibich's avatar
Christian Fibich committed
528
                $self->{'settings_canvas'}->update();
529
                $config_frame->focus;
530
531
            }
        );
532

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

536
        # add tooltip to the config frame
Christian Fibich's avatar
Christian Fibich committed
537
        if (defined DISPLAYGROUPS->{$displaygroup}->{'description'}) {
538
539
540
541
542
543
            $balloon->attach(
                $config_frame,
                -balloonposition => 'mouse',
                -msg             => DISPLAYGROUPS->{$displaygroup}->{'description'}
            );
        }
544

545
        # add matching widgets for all values in this displaygroup
Christian Fibich's avatar
Christian Fibich committed
546
        foreach my $k (sort { DESIGNMAP->{$a}->{'order'} <=> DESIGNMAP->{$b}->{'order'} } @keys) {
547

548
549
            my $tooltip;

550
551
552
            # label
            my $label = $config_frame->Label(
                '-text'    => DESIGNMAP->{$k}->{'description'},
553
                '-justify' => 'left',
554
            );
555
556
557
558
            $label->{'fiji_id'} = DESIGNMAP->{$k}->{'ini_name'};
            $label->grid(
                -row      => $row,
                -column   => 0,
559
                '-sticky' => 'w',
560
            );
Christian Fibich's avatar
Christian Fibich committed
561

562
            # unit
Christian Fibich's avatar
Christian Fibich committed
563
            my $unit = $config_frame->Label('-text' => DESIGNMAP->{$k}->{'unit'},);
564
565
566
567
568
569
            $unit->grid(
                -row      => $row,
                -column   => 1,
                '-ipadx'  => ".5c",
                '-sticky' => 'w',
            );
570

571
572
            # entry
            my $type = DESIGNMAP->{$k}->{'type'};
Christian Fibich's avatar
Christian Fibich committed
573
            if (defined($type) && $type eq 'net') {
574
575

                # entry for NET
576
                $entry = $config_frame->Frame();
577
578
                my $select_button = $entry->Button(-text    => "Select");
                my $net_roentry = $entry->Entry();
579

580
581
                $net_roentry->{'displaygroup'} = $displaygroup;
                $net_roentry->{'key'}          = $k;
582

583
                $net_roentry->configure(-state=>"readonly",
584
                              -validatecommand=>sub {my $new = shift; $self->_indicate_warning($net_roentry, ($select_button->cget(-state) ne "disabled" && $new eq "")); return 1},
585
586
587
                              -textvariable=>\$self->{'settings'}->{'design'}->{$k},
                              -takefocus=>0);

588
                $select_button->configure(
589
                    -command => sub {
590
591
592
593
594
                        my $netname   = [];
                        my $old_value = $self->{'settings'}->{'design'}->{$k};
                        # only display old value if not empty
                        push @{$netname}, $old_value if (defined $old_value && !($old_value =~ /^\s*$/));

595
                        my $rv = $self->_select_net_dialog($netname,"Select Net for $k");
596
597
                        if (defined $rv) {
                            $logger->warn($rv);
598
599
600
601
602
603
                            my $warn_dialog = $self->{'mw'}->FIJIModalDialog(
                                -image     => Tk::FIJIUtils::alert_image($self->{'mw'}),
                                -wraplength => $self->screenwidth,
                                -text      => "$rv",
                                -title     => "Warning",
                            );
604
                            $warn_dialog->Show();
605
606
                        } elsif (@{$netname} > 0) {
                            $self->{'settings'}->{'design'}->{$k} = @{$netname}[0];
607
                            $self->update;
608
                            $self->_indicate_warning($net_roentry, 0);
609
610
611
                        }
                        $self->_check_change();
                    }
612
                );
613
614
                $select_button->grid(-row => 0, -column => 1, -sticky => "ew");
                $net_roentry->grid(-row => 0, -column => 0, -sticky => "ew");
615

616
                $entry->gridColumnconfigure(0, -weight => 1);
617
618
619
620
621
                $entry->grid(
                    -row      => $row,
                    -column   => 2,
                    '-sticky' => 'ew'
                );
622

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

Christian Fibich's avatar
Christian Fibich committed
625
626
627
628
                # entry for an external port name
                $entry = $config_frame->Entry();
                $entry->configure(
                    '-validate'        => 'key',
629
                    '-validatecommand' => [\&_validate_toplevel_port_entry, $self, $entry, $k, 1],
Christian Fibich's avatar
Christian Fibich committed
630
631
632
633
634
635
                );
                $entry->grid(
                    -row      => $row,
                    -column   => 2,
                    '-sticky' => 'ew'
                );
636

Christian Fibich's avatar
Christian Fibich committed
637
            } elsif (defined($type) && $type eq 'toplevel_port') {
Christian Fibich's avatar
Christian Fibich committed
638

Christian Fibich's avatar
Christian Fibich committed
639
                # entry for a DUT port name
640
641
642
                $entry = $config_frame->CompleteEntry();
                $entry->configure(
                    '-validate'        => 'key',
643
                    '-validatecommand' => [\&_validate_toplevel_port_entry, $self, $entry, $k, 0],
644
645
646
647
648
649
                );
                $entry->grid(
                    -row      => $row,
                    -column   => 2,
                    '-sticky' => 'ew'
                );
650
            } elsif (defined($type) && $type eq 'lfsrpoly') {
Christian Fibich's avatar
Christian Fibich committed
651

652
653
654
655
656
657
658
659
660
661
662
                # entry for the LFSR poly
                $entry = $config_frame->CompleteEntry();
                $entry->configure(
                    '-validate'        => 'focusout',
                    '-validatecommand' => [\&_validate_design_entry, $self, $entry, $k],
                );
                $entry->grid(
                    -row      => $row,
                    -column   => 2,
                    '-sticky' => 'ew'
                );
663
664
665
666
667
668
                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
669
            } elsif (defined($type) && $type eq 'boolean') {
670
671

                # checkbutton for values which can only be "enabled" or "disabled"
Christian Fibich's avatar
Christian Fibich committed
672
                $entry = $config_frame->Checkbutton('-justify' => 'left',);
673
674
675
676
677
                $entry->grid(
                    -row      => $row,
                    -column   => 2,
                    '-sticky' => 'w'
                );
Christian Fibich's avatar
Christian Fibich committed
678
            } elsif (defined($type) && ($type eq 'bit' || $type eq 'dropdown')) {
679
680
681
682
683

                # 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
684
685
686
687

                    #                    '-width'        =>
                    '-anchor'  => 'w',
                    '-justify' => 'left'
688
689
690
691
                );
                $entry->grid(
                    -row      => $row,
                    -column   => 2,
692
                    '-sticky' => 'ew',
693
                );
Christian Fibich's avatar
Christian Fibich committed
694
695
            } elsif (defined($type) && ($type eq 'dir' || $type eq 'file')) {

696
                my $dialog_type = ($type eq 'dir') ? 'dir' : 'save';
697
698
699
700
701
702
703

                # 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
704
                        my $fb = $entry->FBox(
Christian Fibich's avatar
Christian Fibich committed
705
706
                            -type  => $dialog_type,
                            -title => "Select " . lc(DESIGNMAP->{$k}->{'description'}),
Stefan Tauner's avatar
Stefan Tauner committed
707
708
709
                        );
                        Tk::FIJIUtils::set_icon($fb);
                        my $val = $fb->Show();
Christian Fibich's avatar
Christian Fibich committed
710
                        if (defined $val) {
711
                            my ($basevolume, $basedirs, $file) = File::Spec->splitpath($self->{'settings'}->{'filename'});
712
                            my $nv = File::Spec->abs2rel($val, File::Spec->catpath($basevolume, $basedirs, ""));
713
714
                            $logger->info("Setting $k to relative path $nv") if (File::Spec->file_name_is_absolute($val));
                            $self->{'settings'}->{'design'}->{$k} = $nv;
715
716
717
                            $self->update;
                        }
                    }
Christian Fibich's avatar
Christian Fibich committed
718
719
720
721
722
                  )->grid(
                    -row    => 0,
                    -column => 0,
                    -sticky => "w"
                  );
723
                $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
724
                $entry->gridColumnconfigure(1, -weight => 1);
725
726
727
728
729
730
                $entry->grid(
                    -row      => $row,
                    -column   => 2,
                    '-sticky' => 'ew'
                );
            } else {
731

732
733
734
735
                # a simple text entry for all other types
                $entry = $config_frame->Entry();
                $entry->configure(
                    '-validate'        => 'key',
Christian Fibich's avatar
Christian Fibich committed
736
                    '-validatecommand' => [\&_validate_design_entry, $self, $entry, $k],
737
738
739
740
741
742
743
                );
                $entry->grid(
                    -row      => $row,
                    -column   => 2,
                    '-sticky' => 'ew'
                );
            }
744

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

750
            # set exclusions (widgets which mutually exclude each other)
Christian Fibich's avatar
Christian Fibich committed
751
752
            if (defined(DESIGNMAP->{$k}->{'forbidden_by'})) {
                push @{$self->{'forbidden_by'}->{DESIGNMAP->{$k}->{'forbidden_by'}}}, $entry;
753
            }
754

755
            # add tooltip for widget
Christian Fibich's avatar
Christian Fibich committed
756
            if (defined DESIGNMAP->{$k}->{'help'}) {
757
                $tooltip = DESIGNMAP->{$k}->{'help'} . " [" . DESIGNMAP->{$k}->{'ini_name'} . "]" if (!defined($tooltip));
758
759
760
                $balloon->attach(
                    $entry,
                    -balloonposition => 'mouse',
761
                    -msg             => $tooltip,
762
763
764
765
                );
                $balloon->attach(
                    $label,
                    -balloonposition => 'mouse',
766
                    -msg             => $tooltip,
767
768
                );
            }
769

770
            Tk::FIJIUtils::entry_rebind($entry);
771

772
773
            # Widget description is needed for widget-based error messages such as
            # "Forbids"
774
775
776
            $entry->{'description'}  = DESIGNMAP->{$k}->{'description'};
            $entry->{'displaygroup'} = $displaygroup;
            $entry->{'key'}          = $k;
777
778
            $row++;
        }
Christian Fibich's avatar
Christian Fibich committed
779
780
        $description_frame->pack(-anchor => "nw", -side => "left", -fill => "x", -padx => 5, -pady => 5);
        $config_frame->pack(-anchor => "nw", -side => "left", -fill => "x", -expand => 1, -padx => 5, -pady => 30);
781

Christian Fibich's avatar
Christian Fibich committed
782
        push @{$self->{'pages_design'}}, $config_frame;
783
    }
784

785
    $widget_background = $entry->cget('-bg');
786

787
788
789
790
    ##############
    # fius panel #
    ##############

Christian Fibich's avatar
Christian Fibich committed
791
    $self->{'page_fius'} = $self->{'nb'}->add(
792
793
        DISPLAYGROUPS_FIU_KEY,
        -label     => DISPLAYGROUPS->{DISPLAYGROUPS_FIU_KEY}->{'title'},
794
795
       # FIXME: Menubar overrides the ALT-(Key) bindings, how can we propagate the events to the notebook?
       #-underline => 0
796
797
798
    );

    # add frame for Block Diagram / Description
Christian Fibich's avatar
Christian Fibich committed
799
    my $description_frame = $self->{'page_fius'}->Frame();
800
    $description_frame->Label(-text => DISPLAYGROUPS->{DISPLAYGROUPS_FIU_KEY}->{'description'})->pack(-fill => "both");
801
802

    # add frame for configuration widgets
Christian Fibich's avatar
Christian Fibich committed
803
    my $config_frame = $self->{'page_fius'}->Frame();
804

Christian Fibich's avatar
Christian Fibich committed
805
806
    $description_frame->pack(-anchor => "nw", -side => "left", -fill => "x", -padx => 5, -pady => 5);
    $config_frame->pack(-anchor => "nw", -side => "top", -fill => "both", -expand => 1, -padx => 5, -pady => 30);
807
808
809

    # 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
810
    $self->{'nb'}->pageconfigure(
811
        DISPLAYGROUPS_FIU_KEY,
812
        -raisecmd => sub {
Christian Fibich's avatar
Christian Fibich committed
813
814
815
            $self->{'settings_canvas'}->packForget() if defined $self->{'settings_canvas'};
            $self->{'settings_canvas'}->pack(-in => $description_frame);
            $self->{'settings_canvas'}->update();
816
            $config_frame->focus;
817
818
819
        }
    );
    $self->_add_fiu_panel($config_frame);
820

821

822
823
}

824
825
826
# 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
827
828
    my ($index, $value, $op, $self) = @_;
    $self->{'settings_canvas'}->update() if defined $self->{'settings_canvas'};
829
    $self->_check_change();
830
831
    return $value;
}
Stefan Tauner's avatar
Stefan Tauner committed
832

833
sub _add_fiu_panel {
Christian Fibich's avatar
Christian Fibich committed