FIJITestsViewer.pm 53.8 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
#-------------------------------------------------------------------------------
#  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 Tests Viewer class
#-------------------------------------------------------------------------------

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

## @class Tk::FIJITestsViewer
19
# @brief Tk Widget allowing to view and edit FIJI::Tests settings
Christian Fibich's avatar
Christian Fibich committed
20
21
22
23
24
25
package Tk::FIJITestsViewer;

use strict;
use warnings;
use utf8;

26
27
28
29
30
31
32
# Not actually used within here directly but as the base for a custom
# Log::Log4perl::Appender. This use statement guarantees that the user
# sees some useful errors because Tk apparently swallows the messages
# and just kills itself/the main window/your dearest pet if there is a
# fatal error in Populate() (or its children).
use Log::Dispatch::QueueAppender;

Christian Fibich's avatar
Christian Fibich committed
33
34
use Log::Log4perl qw(get_logger);
use Scalar::Util 'blessed';
Christian Fibich's avatar
Christian Fibich committed
35
use Time::HiRes qw(time);
36
use Clone qw(clone);
Christian Fibich's avatar
Christian Fibich committed
37

Christian Fibich's avatar
Christian Fibich committed
38
39
use threads;
use threads::shared;
Christian Fibich's avatar
Christian Fibich committed
40
41
42

use FIJI qw(:all);

Christian Fibich's avatar
Christian Fibich committed
43
use Tk;
Christian Fibich's avatar
Christian Fibich committed
44
use Tk::Adjuster;
45
use Tk::widgets qw(LabFrame ROText Balloon Label Entry Pane Button DialogBox Checkbutton CompleteEntry StatusBar NoteBook);
Christian Fibich's avatar
Christian Fibich committed
46
use Tk::FIJITestFrame;
47
use Tk::FIJIModalDialog;
48
use Tk::FIJIUtils;
Christian Fibich's avatar
Christian Fibich committed
49
use base qw(Tk::Frame);
Christian Fibich's avatar
Christian Fibich committed
50

51
52
53
54
55
56
57
58
59
60
61

# 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;

Christian Fibich's avatar
Christian Fibich committed
62
63
Construct Tk::Widget 'FIJITestsViewer';

Christian Fibich's avatar
Christian Fibich committed
64
65
66
67
68
# Constants

use constant {
    FAILEDCOLOR => "red",
    OKCOLOR     => "ForestGreen",
69
70
};

Christian Fibich's avatar
Christian Fibich committed
71
72
73
74
75
use constant LOG4P_FONTS => {
    WARN  => "Courier 9 bold",
    ERROR => "Courier 9 bold",
    FATAL => "Courier 10 bold",
    DEBUG => "Courier 9 italic",
76
77
};

Christian Fibich's avatar
Christian Fibich committed
78
79
80
81
82
83
84
85
86
use constant LOG4P_COLORS => {
    TRACE => "black",
    DEBUG => "black",
    ERROR => "red",
    FATAL => "red",
    WARN  => "orange red",
    INFO  => "dark blue",
};

87
88
89
90
91
92
use constant RMSG_ERROR_STRINGS => {
    U => "UART framing error. Check connection & baud rate.",
    I => "Design ID mismatch. Check if the correct bitstream is programmed.",
    C => "CRC error. Check connection & baud rate.",
};

Christian Fibich's avatar
Christian Fibich committed
93
94
95
## @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
96
my $widget_background;
Christian Fibich's avatar
Christian Fibich committed
97
98

sub ClassInit {
Christian Fibich's avatar
Christian Fibich committed
99
    my ($class, $mw) = @_;
100
    $class->SUPER::ClassInit($mw);
Christian Fibich's avatar
Christian Fibich committed
101

102
103
104
    my $self = bless {}, $class;
    return $self;
}
Christian Fibich's avatar
Christian Fibich committed
105
106

sub Populate {
107
    my $logger = get_logger("");
Christian Fibich's avatar
Christian Fibich committed
108
    my ($self, $args) = @_;
109
110
    my $settings = delete $args->{'-settings'};
    my $tests    = delete $args->{'-tests'};
Christian Fibich's avatar
Christian Fibich committed
111
    $self->{'changes_callback'}  = delete $args->{'-changes_callback'};
112
    $self->{'test_callback'}     = delete $args->{'-test_callback'};
113
    $self->{'mw'}                = delete $args->{'-mw'};
114
115
116
    $self->{'worker'}            = delete $args->{'-worker'};
    $self->{'queue_to_worker'}   = delete $args->{'-queue_to_worker'};
    $self->{'queue_from_worker'} = delete $args->{'-queue_from_worker'};
117
    $self->{'log_queue'}         = delete $args->{'-log_queue'};
118
    $self->{'loglevel'}          = delete $args->{'-loglevel'};
119

Christian Fibich's avatar
Christian Fibich committed
120
    if (!defined($settings) || !blessed($settings) || !$settings->isa("FIJI::Settings")) {
121
        $logger->error("No or invalid settings given.");
122
        return;
Christian Fibich's avatar
Christian Fibich committed
123
    }
124

125
126
    $self->{'settings'} = $settings;

Christian Fibich's avatar
Christian Fibich committed
127
    if (!defined($tests) || !blessed($tests) || !$tests->isa("FIJI::Tests")) {
128
        $logger->error("No or invalid tests given.");
129
        return;
130
    }
131

132
133
    $self->{'widget_states'} = {};

134
135
136
    $self->{'tests'}      = $tests;
    $self->{'manualtest'} = {};
    $self->{'tests'}->set_test_defaults($self->{'manualtest'});
137

138
139
140
141
    if (ref($self->{'tests'}->{'tests'}) ne 'ARRAY') {
        $logger->debug("Adding empty tests array to tests reference.");
        $self->{'tests'}->{'tests'} = [];
    }
142

143
144
145
146
147
    $self->{'original_tests'} = clone($tests);
    $self->{'original_tests'}->{'tests'} = clone($tests->{'tests'});
    $self->traceVariable($self->{'tests'}->{'design'}, 'w' => [\&_watch_settings, $self]);
    $self->traceVariable($self->{'tests'}->{'tests'},  'w' => [\&_watch_settings, $self]);
    $self->{'Downloader'} = FIJI::Downloader->new(undef, undef, $self->{'tests'}, undef, $self->{'settings'});
148
149
150
151

    $self->SUPER::Populate($args);
    $self->_populate_widget($self);
    $self->update();
Christian Fibich's avatar
Christian Fibich committed
152
153
154
}

