FIJISettingsViewer.pm 16.8 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
## @file

## @class Tk::FIJISettingsViewer
#
# 
package Tk::FIJISettingsViewer;

use strict;
use warnings;

use Log::Log4perl qw(get_logger);
use Scalar::Util 'blessed';
use Tk;
14
use Tk::widgets qw(LabFrame Label Entry Pane Button Dialog Checkbutton CompleteEntry);
15
16
17
18
19
20

use Tk::DynaMouseWheelBind;

use base qw(Tk::Frame);

use FIJI qw(:all);
21
use FIJI::Netlist;
22
23
24
25
26
27

Construct Tk::Widget 'FIJISettingsViewer';


my $fr_design; # labled frame surrounding widgets representing design constant
my $fr_fius; # labled frame surrounding widgets representing design constant
Stefan Tauner's avatar
Stefan Tauner committed
28
my $widget_background;
29
30
31
32
33
34
35
36
37
38


sub ClassInit {
  my($class, $mw) = @_;
  $class->SUPER::ClassInit($mw);
  
  my $self = bless {}, $class;
  return $self;
}

Stefan Tauner's avatar
Stefan Tauner committed
39

40
41
42
43
sub Populate {
  my $logger = get_logger();
  my($self, $args) = @_;
  my $settings = delete $args->{'-settings'};
44
  if (!defined($settings) || !blessed($settings) || !$settings->isa("FIJI::Settings")) {
45
46
47
    $logger->error("Given settings are not of type FIJI::Settings. No way to report this back from the constructor...");
  } else {
    $self->{'settings'} = $settings;
48
    if (ref($self->{'settings'}->{'FIUs'}) ne 'ARRAY') {
49
      $logger->debug("Adding empty FIUs array to settings reference.");
50
      $self->{'settings'}->{'FIUs'} = [];
51
52
    }
  }
53

Stefan Tauner's avatar
Stefan Tauner committed
54
  # FIXME: add an option to store a CODE reference that is called when any field is invalid
55
56
  $self->SUPER::Populate($args);
  $self->_populate_widget($self);
57
58
59
60
  $self->ConfigSpecs(
        -nets     => [qw/METHOD nets       Nets/,      undef],
        -settings => [qw/METHOD settings   Settings/,  undef],
  );
61
62
63
  $self->update();
}

64

65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
sub nets {
  my $logger = get_logger();
  my ($self, $nets) = @_;
  if (defined($nets)) {
    if (ref($nets) ne 'ARRAY') {
      $logger->error("Ignoring invalid nets array");
      return undef;
    }
    $self->{'nets'} = $nets;
    $self->update();
  }
  return $self->{'nets'}
}


sub settings {
  my $logger = get_logger();
  my ($self, $settings) = @_;
  if (defined($settings)) {
    if (!blessed($settings) || !$settings->isa("FIJI::Settings")) {
      $logger->error("Given settings are not of type FIJI::Settings.");
      return undef;
    }
    $self->{'settings'} = $settings;
    $self->update();
  }
  return $self->{'settings'}
}


