FIJISettingsViewer.pm 60 KB
Newer Older
Christian Fibich's avatar
Christian Fibich committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
#-------------------------------------------------------------------------------
#  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
#
#-------------------------------------------------------------------------------
#  File:              FIJISettingsViewer.pm
#  Created on:        25.02.2015
#  $LastChangedBy$
#  $LastChangedDate$
#
#  Description:
#  FIJI Settings Viewer class
#-------------------------------------------------------------------------------

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

## @class Tk::FIJISettingsViewer
Christian Fibich's avatar
Christian Fibich committed
24
# @brief A Tk::Frame widget to display all \ref FIJI::Settings
25
26
27
28
package Tk::FIJISettingsViewer;

use strict;
use warnings;
29
30
use utf8;

31
32
use Log::Log4perl qw(get_logger);
use Scalar::Util 'blessed';
33
use FIJI::Utils;
34
use Tk;
35
use Tk::widgets qw(LabFrame Balloon Label Entry Pane Button Dialog DialogBox Checkbutton CompleteEntry NoteBook StatusBar FIJISettingsCanvas);
36
use Tk::FIJIModalDialog;
37
use Tk::FIJINetSelection;
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
use Data::Dumper;
61

62
Construct Tk::Widget 'FIJISettingsViewer';
63

64
65
66
my $delete_image;
my $alert_image;
my $error_image;
Christian Fibich's avatar
Christian Fibich committed
67

Christian Fibich's avatar
Christian Fibich committed
68
69
70
## @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
71
my $widget_background;
72
my $widget_ro_background;
73
74

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

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

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

90
    my $icon_path = delete $args->{'-icon_path'};
91

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

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

107
108
    }

109
110
    $self->{'settings_validation_results'} = {};

Christian Fibich's avatar
Christian Fibich committed
111
    # @FIXME: add an option to store a CODE reference that is called when any field is invalid
112
    $self->{'lfsr_poly_choices'} = [];
113
114
115
    $self->SUPER::Populate($args);
    $self->_populate_widget($self);
    $self->ConfigSpecs(
Christian Fibich's avatar
Christian Fibich committed
116
117
118
        -netlist   => [qw/METHOD netlist    Netlist/,   undef],
        -settings  => [qw/METHOD settings   Settings/,  undef],
        -resources => [qw/METHOD resources  Resources/, undef],
119
120
    );
    $self->update();
121
    $self->{'mw'} = $self->toplevel;
122
    $delete_image = $self->Photo(-file => File::Spec->catfile($icon_path, 'delete_48x48.xpm'), -format => 'XPM');
Christian Fibich's avatar
Christian Fibich committed
123
124
    $error_image  = $self->Photo(-file => File::Spec->catfile($icon_path, 'stop_48x48.xpm'),   -format => 'XPM');
    $alert_image  = $self->Photo(-file => File::Spec->catfile($icon_path, 'alert_48x48.xpm'),  -format => 'XPM');
125
}
126