sub tests {
155
    my $logger = get_logger("");
Christian Fibich's avatar
Christian Fibich committed
156
157
158
    my ($self, $tests) = @_;
    if (defined($tests)) {
        if (!blessed($tests) || !$tests->isa("FIJI::Tests")) {
159
160
161
162
163
            $logger->error("Given tests are not of type FIJI::Tests.");
            return undef;
        }
        $self->{'tests'}      = $tests;
        $self->{'manualtest'} = {};
Christian Fibich's avatar
Christian Fibich committed
164
        $self->{'tests'}->set_test_defaults($self->{'manualtest'});
165
166
        $self->{'original_tests'} = clone($self->{'tests'});
        $self->{'original_tests'}->{'tests'} = clone($self->{'tests'}->{'tests'});
Christian Fibich's avatar
Christian Fibich committed
167
168
        $self->traceVariable($self->{'tests'}->{'design'}, 'w' => [\&_watch_settings, $self]);
        $self->traceVariable($self->{'tests'}->{'tests'},  'w' => [\&_watch_settings, $self]);
169
        $self->{'Downloader'} = FIJI::Downloader->new(undef,undef, $self->{'tests'}, undef, $self->{'settings'});
170
        $self->update();
Christian Fibich's avatar
Christian Fibich committed
171
    }
172
    return $self->{'tests'};
Christian Fibich's avatar
Christian Fibich committed
173
174
}

175
176
177
## @method private _start_test
# @brief downloads FIJI test(s) according to the mode currently selected
# The currently selected mode is read from the raised tab in the central notebook
Christian Fibich's avatar
Christian Fibich committed
178
sub _start_test {
179
    my $self         = shift;
180
    my $current_page = $self->{'notebook'}->raised();
Christian Fibich's avatar
Christian Fibich committed
181

182
183
184
185
186
    my $cfg = {
        mode       => $current_page,
        uart       => $self->{'tests'}->{'design'}->{'UART'},
        downloader => $self->{'Downloader'}
    };
Christian Fibich's avatar
Christian Fibich committed
187

Christian Fibich's avatar
Christian Fibich committed
188
    if ($current_page eq "manual") {
Christian Fibich's avatar
Christian Fibich committed
189
190
191
192
193
194
        $cfg->{'test'} = $self->{'manualtest'};
    }

    $self->_download($cfg);
}

195
196
197
198
## @method private _update_fiji_status ()
# @brief Tries to get current status of FIJI logic
# downloads an empty test (no fault, no duration, no trigger, no reset) to
# determine the status of the FIJI hardware
Christian Fibich's avatar
Christian Fibich committed
199
200
201
202
#
sub _update_fiji_status {
    my $self = shift;

203
    my $cfg = {
204
        mode       => "dryrun",
205
206
207
        uart       => $self->{'tests'}->{'design'}->{'UART'},
        downloader => $self->{'Downloader'},
    };
Christian Fibich's avatar
Christian Fibich committed
208
209
210
211

    $self->_download($cfg);
}