95
96
97
98
99
## @method update()
# @brief redraws the widget on fundamental changes
#
sub update {
  my $self = shift;
100
  my $logger = get_logger();
101
102
103
104
105

  ################
  # design panel #
  ################

Stefan Tauner's avatar
Stefan Tauner committed
106
  # Ugly hack to retrieve the design constants widgets.
107
108
109
110
111
112
113
114
115
  # 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 = ${${$fr_design->children}[0]->children}[1]->children;
  my $const_cnt = @design_widgets;
116
  my $net_choices = defined($self->{'nets'}) ? $self->{'nets'} : [];
117
  for (my $i = 3; $i < $const_cnt; $i += 3) {
118
119
    # The order of the widgets depends on their *construction* time(!)
    my ($namew, $unitw, $valw) = @design_widgets[$i..$i+3];
120
121
122
123
124
125
126
127
128
129
130
131
    my $name = $namew->cget('-text');
    my $k = FIJI::ini2constkey($name);
    if (!defined($k)) {
      my $msg = "Could not find FIJI definition for constant named \"$name\"";
      $logger->error($msg);
      $self->Dialog(
        '-title' => 'Something went horribly wrong!',
        '-text' => "$msg\n",
      )->Show();
      return;
    }
    $logger->trace("Connect widget ($name) with new settings instance hash ($k)");
132
    my $orig_ref = \$self->{'settings'}->{'design'}->{$k};
133
    my $type = DESIGNMAP->{$k}->{'type'};
134
    my $orig = $$orig_ref;
135
    my $val = defined($type) && $type eq 'hexadecimal' ? sprintf("0x%x", $orig) : $orig;
136
    if (ref($valw) eq 'Tk::CompleteEntry') {
137
138
139
140
141
142
143
144
145
      $valw->configure('-choices' => $net_choices,
                       '-textvariable' => $orig_ref,
                      );
    } else {
      if (defined($val)) {
        $valw->configure('-text' => $val);
      } else {
        $valw->delete('0', 'end');
      }
146
    }
147
    $valw->validate();
148
  }
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173

  ##############
  # FIUs panel #
  ##############

  my $parent = $fr_fius->parent();
  $parent->packForget(); # This and the next line would be redundant if
  $fr_fius->destroy();   # the $parent->destroy() call would work.
  $self->_add_fiu_frame($parent->parent());
  # The code line below creates a segfault. It should delete all children
  # of the parent frame of fr_fius.
  # $parent->destroy();
  # FIXME: Without this we have an obvious memory leak

  # An alternative solution is apparently to start destroying higher up
  # in the stack. This does not cause a segfault (but some more flickering).
  #             fr_fius<-frame   <-pane    <-frame   <-frame1  <-border  <-labframe1<-self
  # my $parent = $fr_fius->parent()->parent()->parent()->parent()->parent()->parent();
  # $self->_add_fiu_panel($parent->parent());
  # $parent->destroy();

  $fr_fius->gridColumnconfigure(1, -weight => 1);

  my $i = 1;
  my $hdr_row = 0;
174
  foreach my $hdr ("Net Name", "Fault Model", "LFSR Mask") {
175
176
177
178
179
180
181
182
183
184
185
186
    $fr_fius->Label(
      -text => $hdr,
    )->grid(
      '-row' => $hdr_row,
      '-column' => $i++,
    );
  }
  $fr_fius->Label(
    -text => "Control",
  )->grid(
    '-row' => $hdr_row,
    '-column' => $i++,
187
    # '-columnspan' => 2,
188
189
  );

190
  my $fiu_cnt = $self->_fiu_cnt();
191
  for (my $i = 0; $i < $fiu_cnt; $i++) {
192
    my $fiu_ref = @{$self->{'settings'}->{'FIUs'}}[$i];
193
    $self->_add_fiu($fiu_ref, $i);
194
195
196
  }
}

197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
  