127
sub netlist {
128
    my $logger = get_logger("");
Christian Fibich's avatar
Christian Fibich committed
129
130
131
    my ($self, $netlist) = @_;
    if (defined($netlist)) {
        if (ref($netlist) ne 'FIJI::Netlist') {
132
133
134
            $logger->error("Ignoring invalid Netlist");
            return undef;
        }
135

136
        my $nets = $netlist->get_nets();
137

Christian Fibich's avatar
Christian Fibich committed
138
        if (ref($nets) ne 'ARRAY') {
139
            $logger->error("Ignoring invalid nets array");
140
141
            return undef;
        }
142
143
144
145
146

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

        # generates a list of all nets with full paths from the nets hashref
147
        my @n = map { $_->{'path'} . FIJI::Netlist::HIERSEP . $_->{'name'} } @{$nets};
148
149
150
151
152
        $self->{'nets'}    = \@n;
        $self->{'netlist'} = $netlist;
        $self->{'nets_ok'} = 1;
        $self->update();

Christian Fibich's avatar
Christian Fibich committed
153
        if ($self->{'nets_ok'} != 1) {
154
155
            my $msg = "Some nets defined in the specified netlist do not match the loaded settings.";
            $logger->error($msg);
156
157
158
159
160
161
162
163
164

            my $d = $self->{'mw'}->FIJIModalDialog(-delete_mw   => $self->{'delete_mw'},
                                                   -mw          => $self->{'mw'},
                                                   -image       => $alert_image,
                                                   -text        => $msg . "\n" . "Proceed with new netlist nevertheless?",
                                                   -wraplength  => 200,
                                                   -title       => 'Warning',
                                                   -buttons     => [qw/Yes No/]);

165
            my $rv = $d->Show();
166
            if (!defined $rv || $rv eq "No") {
167
168
169
170
171
172
173
174
175
176
                $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();
177
    }
178
    return $self->{'netlist'};
179
180
}

181
sub settings {
182
    my $logger = get_logger("");
Christian Fibich's avatar
Christian Fibich committed
183
184
185
    my ($self, $settings) = @_;
    if (defined($settings)) {
        if (!blessed($settings) || !$settings->isa("FIJI::Settings")) {
186
187
188
189
            $logger->error("Given settings are not of type FIJI::Settings.");
            return undef;
        }
        my $old_settings = $self->{'settings'};
190
191
        $self->{'settings'}                    = $settings;
        $self->{'original_settings'}           = clone($settings);
192
        $self->{'original_settings'}->{'fius'} = clone($settings->{'fius'});
193
194

        # tk:trace for canvas update
Christian Fibich's avatar
Christian Fibich committed
195
196
        $self->traceVariable($self->{'settings'}->{'design'}, 'w' => [\&_update_canvas, $self]);
        $self->traceVariable($self->{'settings'}->{'fius'},   'w' => [\&_update_canvas, $self]);
197
198
199
        $self->{'nets_ok'} = 1;
        $self->update();

Christian Fibich's avatar
Christian Fibich committed
200
        if (defined $self->{'nets'} && $self->{'nets_ok'} != 1) {
201
202
            my $msg = "Some nets defined in the specified settings do not match the loaded netlist.";
            $logger->info($msg);
203
204
205
206
207
208
209
210
211

            my $d = $self->{'mw'}->FIJIModalDialog(-delete_mw   => $self->{'delete_mw'},
                                                   -mw          => $self->{'mw'},
                                                   -image       => $alert_image,
                                                   -text        => $msg . "\n" . "Proceed with new netlist nevertheless?",
                                                   -wraplength  => 200,
                                                   -title       => 'Warning',
                                                   -buttons     => [qw/Yes No/]);

212
            my $rv = $d->Show();
213
            if (!defined $rv || $rv eq "No") {
214
                $logger->info("Using original settings");
215
216
                $self->{'settings'}                    = $old_settings;
                $self->{'original_settings'}           = clone($old_settings);
217
                $self->{'original_settings'}->{'fius'} = clone($old_settings->{'fius'});
218
219

                # tk:trace for canvas update
Christian Fibich's avatar
Christian Fibich committed
220
221
                $self->traceVariable($self->{'settings'}->{'design'}, 'w' => [\&_update_canvas, $self]);
                $self->traceVariable($self->{'settings'}->{'fius'},   'w' => [\&_update_canvas, $self]);
222
223
224
225
226
                $self->update();
                return 0;
            } else {
                $logger->info("Using new settings nevertheless");
            }
227
228
        }
    }
229
    return $self->{'settings'};
230
231
}

232
sub resources {
Christian Fibich's avatar
Christian Fibich committed
233
    my ($self, $resources) = @_;
234
235
236
237
    $self->{'resources'} = $resources;
    $self->update();
}

238
239
240
241
## @method update()
# @brief redraws the widget on fundamental changes
#
sub update {
242
    my $self   = shift;
243
    my $logger = get_logger("");
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259

    #################
    # 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
260
261
    foreach my $f (@{$self->{'pages_design'}}) {
        foreach my $c ($f->children) {
262
263
            push @design_widgets, $c;
        }
264
    }
265

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

Christian Fibich's avatar
Christian Fibich committed
270
    for (my $i = 0 ; $i < $const_cnt ; $i += 3) {
271
272

        # The order of the widgets depends on their *construction* time(!)
Christian Fibich's avatar
Christian Fibich committed
273
        my ($namew, $unitw, $valw) = @design_widgets[$i .. $i + 3];
274
275
276
277
        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
278
        if (!defined($k)) {
279
280
            my $msg = "Could not find FIJI definition for constant named \"$name\"";
            $logger->error($msg);
281
282
283
284
285
286
287
288
289

            my $d = $self->{'mw'}->FIJIModalDialog(-delete_mw   => $self->{'delete_mw'},
                                                   -mw          => $self->{'mw'},
                                                   -image       => $error_image,
                                                   -text        => 'Something went horribly wrong!',
                                                   -wraplength  => 200,
                                                   -title       => 'Warning',
                                                   -buttons     => ["OK"]);

290
            $d->Show();
291
292
293
294
            return;
        }

        $logger->trace("Connect widget ($name) with new settings instance hash ($k)");
Christian Fibich's avatar
Christian Fibich committed
295
296
297
298
        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;
299
300
301
302
303
304
        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
305
                $orig_ref = \$val;
306
307
            }
        }
308
309

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

313
            # Update CompleteEntry Fields with the new choices if defined
314
            $valw->configure(
Christian Fibich's avatar
Christian Fibich committed
315
316
317
318
                '-choices' => $autocomplete_choices,
              )
              if defined($autocomplete_choices);
            $valw->configure('-textvariable' => $orig_ref);
319
            my $valid = $valw->validate();
Christian Fibich's avatar
Christian Fibich committed
320
        } elsif (ref($valw) eq 'Tk::Checkbutton') {
321
322

            # Set fields depending on checkbuttons, check if checkbutton forbids another
Christian Fibich's avatar
Christian Fibich committed
323
324
325
326
327
328
329
            $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}]);