212
213
214
## @method private _download ($cfg)
# @brief sends tests to the worker thread
#
Christian Fibich's avatar
Christian Fibich committed
215
216
# posts a new work package to the worker
# waits for response messages until a 'finished' message is encountered
Christian Fibich's avatar
Christian Fibich committed
217
#
218
# @param cfg    a hash describing the current test
Christian Fibich's avatar
Christian Fibich committed
219
220
#
sub _download {
221
    my $logger = get_logger("");
Christian Fibich's avatar
Christian Fibich committed
222
    my ($self, $cfg) = @_;
Christian Fibich's avatar
Christian Fibich committed
223

224
225
    Tk::FIJIUtils::disable_all_widgets($self->MainWindow(), $self->{'widget_states'});

226
227
228
    $self->{'update_button'}->configure(-state => "disabled");
    $self->{'stop_button'}->configure(-state => "normal");
    $self->{'start_button'}->configure(-state => "disabled");
Christian Fibich's avatar
Christian Fibich committed
229
230
231

    $self->{'queue_to_worker'}->enqueue($cfg);

Stefan Tauner's avatar
Stefan Tauner committed
232
    $self->{'starttime'} = time;
233

234
    # start timer to update the test 'uptime' periodically
Christian Fibich's avatar
Christian Fibich committed
235
    my $timer = $self->repeat(100, [\&_update_timer, $self, "Running"]);
Christian Fibich's avatar
Christian Fibich committed
236

237
    my $worker_msg;
238
    my $downloader_reply;
Christian Fibich's avatar
Christian Fibich committed
239
    do {
240
241
        # try to read a new message from the queue
        # if no message arrives within 0.01s, process the GUI
242
        while (!defined($worker_msg = $self->{'queue_from_worker'}->dequeue_timed(0.01))) {
Christian Fibich's avatar
Christian Fibich committed
243
244
            $self->toplevel->update();
        }
Christian Fibich's avatar
Christian Fibich committed
245

246
247
        $downloader_reply = $worker_msg->{'rmsg'};

248
        if ($worker_msg->{'state'} eq "dying") {
249
            my $d = $self->{'mw'}->FIJIModalDialog(-image      => Tk::FIJIUtils::error_image($self->{'mw'}),
250
                                                   -wraplength => "400",
251
                                                   -text       => $downloader_reply,
252
                                                   -title      => 'Download worker thread died!',);
253
254
255
256
257
            $d->Show();
            # FIXME: convey this error to the main thread instead of simply closing the GUI
            $self->{'mw'}->destroy();
        }

258
        # process message
259
        if (defined $downloader_reply && ref $downloader_reply eq "HASH") {
260
            $self->_update_rmsg_status($downloader_reply) if not $downloader_reply->{'aborted'};
Christian Fibich's avatar
Christian Fibich committed
261
        } else {
262
            $self->{'msg_type'}->configure(-text => $downloader_reply, -bg => "red");
Christian Fibich's avatar
Christian Fibich committed
263
        }
264
        $self->toplevel->update();
265
    } while ($worker_msg->{'state'} ne "finished");
Christian Fibich's avatar
Christian Fibich committed
266
267
268
269

    $self->afterCancel($timer);
    $self->_update_timer("Run duration");

270
271
272
273
274
275
276
277
278
279
280
    FIJI::Utils::execute_completion_script(
        $self->{'tests'}->{'design'}->{'COMPLETION_SCRIPT'},
        $self->{'tests'}->{'filename'},
        $downloader_reply,
        $self->{'starttime'},
        time,
        $worker_msg->{'testref'},
        $self->{'logbox'}->Contents(),
    ) if (($cfg->{'mode'} ne 'dryrun') && ($cfg->{'mode'} ne 'manual'));

    # if a valid return message has beeen received from the FIC
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
    if (defined $downloader_reply && ref $downloader_reply eq "HASH" ) {
        if (not $downloader_reply->{'aborted'}) {
            my $rmsg_error_strings = RMSG_ERROR_STRINGS;
            # if errors were reported, display error messages accordingly
            if ($downloader_reply->{'error'}->{'ANY'}) {
                my $text = "FIJI Hardware reported error(s):\n";
                for my $k (keys(%{$rmsg_error_strings})) {
                    $text .= RMSG_ERROR_STRINGS->{$k} . "\n" if $downloader_reply->{'error'}->{$k};
                }

                my $d = $self->{'mw'}->FIJIModalDialog(-image       => Tk::FIJIUtils::error_image($self->{'mw'}),
                                                       -text        => $text,
                                                       -title       => "Error while downloading.",);

                $d->Show();
296
297
            }
        }
298
299
300
301
302
        # if the message contained a valid reference to executed tests
        if (defined $worker_msg->{'testref'} && blessed($worker_msg->{'testref'}) && $worker_msg->{'testref'}->isa("FIJI::Tests")) {
            $self->{'last_test'} = clone($worker_msg->{'testref'});
            # execute the callback in the parent
            $self->{'test_callback'}->(1);
303
304
        } else {
            $self->{'last_test'} = undef;
305
306
307
            # In case we got actively aborted do not report an error to the callback
            my $state = $downloader_reply->{'aborted'} ? 1 : 0;
            $self->{'test_callback'}->($state);
308
        }
309
310
311
    } else {
        $self->{'last_test'} = undef;
        $self->{'test_callback'}->(0);
312
313
    }

314
315
    Tk::FIJIUtils::reenable_all_widgets($self->MainWindow(), $self->{'widget_states'});

316
317
318
319
    # update button state
    $self->{'update_button'}->configure(-state => "normal");
    $self->{'stop_button'}->configure(-state => "disabled", -text => "Stop");
    $self->{'start_button'}->configure(-state => "normal");
Christian Fibich's avatar
Christian Fibich committed
320
321
}

322
323
324
325
326
sub get_last_test {
    my $logger = get_logger("");
    my $self = shift;
    my $lt;
    if (!defined $self->{'last_test'}) {
327
        my $msg = "Could not determine last test case.";
328
        $logger->error($msg);
Stefan Tauner's avatar
Stefan Tauner committed
329
        my $d = $self->{'mw'}->FIJIModalDialog(-image      => Tk::FIJIUtils::error_image($self->{'mw'}),
330
331
                                               -wraplength => "200",
                                               -text       => $msg,
332
                                               -title      => 'Export failed!',);
333
334
335
336
337
338
339
        $d->Show();
    } else {
        $lt = $self->{'last_test'};
    }
    return $lt;
}

340
341
342
343
## @method private _update_logging_box ()
# @brief Reads log messages from the internal logging queue and appends them
#        to the logging ROText widget
sub _update_logging_box {
Christian Fibich's avatar
Christian Fibich committed
344
    my $logger = get_logger("");
345
346
    my $self = shift;
    my $msg;
Christian Fibich's avatar
Christian Fibich committed
347
    while (defined($msg = $self->{'log_queue'}->dequeue_timed(0))) {
Christian Fibich's avatar
Christian Fibich committed
348
349
350
        if (defined $msg->{'clear'}) {
            $self->{'logbox'}->delete('0.0','end');
            $logger->info('Log messages cleared');
351
        } else {
Christian Fibich's avatar
Christian Fibich committed
352
353
354
355
356
357
            if (defined $msg->{'log4p_level'}) {
                $self->{'logbox'}->insert('end', $msg->{'message'}, [$msg->{'log4p_level'}]);
            } else {
                $self->{'logbox'}->insert('end', $msg->{'message'});
            }
            $self->{'logbox'}->yview('end');
358
359
360
361
362
363
        }
    }
}

## @method private _update_timer ()
# @brief updates the 'duration' widget with the current test 'uptime'
Christian Fibich's avatar
Christian Fibich committed
364
sub _update_timer {
Christian Fibich's avatar
Christian Fibich committed
365
    my ($self, $state) = @_;
Christian Fibich's avatar
Christian Fibich committed
366

Stefan Tauner's avatar
Stefan Tauner committed
367
    my $d = (time - $self->{'starttime'});
Christian Fibich's avatar
Christian Fibich committed
368
    my $m = int($d / 60);
369
370
    my $s = $d - $m * 60;

Christian Fibich's avatar
Christian Fibich committed
371
    $self->{'duration'}->configure(-text => sprintf("$state: %dm %02.3fs", $m, $s), -bg => $widget_background);
Christian Fibich's avatar
Christian Fibich committed
372
373
}