## @method _populate_widget()
# Creates, aranges and binds all widgets
#
sub _populate_widget {
  my $logger = get_logger();
  my ($self, $fr) = @_;

  $fr->DynaMouseWheelBind('Tk::Pane');
  ################
  # design panel #
  ################
  $fr_design = $fr->LabFrame(
    -label => "Design Constants",
    -labelside => "acrosstop"
  )->pack(
    '-side' => 'top',
    '-anchor' => 'nw',
    '-fill' => 'x'
  );
217
218
  $fr_design->gridColumnconfigure(2, '-weight' => 1);
  
219
  my $i = 0;
220
221
222
223
224
225
226
227
228
  foreach my $hdr (qw(Name Unit Value)) {
    $fr_design->Label(
      -text => $hdr,
    )->grid(
      '-row' => 0,
      '-column' => $i++,
    );
  }

229
  my @filter_keys = ('FIU_NUM', 'FIU_CFG_BITS', 'ID'); # we don't want to show these
230
231
  my $dm_ref = DESIGNMAP; # Work around Perl limitation: use constant <hash> and dereferencing does not play well together
  my @keys = map { my $foo = $_; scalar(grep(/$foo/, @filter_keys)) == 0 ? ($_) : ()  } sort(keys(%{$dm_ref}));
232

Stefan Tauner's avatar
Stefan Tauner committed
233
  my $entry;
234
  my $row = 0;
235
  my $net_choices = defined($self->{'nets'}) ? $self->{'nets'} : [];
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
  foreach my $k (@keys) {
    $row++;
    # label
    my $label = $fr_design->Label(
      '-text' => DESIGNMAP->{$k}->{'ini_name'},
      '-justify' => 'left',
    );
    $label->grid(-row => $row, -column => 0,
      '-sticky' => 'w'
    );
    # unit
    my $unit = $fr_design->Label(
      '-text' => DESIGNMAP->{$k}->{'unit'},
    );
    $unit->grid(-row => $row, -column => 1,
      '-ipadx' => 5,
      '-sticky' => 'ew',
    );
    # entry
    my $type = DESIGNMAP->{$k}->{'type'};
256
257
258
259
260
261
262
263
    if (defined($type) && $type eq 'net') {
      $entry = $fr_design->CompleteEntry(
      );
      $entry->configure(
        '-validate' => 'key',
        '-validatecommand' => [\&_validate_net_entry, $self, $entry, $k],
      );
    } else {
264
      $entry = $fr_design->Entry();
265
266
267
268
269
      $entry->configure(
        '-validate' => 'key',
        '-validatecommand' => [\&_validate_design_entry, $self, $entry, $k],
      );
    }
270
    $entry->grid(-row => $row, -column => 2,
271
272
      '-sticky' => 'ew'
    );
Stefan Tauner's avatar
Stefan Tauner committed
273
274
275
276
277
278
279
280
281
282
283
284
285
    $entry->bind('<Control-a>',
      sub {
        my $w = shift;
        $w->selectionRange(0,'end');
        $w->icursor('end');
      },
    );
    # $entry->bind('<KeyRelease>',
      # sub {
        # my $entry_var = ${$entry->cget('-textvariable')};
        # $self->_highlight_widget($entry, (FIJI::Settings::validate_design_value($k, \$entry_var)));
      # }
    # );
286
287
288
289
290
291
292
293
294
    # $fr_design->Button(
      # -text    => 'Defaults',
      # -command => [\&_save, $self],
      # sub {
        # my $state = defined($filename) ? 'normal' : 'disabled';
        # $btn_open->configure(-state => $state);
        # $btn_save->configure(-state => $state);
      # },
    # ),
295
  }
Stefan Tauner's avatar
Stefan Tauner committed
296
  $widget_background = $entry->cget('-bg');
297
298
299
300

  ##############
  # FIUs panel #
  ##############
301
302
303
  $self->_add_fiu_panel($fr);
}

Stefan Tauner's avatar
Stefan Tauner committed
304

305
306
307
sub _add_fiu_panel {
  my($self, $fr) = @_;

308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
  my $fr_fius_main = $fr->LabFrame(
    -label => "FIUs",
    -labelside => "acrosstop"
  )->pack(
    '-expand' => 1,
    '-side' => 'top',
    '-anchor' => 'nw',
    '-fill' => 'both'
  );

  $fr_fius_main->Button(
    -text    => 'Append empty FIU',
    -command => [\&_add_fiu, $self],
  )->pack(
    '-side' => 'top',
    '-anchor' => 'nw',
  );

  # Make the grid containing the FIUs scrollable (with the help of DynaMouseWheelBind)
  my $fr_fius_scroll = $fr_fius_main->Scrolled(
    'Pane',
    '-scrollbars'  => 'osre',
    '-sticky' => 'nwse',
  );
  $fr_fius_scroll->pack(
    '-expand' => 1,
    '-fill' => 'both',
    '-anchor' => 'nw',
    '-side' => 'top',
  );
338
339
  $self->_add_fiu_frame($fr_fius_scroll);
}
340