330
            }
Christian Fibich's avatar
Christian Fibich committed
331
332
333
            _set_fields_by_button($self, $valw, $self->{'depends'}->{$k}, $self->{'forbidden_by'}->{$k});
        } elsif (ref($valw) eq 'Tk::Optionmenu') {
            $valw->configure('-textvariable' => $orig_ref);
334
        } elsif (ref($valw) eq 'Tk::Frame' && defined($type)) {
335
336
337
            # Tk::Frames need a little extra work, because the design widget is
            # a child widget.

338
339

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

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

Christian Fibich's avatar
Christian Fibich committed
361
362
363
364
    my $parent = $self->{'fr_fius'}->parent();
    $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());
365
366

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

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

    # This recreates the entire FIU list:

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

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

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

398
    $self->_update_resources();
Christian Fibich's avatar
Christian Fibich committed
399
    $self->{'settings_canvas'}->configure(-settings_ref => \($self->{'settings'})) if defined $self->{'settings_canvas'};
400

401
    return 1;
402
403
}

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

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

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

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

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

444
445
446
447
    # create Tk::Balloon instance for tooltips
    my $balloon = $fr->Balloon();

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

452
    # Button to open the documentation
453
    my $bd;
454
    if (defined FIJI_DOCUMENTATION_PATH) {
455
        $bd = $bf->Button(
456
457
            -text    => "Open Documentation",
            -command => sub {
458
                my $ret;
Christian Fibich's avatar
Christian Fibich committed
459
                if ($^O eq "MSWin32") {
460
                    $ret = FIJI::Utils::system(1, "start " . FIJI_DOCUMENTATION_PATH);
Christian Fibich's avatar
Christian Fibich committed
461
                } elsif ($^O eq "linux") {
462
                    $ret = FIJI::Utils::system("xdg-open " . FIJI_DOCUMENTATION_PATH);
463
                } else {
464
465
466
467
468
469
                    my $d = $self->{'mw'}->FIJIModalDialog(-delete_mw => $self->{'delete_mw'},
                                                           -mw        => $self->{'mw'},
                                                           -image     => $error_image,
                                                           -text      => "No default PDF viewer for OS \"" . $^O . "\"...",
                                                           -title     => "Open Documentation failed",
                                                           -buttons   => ["OK"]);
470
471
                    $d->Show();
                    return;
472
                }
473
                if (defined($ret)) {
474
475
476
477
478
479
                    my $d = $self->{'mw'}->FIJIModalDialog(-delete_mw => $self->{'delete_mw'}, 
                                                           -mw        => $self->{'mw'},
                                                           -image     => $error_image,
                                                           -text      => $ret,
                                                           -title     => "Open Documentation failed",
                                                           -buttons   => ["OK"]);
480
                    $d->Show();
Christian Fibich's avatar
Christian Fibich committed
481
                }
482
            }
483
        );
484
    }