374
375
## @method private _stop_test ()
# @brief just sends a SIGKILL to the worker thread
Christian Fibich's avatar
Christian Fibich committed
376
377
sub _stop_test {
    my $self = shift;
378
    $self->{'stop_button'}->configure(-state => "disabled", -text => "Stopping");
Christian Fibich's avatar
Christian Fibich committed
379
    $self->{'worker'}->kill('STOP');
Christian Fibich's avatar
Christian Fibich committed
380
381
}

382
383
384
## @method private _update_rmsg_status (%$rmsg)
# @brief updates the error state widgets according to %$rmsg
# @param rmsg a reference to a hash containing the decoded return message
Christian Fibich's avatar
Christian Fibich committed
385
sub _update_rmsg_status {
386
    my $logger = get_logger("");
Christian Fibich's avatar
Christian Fibich committed
387
    my ($self, $rmsg) = @_;
388
389
390
    $self->{'uart_status'}->configure(-bg => ($rmsg->{'error'}->{'U'}) ? FAILEDCOLOR : OKCOLOR);
    $self->{'id_status'}->configure(-bg => ($rmsg->{'error'}->{'I'}) ? FAILEDCOLOR : OKCOLOR);
    $self->{'crc_status'}->configure(-bg => ($rmsg->{'error'}->{'C'}) ? FAILEDCOLOR : OKCOLOR);
391
392
    $self->{'fault_detect_1'}->configure(-bg => ($rmsg->{'fault_detect'}->{'1'}) ? FAILEDCOLOR : OKCOLOR) if ($self->{'settings'}->{'design'}->{'FD_1_EN'} == 1);
    $self->{'fault_detect_2'}->configure(-bg => ($rmsg->{'fault_detect'}->{'2'}) ? FAILEDCOLOR : OKCOLOR) if ($self->{'settings'}->{'design'}->{'FD_2_EN'} == 1);
Christian Fibich's avatar
Christian Fibich committed
393
    $self->{'msg_type'}->configure(-text => $rmsg->{'msg_type'}, -bg => $widget_background);
Christian Fibich's avatar
Christian Fibich committed
394
395
}

396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
## @method _switchtab(nb, inc)
# Raises the tab $inc frames left ($inc < 0) or right ($inc > 0) of the
# currently selected tab of $nb
#
sub _switchtab {
    my ($dummy, $nb, $inc) = @_;
    my @pages        = $nb->pages();
    my $current_page = $nb->raised();
    my ($index) = grep { $pages[$_] eq $current_page } 0 .. (@pages - 1);
    my $next_page = $pages[$index + $inc];

    $nb->raise($next_page) if (($inc > 0 && defined $next_page)
        || ($inc < 0 && $index > 0));
}