341

342
343
344
sub _add_fiu_frame {
  my($self, $parent) = @_;
  $fr_fius = $parent->Frame()->pack(
345
346
347
348
349
350
351
352
353
    '-fill' => 'both',
    '-side' => 'top',
    '-anchor' => 'nw',
  );
}


sub _fiu_cnt {
  my($self) = @_;
354
  my $fius = $self->{'settings'}->{'FIUs'};
355
356
357
358
  return (defined($fius) && ref($fius) eq 'ARRAY') ? scalar(@{$fius}) : 0;
}


359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
sub get_fiu_dimensions {
  my $scrolled = $fr_fius->parent()->parent()->parent();
  my $h = $fr_fius->height() + $scrolled->Subwidget('xscrollbar')->cget('width');
  my $w = $fr_fius->width() + $scrolled->Subwidget('yscrollbar')->cget('width');
  return ($w, $h);
}


sub append_fiu ($) {
  my($self, $fiu) = @_;
  $self->_add_fiu($fiu);
}


sub remove_fiu ($) {
  my($self, $i) = @_;
  $i = 0 if !defined($i);
376
  splice(@{$self->{'settings'}->{'FIUs'}}, $i, 1);
377
378
379
  $self->update();
}

380
sub _add_fiu ($$) {
381
  my($self, $fiu, $i) = @_;
382
383
384
385
  if (!defined($i)) {
    $i = $self->_fiu_cnt(); # default is to append
  }
  if (!defined($fiu)) {
386
387
    my %tmp_hash = (); # default is to add a new/empty FIU
    $fiu = \%tmp_hash;
388
389
    $self->{'settings'}->set_fiu_defaults($fiu);
    push(@{$self->{'settings'}->{'FIUs'}}, $fiu);
390
  }
391

392
393
  # forward declarations of widgets used in callbacks:
  # currently none...
Stefan Tauner's avatar
Stefan Tauner committed
394

395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
  my $lbl = $fr_fius->Label(
    '-text' => "FIU$i",
  );

  my $choices = defined($self->{'nets'}) ? $self->{'nets'} : [];
  my $net_entry = $fr_fius->CompleteEntry(
    '-textvariable' => \$fiu->{'FIU_NET_NAME'},
    '-choices' => $choices,
  );
  $net_entry->configure(
    '-validate' => 'key',
    '-validatecommand' => [\&_validate_net_entry, $self, $net_entry, "FIU$i"],
  );
  $net_entry->bind('<Control-a>',
    sub {
      my $w = shift;
      $w->selectionRange(0,'end');
      $w->icursor('end');
    },
  );

  my $model_menu = $fr_fius->Optionmenu(
    '-options' => FIU_MODEL->{'values'},
    '-width' => -1,
    '-variable' => \$fiu->{'FIU_MODEL'},
  # Doesn't help anyway... most of the time!? wtf m(
  # )->pack(
    # '-side' => 'left',
    # '-expand' => 1,
  );
  
426
427
428
429
  my $mask_entry = $fr_fius->Entry(
    '-width' => -1,
    '-justify' => 'right',
  );
Stefan Tauner's avatar
Stefan Tauner committed
430
431
432
  $mask_entry->configure('-text' => sprintf("0x%x", $fiu->{'FIU_LFSR_MASK'}));
  $mask_entry->configure(
    '-validate' => 'key',
433
    '-validatecommand' => [\&_validate_fiu_entry, $self, $mask_entry, 'FIU_LFSR_MASK', $i],
Stefan Tauner's avatar
Stefan Tauner committed
434
435
436
437
438
439
440
441
442
  );
  $mask_entry->bind('<Control-a>',
    sub {
      my $w = shift;
      $w->selectionRange(0,'end');
      $w->icursor('end');
    },
  );

443
444
445
446
447
448
449
450
  # my $so_entry = $fr_fius->Entry(
    # '-width' => -1,
    # '-justify' => 'center',
  # );
  # $so_entry->{'fiji_backend_ref'} = \$fiu->{'FIU_LFSR_STUCK_OPEN_BIT'};
  # $so_entry->configure('-text' => $fiu->{'FIU_LFSR_STUCK_OPEN_BIT'});
  # $so_entry->configure(
    # '-validate' => 'key',
451
    # '-validatecommand' => [\&_validate_fiu_entry, $self, $so_entry, 'FIU_LFSR_STUCK_OPEN_BIT', $i],
452
453
454
455
456
457
458
459
460
  # );
  # $so_entry->bind('<Control-a>',
    # sub {
      # my $w = shift;
      # $w->selectionRange(0,'end');
      # $w->icursor('end');
    # },
  # );

Stefan Tauner's avatar
Stefan Tauner committed
461
462
463
464
465
466
467
  # $so_entry->bind('<KeyRelease>',
    # sub {
      # my $entry_var = ${$so_entry->cget('-textvariable')};
      # $self->_highlight_widget($so_entry, (FIJI::Settings::validate_fiu_value('FIU_LFSR_STUCK_OPEN_BIT', \$entry_var)));
    # }
  # );

468
469
  # my $def_button = $fr_fius->Button(
    # '-text'    => 'Defaults',
470
    # -command => [\&_save, $self],
471
  # );
472
473
  my $del_button = $fr_fius->Button(
    -text    => 'Delete',
474
    -command => [\&remove_fiu, $self, $i],
475
  );
476
  $model_menu->configure(
Stefan Tauner's avatar
Stefan Tauner committed
477
    '-command' => sub {
478
479
480
481
482
483
484
      my $logger = get_logger();
      my $model = shift;
      $logger->trace("model is now: $model");
      $self->_update_fields(
        $lbl,
        $net_entry,
        $model_menu,
485
        # $lfsr_button,
486
        $mask_entry,
487
        # $so_entry,
488
        # $def_button,
489
490
491
492
        $del_button,
      );
    }
  );
493
494
495
496
  # $lfsr_button->configure(
    # '-variable' => \$fiu->{'FIU_LFSR_EN'},
    # '-command' => [\&_set_fields_by_button, $self, $lfsr_button, $mask_entry ],
  # );
Stefan Tauner's avatar
Stefan Tauner committed
497

498
  Tk::grid(
499
500
501
    $lbl,
    $net_entry,
    $model_menu,
502
    # $lfsr_button,
503
    $mask_entry,
504
    # $so_entry,
505
    # $def_button,
506
    $del_button,
507
508
    '-sticky' => 'ew'
  );
509
510
511
512
  $self->_update_fields(
    $lbl,
    $net_entry,
    $model_menu,
513
    # $lfsr_button,
514
    $mask_entry,
515
    # $so_entry,
516
    # $def_button,
517
518
519
520
    $del_button,
  );
}