485
486
487
488
489
490
491
492
493
494
495
496
497
498

    # Switch tabs by buttons in "status bar"
    my $bb = $bf->Button(
        -text    => "< Back",
        -command => [\&_switchtab, undef, $self->{'nb'}, -1],
    );
    my $bn = $bf->Button(
        -text    => "Next >",
        -command => [\&_switchtab, undef, $self->{'nb'}, 1],
    );

    $bn->pack(-side => "right");
    $bb->pack(-side => "right");
    $bd->pack(-side => "right") if defined($bd);
499

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

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

507
508
509
    # 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]);
510

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

Christian Fibich's avatar
Christian Fibich committed
514
    foreach my $displaygroup (sort { DISPLAYGROUPS->{$a}->{'order'} <=> DISPLAYGROUPS->{$b}->{'order'} } keys(%{$dg_ref})) {
515

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

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

521
522
        my $row = 1;
        my $i   = 0;
523

524
525
        my $title = DISPLAYGROUPS->{$displaygroup}->{'title'};
        $title .= ": " . DISPLAYGROUPS->{$displaygroup}->{'subtitle'} if DISPLAYGROUPS->{$displaygroup}->{'subtitle'} ne "";
526

527
        # add new notebook page
Christian Fibich's avatar
Christian Fibich committed
528
        my $page = $self->{'nb'}->add(
529
530
            $displaygroup,
            -anchor => "ne",
Stefan Tauner's avatar
Stefan Tauner committed
531
            -label  => DISPLAYGROUPS->{$displaygroup}->{'title'}
532
        );
533

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

538
539
        # add frame for configuration widgets
        my $config_frame = $page->Frame();
540

541
        # if the tab is changed, reparent the canvas widget
Christian Fibich's avatar
Christian Fibich committed
542
        $self->{'nb'}->pageconfigure(
543
544
            $displaygroup,
            -raisecmd => sub {
Christian Fibich's avatar
Christian Fibich committed
545
                $self->{'settings_canvas'}->packForget() if defined $self->{'settings_canvas'};
Christian Fibich's avatar
Christian Fibich committed
546
                $self->{'settings_canvas'}->pack(-anchor => "nw", -in => $description_frame);
Christian Fibich's avatar
Christian Fibich committed
547
                $self->{'settings_canvas'}->update();
548
549
            }
        );
550

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

554
        # add tooltip the config frame
Christian Fibich's avatar
Christian Fibich committed
555
        if (defined DISPLAYGROUPS->{$displaygroup}->{'description'}) {
556
557
558
559
560
561
            $balloon->attach(
                $config_frame,
                -balloonposition => 'mouse',
                -msg             => DISPLAYGROUPS->{$displaygroup}->{'description'}
            );
        }
562

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

566
567
568
569
            # label
            my $label = $config_frame->Label(
                '-text'    => DESIGNMAP->{$k}->{'description'},
                '-justify' => 'left'
570
            );
571
572
573
574
575
            $label->{'fiji_id'} = DESIGNMAP->{$k}->{'ini_name'};
            $label->grid(
                -row      => $row,
                -column   => 0,
                '-sticky' => 'w'
576
            );
Christian Fibich's avatar
Christian Fibich committed
577

578
            # unit
Christian Fibich's avatar
Christian Fibich committed
579
            my $unit = $config_frame->Label('-text' => DESIGNMAP->{$k}->{'unit'},);
580
581
582
583
584
585
            $unit->grid(
                -row      => $row,
                -column   => 1,
                '-ipadx'  => ".5c",
                '-sticky' => 'w',
            );
586

587
588
            # entry
            my $type = DESIGNMAP->{$k}->{'type'};
Christian Fibich's avatar
Christian Fibich committed
589
            if (defined($type) && $type eq 'net') {
590
591

                # entry for NET
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
                $entry = $config_frame->Frame();
                $entry->Button(
                    -text    => "Select",
                    -command => sub {
                        my $netname = $self->{'settings'}->{'design'}->{$k};
                        my $rv = $self->_select_net_dialog(\$netname,"Select Net for $k");
                        if (defined $rv) {
                            $logger->warn($rv);
                            $logger->error($rv);
                            my $d = $self->{'mw'}->FIJIModalDialog(-delete_mw => $self->{'delete_mw'},
                                                                   -mw        => $self->{'mw'},
                                                                   -image     => $alert_image,
                                                                   -wraplength => $self->screenwidth,
                                                                   -text      => "$rv",
                                                                   -title     => "Warning",
                                                                   -buttons   => ["OK"]);
                            $d->Show();
                        } elsif (defined $netname) {
                            $self->{'settings'}->{'design'}->{$k} = $netname;
                            $self->update;
                        }
                        $self->_check_change();

                    }
                )->grid(
                    -row    => 0,
                    -column => 1,
                    -sticky => "ew"
                  );
                $entry->Entry(-state=>"readonly",-textvariable=>\$self->{'settings'}->{'design'}->{$k},-takefocus=>0)->grid(-row => 0, -column => 0, -sticky => "ew");
                $entry->gridColumnconfigure(0, -weight => 1);
623
624
625
626
627
                $entry->grid(
                    -row      => $row,
                    -column   => 2,
                    '-sticky' => 'ew'
                );
Christian Fibich's avatar
Christian Fibich committed
628
            } elsif (defined($type) && $type eq 'external_port') {
Christian Fibich's avatar
Christian Fibich committed
629

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

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

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

657
658
659
660
661
662
663
664
665
666
667
                # 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'
                );
Christian Fibich's avatar
Christian Fibich committed
668
            } elsif (defined($type) && $type eq 'boolean') {
669
670

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

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

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

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

                # complex widget (frame) for selecting directories
                $entry = $config_frame->Frame();
                my $btn = $entry->Button(
                    -justify => "left",
                    -text    => "Open",
                    -command => sub {
Christian Fibich's avatar
Christian Fibich committed
703
704
705
                        my $val = $entry->FBox(
                            -type  => $dialog_type,
                            -title => "Select " . lc(DESIGNMAP->{$k}->{'description'}),
706
                        )->Show;
Christian Fibich's avatar
Christian Fibich committed
707
                        if (defined $val) {
708
                            my ($basevolume, $basedirs, $file) = File::Spec->splitpath($self->{'settings'}->{'filename'});
709
                            my $nv = File::Spec->abs2rel($val, File::Spec->catpath($basevolume, $basedirs, ""));
710
711
                            $logger->info("Setting $k to relative path $nv") if (File::Spec->file_name_is_absolute($val));
                            $self->{'settings'}->{'design'}->{$k} = $nv;
712
713
714
                            $self->update;
                        }
                    }
Christian Fibich's avatar
Christian Fibich committed
715
716
717
718
719
                  )->grid(
                    -row    => 0,
                    -column => 0,
                    -sticky => "w"
                  );
720
                $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
721
                $entry->gridColumnconfigure(1, -weight => 1);
722
723
724
725
726
727
                $entry->grid(
                    -row      => $row,
                    -column   => 2,
                    '-sticky' => 'ew'
                );
            } else {
728

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

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

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

752
            # add tooltip for widget
Christian Fibich's avatar
Christian Fibich committed
753
            if (defined DESIGNMAP->{$k}->{'help'}) {
754
755
756
757
758
759
760
761
762
763
764
                $balloon->attach(
                    $entry,
                    -balloonposition => 'mouse',
                    -msg             => DESIGNMAP->{$k}->{'help'}
                );
                $balloon->attach(
                    $label,
                    -balloonposition => 'mouse',
                    -msg             => DESIGNMAP->{$k}->{'help'}
                );
            }
765

766
767
768
769
            $entry->bind(
                '<Control-a>',
                sub {
                    my $w = shift;
Christian Fibich's avatar
Christian Fibich committed
770
                    $w->selectionRange(0, 'end');
771
772
773
                    $w->icursor('end');
                },
            );
774

775
776
777
            # Widget description is needed for widget-based error messages such as
            # "Forbids"
            $entry->{'description'} = DESIGNMAP->{$k}->{'description'};
778
            $entry->{'key'}         = $k;
779
780
            $row++;
        }