411
412
413
## @method private _populate_widget ()
# @brief creates GUI elements of the FIJI Settings Viewer
# @returns 0
Christian Fibich's avatar
Christian Fibich committed
414
sub _populate_widget {
415
    my $logger = get_logger("");
Christian Fibich's avatar
Christian Fibich committed
416
    my $self   = shift;
417

418
    eval {
419
420
421
422
423
424
425
426
427
428
429
430
431
432
        # central control frame
        $self->{'fr_download'} = $self->Frame();

        $self->{'notebook'} = $self->{'fr_download'}->NoteBook();

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

        # bottom frame for control buttons
        $self->{'fr_buttons'} = $self->Frame(-borderwidth => 1, -relief => 'raised',)->pack(
            -side => "bottom",
            -fill => 'both',
        );
433
        my $balloon = $self->{'balloon'} = $self->Balloon();
434

Christian Fibich's avatar
Christian Fibich committed
435
436
437
438
439
        $self->{'clear_button'} = $self->{'fr_buttons'}->Button(
            -text    => "Clear Log",
            -command => sub {$self->{'log_queue'}->enqueue({clear=>1})} ,
            -underline => 0,
        );
440
        $self->MainWindow->bind("<Alt-c>" => [ $self->{'clear_button'}, 'Invoke']);
Christian Fibich's avatar
Christian Fibich committed
441
        $self->MainWindow->bind("<F4>" => [ $self->{'clear_button'}, 'Invoke']);
442
443
444
445
446
        $balloon->attach(
            $self->{'clear_button'},
            -balloonposition => 'mouse',
            -msg             => "Clear current log messages (F4)",
        );
Christian Fibich's avatar
Christian Fibich committed
447

448
449
450
        $self->{'update_button'} = $self->{'fr_buttons'}->Button(
            -text    => "Update",
            -command => [\&_update_fiji_status, $self],
451
452
            -state   => (defined $self->{'Downloader'}) ? "normal" : "disabled",
            -underline => 0,
453
        );
454
455
        $self->MainWindow->bind("<Alt-u>" => [ $self->{'update_button'}, 'Invoke']);
        $self->MainWindow->bind("<F5>" => [ $self->{'update_button'}, 'Invoke']);
456
457
458
459
460
461
        $balloon->attach(
            $self->{'update_button'},
            -balloonposition => 'mouse',
            -msg             => "Query hardware for current status (F5)",
        );

462

463
464
465
        $self->{'start_button'} = $self->{'fr_buttons'}->Button(
            -text    => "Start",
            -command => [\&_start_test, $self],
466
467
            -state   => (defined $self->{'Downloader'}) ? "normal" : "disabled",
            -underline => 0,
468
        );
469
470
        $self->MainWindow->bind("<Alt-s>" => [ $self->{'start_button'}, 'Invoke']);
        $self->MainWindow->bind("<F6>" => [ $self->{'start_button'}, 'Invoke']);
471
472
473
474
475
476
        $balloon->attach(
            $self->{'start_button'},
            -balloonposition => 'mouse',
            -msg             => "Start currently selected test(s) (F6)",
        );

477

478
479
480
        $self->{'stop_button'} = $self->{'fr_buttons'}->Button(
            -text    => "Stop",
            -command => [\&_stop_test, $self],
481
482
            -state   => "disabled",
            -underline => 3,
483
        );
484
485
        $self->MainWindow->bind("<Alt-p>" => [ $self->{'stop_button'}, 'Invoke']);
        $self->MainWindow->bind("<F7>" => [ $self->{'stop_button'}, 'Invoke']);
486
487
488
489
490
491
        $balloon->attach(
            $self->{'stop_button'},
            -balloonposition => 'mouse',
            -msg             => "Stop test(s) immediately (F7)",
        );

492
493
494
495

        $self->{'stop_button'}->pack(-side => "right");
        $self->{'start_button'}->pack(-side => "right");
        $self->{'update_button'}->pack(-side => "right");
Christian Fibich's avatar
Christian Fibich committed
496
        $self->{'clear_button'}->pack(-side => "right");
497
498
499
500
501
502
503

        # configure all the status labels so that they look like 'sunken-in' displays
        $self->{'fr_buttons'}->Label(-text => "Error:")->pack(-side => "left", -padx => 5);
        $self->{'uart_status'} = $self->{'fr_buttons'}->Label(-width => 2, -relief => "sunken", -borderwidth => "1", -text => "U", -bg => OKCOLOR)->pack(-side => "left");
        $self->{'id_status'} = $self->{'fr_buttons'}->Label(-width => 2, -relief => "sunken", -borderwidth => "1", -text => "I", -bg => OKCOLOR)->pack(-side => "left");
        $self->{'crc_status'} = $self->{'fr_buttons'}->Label(-width => 2, -relief => "sunken", -borderwidth => "1", -text => "C", -bg => OKCOLOR)->pack(-side => "left");
        $self->{'fr_buttons'}->Label(-text => "Fault Detect:")->pack(-side => "left", -padx => 5);
504
505
        for my $i (1..2) {
        my @fd_settings;
506
            if ($self->{'settings'}->{'design'}->{"FD_${i}_EN"} == 1) {
507
508
509
510
511
512
513
                push(@fd_settings, -state, "normal");
                push(@fd_settings, -bg, OKCOLOR);
            } else {
                push(@fd_settings, -state, "disabled");
            }
            $self->{"fault_detect_$i"} = $self->{'fr_buttons'}->Label(-width => 2, -relief => "sunken", -borderwidth => "1", -text => "$i", @fd_settings)->pack(-side => "left");
        }
514
515
516
        $self->{'msg_type'} = $self->{'fr_buttons'}->Label(-width => 22, -text => "FIJI status",  -borderwidth => "1", -relief => "sunken")->pack(-side => "left", -padx => 5);
        $self->{'duration'} = $self->{'fr_buttons'}->Label(-width => 22, -text => "Test runtime", -borderwidth => "1", -relief => "sunken")->pack(-side => "left", -padx => 5);

517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
        $balloon->attach(
            $self->{'uart_status'},
            -balloonposition => 'mouse',
            -msg             => "UART",
        );
        $balloon->attach(
            $self->{'id_status'},
            -balloonposition => 'mouse',
            -msg             => "Design ID",
        );
        $balloon->attach(
            $self->{'crc_status'},
            -balloonposition => 'mouse',
            -msg             => "CRC",
        );

533
        #--- Container for logging window
534
        my $text_scrolled = $self->ScrlROText(-scrollbars => "oe", -width => 80, -height => 10);
535
536
537
538

        $text_scrolled->pack(
            -fill   => 'both',
            -expand => 1,
539
            -side   => 'bottom',
540
541
        );

542
543
544
545
546
        #--- Adjuster bar between logging window container and notebook container
        my $adj = $self->Adjuster();
        $adj->packAfter($text_scrolled, -side=>'bottom');
        $self->{'fr_download'}->pack(-fill => "both", -expand => "1",-side=>'bottom');

547
548
549
550
551
552
553
554
555
556
557
558
559
560
        #---
        # Configure logging window
        #
        $self->{'logbox'} = $text_scrolled->Subwidget('scrolled');

        my $log4p_colors_ref = LOG4P_COLORS;
        my $log4p_fonts_ref  = LOG4P_FONTS;

        foreach my $k (keys(%{$log4p_colors_ref})) {
            $self->{'logbox'}->tagConfigure($k, -foreground => LOG4P_COLORS->{$k});
        }
        foreach my $k (keys(%{$log4p_fonts_ref})) {
            $self->{'logbox'}->tagConfigure($k, -font => LOG4P_FONTS->{$k});
        }
561

562
563
        # Append any messages from the logging queue to textbox periodically
        $self->repeat(100, [\&_update_logging_box, $self]);
564
565

        # also log to the log_queue
566
        append_logger($self->{'log_queue'}, $self->{'loglevel'});
567
        $logger->info("Live capturing of log output has started");
568
569
570
571
572
573
574
575
576
577

        #---
        # Test settings Notebook

        my $modes_ref       = TESTGUIMODES;
        my $tcm_ref         = TESTCONSTMAP;
        my @tcm_keys_sorted = sort { TESTCONSTMAP->{$a}->{'order'} <=> TESTCONSTMAP->{$b}->{'order'} } grep { defined TESTCONSTMAP->{$_}->{'order'} } keys(%{$tcm_ref});

        # fill the notebook with pages, one page for each test mode
        for my $mode (sort(keys(%{$modes_ref}))) {
578
            my $pg = $self->{'notebook'} ->add(
579
580
581
582
583
                $mode,
                -label    => TESTGUIMODES->{$mode}->{'title'},
                -raisecmd => [\&update, $self]
            );    # to sync changes from textbuttons in other
                  # tabs that also exist in this tab
584
585
586
587

            my $sp = $pg->Scrolled('Pane', '-scrollbars'=>'osoe', '-sticky'=>'nwse')->pack(-fill=>'both',-expand=>1);
            Tk::FIJIUtils::bind_mousewheel($sp->MainWindow,$sp);
            my $page =  $self->{'pages'}->{$mode} = $sp->Frame();
588
589
590
            $page->gridColumnconfigure(0, -weight => 0);
            $page->gridColumnconfigure(1, -weight => 0);
            $page->gridColumnconfigure(2, -weight => 1);
591

592
593
594
            my $row = 0;
            my $i   = 0;

595
596
597
            # calculate the height of all widgets combined to set the height of the pane
            my $total_height = 0;

598
599
            # fill the current page with widgets representing test settings
            for my $k (@tcm_keys_sorted) {
600
601
                next if (TESTCONSTMAP->{$k} eq UART);

602
                my $entry;
603
604
                # this variable will be filled with the tallest generated widget's reqheight
                my $widget_height;
605
606
607
608
609
610
611
612
                if (defined TESTCONSTMAP->{$k}->{'gui_modes'}) {
                    for my $m (@{TESTCONSTMAP->{$k}->{'gui_modes'}}) {
                        if ($m eq $mode) {

                            # label
                            my $label = $page->Label(
                                '-text'    => TESTCONSTMAP->{$k}->{'description'},
                                '-justify' => 'left'
613
                            );
614
                            $label->grid(
615
616
                                '-row'    => $row,
                                '-column' => 0,
617
618
                                '-sticky' => 'w'
                            );
619
620

                            # unit
621
622
                            my $unit_val = TESTCONSTMAP->{$k}->{'unit'};
                            my $unit = $page->Label('-text' => (!defined($unit_val)) ? "" : "[$unit_val]",);
623
                            $unit->grid(
624
625
                                '-row'    => $row,
                                '-column' => 1,
626
627
                                '-ipadx'  => ".5c",
                                '-sticky' => 'w',
628
                            );
629

630
631
632
                            # entry
                            my $type = TESTCONSTMAP->{$k}->{'type'};

633
                            my $en;
634
635
636
637
                            my $activation_text = "";
                            my $activation_func = TESTCONSTMAP->{$k}->{'activated_by_settings'};
                            if (defined($activation_func) && ref($activation_func) eq "CODE")
                            {
638
639
640
641
                                $en = $activation_func->($self->{'settings'});
                                $activation_text = "(disabled due to current FIJI configuration)" if (!$en);
                            } else {
                                $en = 1;
642
643
644
                            }

                            if (defined($type) && $type eq 'boolean') {
645
                                $entry = $page->Checkbutton(
646
                                    '-state'    => $en ? "active" : "disabled",
647
648
                                    '-variable' => \$self->{'tests'}->{'design'}->{$k},
                                    '-justify'  => 'left',
649
                                    '-text'     => $activation_text,
650
651
                                );
                                $entry->grid(
652
653
                                    '-row'    => $row,
                                    '-column' => 2,
654
                                    '-sticky' => 'w',
655
                                );
656
                                $widget_height = $label->reqheight;
657
658
                            } elsif (defined($type) && $type eq 'autocomplete') {
                                my $options = TESTCONSTMAP->{$k}->{'values'};
659
660
661
662
                                $entry = $page->Frame();
                                
                                my $complete = $entry->CompleteEntry(
                                    '-state' => $en ? "normal" : "disabled",
663
                                    '-textvariable' => \$self->{'tests'}->{'design'}->{$k},
664
                                );
665
666
667
668
669
670
671
672
                                $complete->grid(
                                    '-row'    => 0,
                                    '-column' => 0,
                                    '-sticky' => "ew",
                                );
                                $entry->gridColumnconfigure(0, -weight => 1);
                                if (defined $options && ref($options) eq "CODE") {
                                    my $b = $entry->Button(
673
674
                                        -text    => 'Update Choices',
                                        -command => sub {
675
                                            $complete->configure('-choices' => TESTCONSTMAP->{$k}->{'values'}->($self->{'settings'}->{$k}, $self->{'settings'}));
676
677
                                        },
                                    )->grid(
678
679
680
                                        '-row'    => 0,
                                        '-column' => 1,
                                        '-sticky' => "w",
681
                                    );
682
                                    $options = $options->();
683
684
685
                                    $widget_height = $b->reqheight;
                                } else {
                                    $widget_height = $complete->Subwidget('entry')->reqheight;
686
                                }
687
                                $complete->configure('-choices' => $options);
688

689
                                $entry->grid(
690
691
                                    '-row'    => $row,
                                    '-column' => 2,
692
693
694
695
696
                                    '-sticky' => 'ew'
                                );
                            } elsif (defined($type) && $type eq 'dropdown') {
                                my $options = TESTCONSTMAP->{$k}->{'values'};
                                if (defined $options && ref($options) eq "CODE") {
697
                                    $options = $options->($self->{'settings'}->{$k}, $self->{'settings'});
698
                                }
699

700
701
702
                                $entry = $page->Frame();
                                my $opts = $entry->Optionmenu(
                                    '-state'        => $en ? "normal" : "disabled",
703
704
705
                                    '-options'      => $options,
                                    '-textvariable' => \$self->{'tests'}->{'design'}->{$k},
                                    '-anchor'       => 'w',
706
                                    '-justify'      => 'left',
707
                                );
708
709
710
711
712
                                $opts->grid(
                                    '-row'    => 0,
                                    '-column' => 0,
                                    '-sticky' => "w"
                                );
713

714
715
716
717
718
719
720
721
722
723
724
725
                                $entry->Label(
                                    '-text'  => $activation_text,
                                    '-state' => "disabled",
                                )->pack(
                                    '-side' => "left",
                                    '-padx' => 5
                                )->grid(
                                    '-row'    => 0,
                                    '-column' => 1,
                                    '-sticky' => 'w'
                                );
                                $entry->gridColumnconfigure(1, -weight => 1);
726

727
                                $entry->grid(
728
729
                                    '-row'    => $row,
                                    '-column' => 2,
730
                                    '-sticky' => 'w',
731
                                );
732
                                $widget_height = $opts->reqheight;
733
734
735
736
737
738
739
740
                            } elsif (defined($type) && $type eq 'file') {
                                $entry = $page->Frame();
                                my $filetypes = [['All files', '*']];

                                $filetypes = TESTCONSTMAP->{$k}->{'filetypes'} if (defined TESTCONSTMAP->{$k}->{'filetypes'});

                                my $b = $entry->Button(
                                    -text    => 'Open',
741
                                    '-state'        => $en ? "normal" : "disabled",
742
                                    -command => sub {
Stefan Tauner's avatar
Stefan Tauner committed
743
                                        my $fb = $page->FBox(
744
745
746
                                            -type      => 'open',
                                            -title     => "Select " . lc(TESTCONSTMAP->{$k}->{'description'}),
                                            -filetypes => $filetypes
Stefan Tauner's avatar
Stefan Tauner committed
747
748
749
750
                                        );
                                        Tk::FIJIUtils::set_icon($fb);
                                        my $file = $fb->Show();

751
752
753
754
755
                                        if (defined $file) {
                                            my ($basevolume, $basedirs, $fn) = File::Spec->splitpath($self->{'tests'}->{'filename'});
                                            my $nv = File::Spec->abs2rel($file, File::Spec->catpath($basevolume, $basedirs, ""));
                                            $logger->info("Setting $k to relative path $nv") if (File::Spec->file_name_is_absolute($file));
                                            $self->{'tests'}->{'design'}->{$k} = $nv;
756
                                            $self->update();
757
758
759
760
761
762
763
764
765
766
                                        }
                                    }
                                )->grid(
                                    -row    => 0,
                                    -column => 0,
                                    -sticky => "w"
                                );
                                my $e = $entry->Entry(-state => 'readonly', -textvariable => \$self->{'tests'}->{'design'}->{$k},)->grid(-row => 0, -column => 1, -sticky => "ew");
                                $entry->gridColumnconfigure(1, -weight => 1);

767
768
769
770
771
772
773
774
775
776
777
778
                                $entry->Button(
                                    -text    => "Clear",
                                    '-state' => ($self->{'tests'}->{'design'}->{$k} ne "") ? "normal" : "disabled",
                                    -command => sub {
                                        $self->{'tests'}->{'design'}->{$k} = "";
                                        $self->update();
                                    },
                                )->grid(
                                    -row    => 0,
                                    -column => 2,
                                    -sticky => "e"
                                );;
779
780
781
782
783
                                $entry->grid(
                                    -row      => $row,
                                    -column   => 2,
                                    '-sticky' => 'ew'
                                );
784
                                $widget_height = $b->reqheight;
785
                            } else {
786
                                $entry = $page->Entry('-state' => $en ? "normal" : "readonly");
787
788
789
790
791
792
793
794
795
                                $entry->configure(
                                    '-validate'        => 'key',
                                    '-validatecommand' => [\&_validate_design_entry, $self, $entry, $k],
                                );
                                $entry->grid(
                                    -row      => $row,
                                    -column   => 2,
                                    '-sticky' => 'ew'
                                );
796
                                $widget_height = $entry->reqheight;
797
                            }
798
799
800
801
802
803
804
805
                            if (defined(TESTCONSTMAP->{$k}->{'matching'})) {
                                push @{$self->{'matching'}->{TESTCONSTMAP->{$k}->{'matching'}}}, $entry;
                            }
                            if (defined(TESTCONSTMAP->{$k}->{'depends_on'})) {
                                push @{$self->{'depends'}->{TESTCONSTMAP->{$k}->{'depends_on'}}}, $entry;
                            }
                            if (defined(TESTCONSTMAP->{$k}->{'forbidden_by'})) {
                                push @{$self->{'forbidden_by'}->{TESTCONSTMAP->{$k}->{'forbidden_by'}}}, $entry;
806
                            }
807
808
                            # add tooltip for widget
                            if (defined TESTCONSTMAP->{$k}->{'help'}) {
Christian Fibich's avatar
Christian Fibich committed
809
                                $balloon->attach(
810
811
812
813
                                    $entry,
                                    -balloonposition => 'mouse',
                                    -msg             => TESTCONSTMAP->{$k}->{'help'}
                                );
Christian Fibich's avatar
Christian Fibich committed
814
                                $balloon->attach(
815
816
817
818
819
                                    $label,
                                    -balloonposition => 'mouse',
                                    -msg             => TESTCONSTMAP->{$k}->{'help'}
                                );
                            }
820

821
                            Tk::FIJIUtils::entry_rebind($entry);
Christian Fibich's avatar
Christian Fibich committed
822

823
824
825
826
827
828
829
                            # Widget description is needed for widget-based error messages such as
                            # "Forbids"
                            $entry->{'key'}         = $k;
                            $entry->{'description'} = TESTCONSTMAP->{$k}->{'description'};
                            push @{$self->{'widgets'}}, $entry;
                            $row++;
                            $widget_background = $entry->cget('-bg');
830
                            $total_height += $widget_height;
831
                        }
Christian Fibich's avatar
Christian Fibich committed
832
833
                    }
                }
834
                $sp->configure(-height=>$total_height);
Christian Fibich's avatar
Christian Fibich committed
835
            }
836
837
838
839
            # extra widgets and settings for the test modes
            if ($mode eq "auto") {
                my $fr = $page->Frame(-relief => "ridge", -borderwidth => 2);
                $fr->grid(-row => $row, -column => 0, -columnspan => 3, -padx => 10, -pady => 10, -ipadx => 10, -ipady => 10, -sticky => "nsew");
Christian Fibich's avatar
Christian Fibich committed
840
                $self->_add_test_panel($fr,$balloon);
841
842
843
844
845
846
847
848
849
850
            } elsif ($mode eq "random") {
                # no extra widgets
            } elsif ($mode eq "manual") {
                $self->{'manual_test_frame'} = $self->{'pages'}->{'manual'}->FIJITestFrame(
                    -settings    => $self->{'settings'},
                    -scrolled    => 1,
                    -test        => $self->{'manualtest'},
                    -relief      => "ridge",
                    -borderwidth => 2
                );
851
                $self->{'manual_test_frame'}->grid(-row => $row, -column => 0, -columnspan => 3, -ipady => 10, -ipadx => 10, -pady => 10, -padx => 10, -sticky => "nsew");
852
853
            }
            $page->gridRowconfigure($row, -weight => 1);
854
            $page->pack(-fill=>'both',-expand=>1);
Christian Fibich's avatar
Christian Fibich committed
855
        }
856
        $self->{'notebook'}->pack(-anchor => "nw", -side => "bottom", -fill => "both", -expand => 1);
857
    };
858

859
860
861
862
863
    if ($@ ne "") {
        # The message might be nonsense, e.g. if Log::Dispatch::QueueAppender is not available"
        # and Perl:Tk(?) might wreck havoc anyway... *shrug*
        $logger->error("Something went wrong while populating " . __PACKAGE__ . ": $@");
    }
Christian Fibich's avatar
Christian Fibich committed
864
865
866
867
868

    return 0;
}