Stefan Tauner's avatar
Stefan Tauner committed
521

522
523
524
525
526
sub _update_fields {
  my($self,
    $lbl,
    $net_entry,
    $model_menu,
527
    # $lfsr_button,
528
    $mask_entry,
529
    # $so_entry,
530
    # $def_button,
531
532
533
534
535
536
537
    $del_button,
  ) = @_;
  my $logger = get_logger();

  my $model = ${$model_menu->cget('-variable')};
  if ($model eq 'RUNTIME' ||
      $model eq 'STUCK_OPEN') {
538
539
540
    $self->_set_fields(1, $mask_entry);
  } elsif ($model eq 'PASS_THRU' ||
           $model eq 'STUCK_AT_0' ||
541
542
543
           $model eq 'STUCK_AT_1' ||
           $model eq 'DELAY' ||
           $model eq 'SEU') {
544
    $self->_set_fields(0, $mask_entry);
545
546
547
  } else {
    $logger->error("Unknown model selected: $model");
  }
548
549
  $net_entry->validate();
  $mask_entry->validate();
550
551
}

552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570

sub _set_fields_by_button {
  my($self, $button, @fields) = @_;
  $self->_set_fields(${$button->cget('-variable')}, @fields);
}


sub _set_fields {
  my($self, $bool, @fields) = @_;
  my $logger = get_logger();
  foreach my $f (@fields) {
    if ($bool) {
      $f->configure('-state' => 'normal');
    } else {
      $f->configure('-state' => 'disabled');
    }
  }
}