Christian Fibich's avatar
Christian Fibich committed
781
782
        $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);
783

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

787
    $widget_background = $entry->cget('-bg');
788

789
790
791
792
    ##############
    # fius panel #
    ##############

Christian Fibich's avatar
Christian Fibich committed
793
    $self->{'page_fius'} = $self->{'nb'}->add(
794
795
796
797
798
799
        'fius',
        -label     => 'FIUs',
        -underline => 0
    );

    # add frame for Block Diagram / Description
Christian Fibich's avatar
Christian Fibich committed
800
801
    my $description_frame = $self->{'page_fius'}->Frame();
    $description_frame->Label(-text => "Settings concerning Fault Injection Units")->pack(-fill => "both");
802
803

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

Christian Fibich's avatar
Christian Fibich committed
806
807
    $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);
808
809
810

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

821
822
}

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

832
sub _add_fiu_panel {
Christian Fibich's avatar
Christian Fibich committed
833
    my ($self, $fr) = @_;
834

835
    my $fr_fius_main = $fr;
836

837
838
    $fr_fius_main->Button(
        -text    => 'Append empty FIU',
Christian Fibich's avatar
Christian Fibich committed
839
        -command => [\&_add_fiu, $self],
840
841
842
843
844
      )->pack(
        '-side'   => 'top',
        '-anchor' => 'nw',
      );

845
    # Make the grid containing the fius scrollable
846
847
848
849
850
    my $fr_fius_scroll = $fr_fius_main->Scrolled(
        'Pane',
        '-scrollbars' => 'osre',
        '-sticky'     => 'nwse',
    );
851
852
853

    Tk::FIJIUtils::bind_mousewheel($self->{'mw'},$fr_fius_scroll);

854
855
856
857
858
859
860
    $fr_fius_scroll->pack(
        '-expand' => 1,
        '-fill'   => 'both',
        '-anchor' => 'nw',
        '-side'   => 'top',
    );
    $self->_add_fiu_frame($fr_fius_scroll);
861
862
}

863
sub _add_fiu_frame {
Christian Fibich's avatar
Christian Fibich committed
864
865
    my ($self, $parent) = @_;
    $self->{'fr_fius'} = $parent->Frame()->pack(
866
867
868
869
870
        '-fill'   => 'both',
        '-side'   => 'top',
        '-anchor' => 'nw',
    );
}
871
872

sub _fiu_cnt {
873
874
    my ($self) = @_;
    my $fius = $self->{'settings'}->{'fius'};
Christian Fibich's avatar
Christian Fibich committed
875
    return (defined($fius) && ref($fius) eq 'ARRAY') ? scalar(@{$fius}) : 0;
876
877
}

878
sub append_fiu ($) {
Christian Fibich's avatar
Christian Fibich committed
879
    my ($self, $fiu) = @_;
880
    $self->_add_fiu($fiu);
881
882
883
}

sub remove_fiu ($) {
Christian Fibich's avatar
Christian Fibich committed
884
    my ($self, $i) = @_;
885
    $i = 0 if !defined($i);
Christian Fibich's avatar
Christian Fibich committed
886
    splice(@{$self->{'settings'}->{'fius'}}, $i, 1);