sub update {
Christian Fibich's avatar
Christian Fibich committed
869
    my $self   = shift;
870
871
872

    # loop through all widgets and set their values and states according
    # to the settings
Christian Fibich's avatar
Christian Fibich committed
873
    for my $widget (@{$self->{'widgets'}}) {
874
875
876
877
878
879
880
881
882
883
884
885
        my $k = $widget->{'key'};
        next if (!defined $k || !defined TESTCONSTMAP->{$k}->{'type'});

        my $en;
        my $activation_func = TESTCONSTMAP->{$k}->{'activated_by_settings'};
        if (defined($activation_func) && ref($activation_func) eq "CODE")
        {
            $en = $activation_func->($self->{'settings'});
        } else {
            $en = 1;
        }

886
        my $val = \$self->{'tests'}->{'design'}->{$k};
Christian Fibich's avatar
Christian Fibich committed
887
        if (ref($widget) eq "Tk::Entry") {
888
            $widget->configure('-state' => $en ? "normal" : "readonly");
889
890
891
892
893
            if (defined($val)) {
                $widget->configure(-text => $val);
            } else {
                $widget->delete('0', 'end');
            }
Christian Fibich's avatar
Christian Fibich committed
894
        } elsif (ref($widget) eq "Tk::Checkbutton") {
895
896
897
898
            $widget->configure(
                '-state'    => $en ? "normal" : "disabled",
                '-variable' => \$self->{'tests'}->{'design'}->{$k},
            );
899
900
901
902
            if (defined($self->{'depends'}->{$k})) {
                $widget->configure('-command' => [\&_set_fields_by_button, $self, $widget, $self->{'depends'}->{$k}, []]);
            }
            _set_fields_by_button($self, $widget, $self->{'depends'}->{$k}, []);
903
        } elsif (ref($widget) eq "Tk::Frame") {
904
            if (TESTCONSTMAP->{$k}->{'type'} eq 'file') {
905
906
                my $text = ($widget->children)[1];
                $text->configure(
907
                    '-state' => $en ? "normal" : "disabled",
908
909
910
911
912
913
914
915
916
917
918
                    # Don't ask me why but setting "" to the underlying variable
                    # does not change the text in the entry.
                    # Setting something else than "" or undef works just fine. O_o
                    # This workaround re-sets the textvariable to its previous value namely
                    # the reference to the respective $self->{'tests'}->{'design'} field
                    # and this seems to trigger an update.
                    '-textvariable' => $val,
                );
                my $clear = ($widget->children)[2];
                $clear->configure(
                    '-state' => ($$val ne "") ? "normal" : "disabled",
919
920
921
922
923
924
                );
            } elsif (TESTCONSTMAP->{$k}->{'type'} eq 'dropdown') {
                my $options = TESTCONSTMAP->{$k}->{'values'};
                if (defined $options && ref($options) eq "CODE") {
                    $options = $options->($self->{'settings'}->{$k}, $self->{'settings'});
                }
925
926
                my $subwidget = ($widget->children)[0];
                $subwidget->configure(
927
928
929
930
931
932
933
934
935
                    '-state' => $en ? "active" : "disabled",
                    '-options'      => $options,
                    '-textvariable' => $val,
                );
            } elsif (TESTCONSTMAP->{$k}->{'type'} eq 'autocomplete') {
                my $options = TESTCONSTMAP->{$k}->{'values'};
                if (defined $options && ref($options) eq "CODE") {
                    $options = $options->($self->{'settings'}->{$k}, $self->{'settings'});
                }
936
937
                my $subwidget = ($widget->children)[0];
                $subwidget->configure(
938
939
940
941
                    '-state'        => $en ? "normal" : "disabled",
                    '-choices'      => $options,
                    '-textvariable' => $val,
                );
942
            }
943
944
945
        } else {
            my $logger = get_logger("");
            $logger->error("Updating unknown widget: " . ref($widget) . " of type: " . TESTCONSTMAP->{$k}->{'type'});
Christian Fibich's avatar
Christian Fibich committed
946
947
948
        }
    }

949
950
951
952
    ###############
    # tests panel #
    ###############

Christian Fibich's avatar
Christian Fibich committed
953
    my $parent = $self->{'fr_tests'}->parent();
Christian Fibich's avatar
Christian Fibich committed
954
955
956
    for my $w ($self->{'fr_tests'}->children()) {
        $self->{'balloon'}->detach($w);
    }
Christian Fibich's avatar
Christian Fibich committed
957
958
959
    $parent->packForget();             # This and the next line would be redundant if
    $self->{'fr_tests'}->destroy();    # the $parent->destroy() call would work.
    $self->_add_test_frame($parent->parent());
960

Christian Fibich's avatar
Christian Fibich committed
961
962
963
    $self->{'fr_tests'}->gridColumnconfigure(0, -weight => 0);
    $self->{'fr_tests'}->gridColumnconfigure(1, -weight => 1);
    $self->{'fr_tests'}->gridColumnconfigure(2, -weight => 1);
964
965
966

    my $i       = 1;
    my $hdr_row = 0;
967
    foreach my $hdr ("Duration T1 [cycles]", "Duration T2 [cycles]") {
Christian Fibich's avatar
Christian Fibich committed
968
        $self->{'fr_tests'}->Label(-text => $hdr,)->grid(
969
970
971
972
            '-row'    => $hdr_row,
            '-column' => $i++,
        );
    }
Christian Fibich's avatar
Christian Fibich committed
973

974
    my $test_cnt = $self->_test_cnt();