Stefan Tauner's avatar
Stefan Tauner committed
571

572
573
574
575
576
577
578
579
sub _validate_net {
  my ($self, $widget, $name, $new) = @_;
  my $logger = get_logger();
  if (!defined($self->{'nets'})) {
    return 1;
  }
  my $complete_matches = grep(/^$new$/, @{$self->{'nets'}});
  my $prefix_matches = grep(/^$new/, @{$self->{'nets'}});
580
581
  $logger->trace("'$new' matches $complete_matches nets completely and is a prefix of $prefix_matches");
  return $complete_matches == 1;# || $prefix_matches > 0;
582
583
584
585
}


sub _validate_net_entry {
586
587
588
589
590
  my ($self, $widget, $name, $new) = @_;
  my $ok = $self->_validate_net($widget, $name, $new);
  _highlight_widget($widget, (!$ok));
  # $widget->configure('-validate' => 'key');
  return 1; # always allow the new value and show the user what happened.
591
592
593
}


Stefan Tauner's avatar
Stefan Tauner committed
594
sub _validate_design_entry {
595
596
597
598
599
600
  my $self = shift;
  my $widget = shift;
  my $name = shift;
  my $new_ref = \shift;
  my $old_ref = \$self->{'settings'}->{'design'}->{$name};
  return _validate_entry(DESIGNMAP, $self, $widget, $name, $old_ref, $new_ref, @_);
Stefan Tauner's avatar
Stefan Tauner committed
601
602
603
604
}


sub _validate_fiu_entry {
605
606
607
608
609
610
611
  my $self = shift;
  my $widget = shift;
  my $name = shift;
  my $i = shift;
  my $new_ref = \shift;
  my $old_ref = \@{$self->{'settings'}->{'FIUs'}}[$i]->{$name};
  return _validate_entry(FIUMAP, $self, $widget, $name, $old_ref, $new_ref, @_);
Stefan Tauner's avatar
Stefan Tauner committed
612
613
614
615
}


sub _validate_entry {
616
617
  my ($map, $self, $widget, $name, $old_ref, $new_ref, $diff, $old_str, $char_idx, $brokentype) = @_;
  my $ok = FIJI::Settings::validate_value($map, $name, $new_ref, $$old_ref);
618
  _highlight_widget($widget, (!$ok));
619
620
621
622
  # The following line is needed to re-enable validation IFF the value is
  # changed via -textvariable or insert().
  # $widget->configure('-validate' => 'key');
  
623
  if ($ok) {
624
    $$old_ref = $$new_ref;
625
626
  }
  return 1; # always allow the new value and show the user what happened.
Stefan Tauner's avatar
Stefan Tauner committed
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
}


sub _highlight_widget ($$) {
  my($widget, $enable) = @_;
  if ($enable) {
    $widget->configure('-bg' => 'orange red');
  } else {
    # the 3rd element returned for '-bg' is the default background, usually.
    # Apparently it is something darker on Linux so the following does
    # not work as intended. :(
    # $widget->configure('-bg' => ($widget->configure('-bg'))[3]);
    # Work around: store the entry background color at creation time and
    # use that instead.
    $widget->configure('-bg' => $widget_background);
  }
}

645
1;