Connection.pm 25.9 KB
Newer Older
1
2
3
#-----------------------------------------------------------------------
# Fault InJection Instrumenter (FIJI)
# https://embsys.technikum-wien.at/projects/vecs/fiji
Christian Fibich's avatar
Christian Fibich committed
4
#
5
6
7
8
# The creation of this file has been supported by the publicly funded
# R&D project Josef Ressel Center for Verification of Embedded Computing
# Systems (VECS) managed by the Christian Doppler Gesellschaft (CDG).
#
9
10
11
# Authors:
# Christian Fibich <fibich@technikum-wien.at>
# Stefan Tauner <tauner@technikum-wien.at>
Christian Fibich's avatar
Christian Fibich committed
12
#
13
14
# This module is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
Christian Fibich's avatar
Christian Fibich committed
15
#
16
17
18
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
Christian Fibich's avatar
Christian Fibich committed
19
#
20
21
# See the LICENSE file for more details.
#-----------------------------------------------------------------------
Christian Fibich's avatar
Christian Fibich committed
22

Christian Fibich's avatar
Christian Fibich committed
23
24
## @file Connection.pm
# @brief Contains class \ref FIJI::Connection
25

26
## @class FIJI::Connection
Christian Fibich's avatar
Christian Fibich committed
27
28
# @brief Instances of this class represent a single serial connection to a FIJI-compatible DUT
## @class FIJI::Connection
29
# Besides handling all communication-related functions they are also responsible for generating and interpreting the respective payloads.
30
#
31
32
33
# The implementation relies on AnySerialPort.pm to be cross-platform-compatible.
package FIJI::Connection;

34
35
36
use strict;
use warnings;

37
38
39
40
41
use Log::Log4perl qw(get_logger);
use Digest::CRC "crc";
use Time::HiRes "usleep";
use FIJI::AnySerialPort;

42
## @method public init ($portname, $baudrate)
43
44
45
# @brief Initiate the given serial port and this abstraction.
#
# \param portname The path to the device file of the port.
46
# \param baudrate (optional) The baudrate to use.
47
48
49
#
# \returns a FIJI::Connection object, or undef if non could be obtained.
sub init {
50
    my $logger = get_logger("");
Christian Fibich's avatar
Christian Fibich committed
51
    my ($class, $portname, $baudrate) = @_;
52

Christian Fibich's avatar
Christian Fibich committed
53
54
55
    if (defined($baudrate)) {
        if ($baudrate <= 0) {
            $logger->error(sprintf("Baud rate is negative (%d).", $baudrate));
56
57
58
59
60
            return undef;
        }
    } else {
        $baudrate = 9600;
    }
61

62
    my $port = Device::SerialPort->new($portname);
Christian Fibich's avatar
Christian Fibich committed
63
    if (!defined($port)) {
64
        $logger->error("Could not open serial port \"$portname\".");
65
66
67
        return undef;
    }

Christian Fibich's avatar
Christian Fibich committed
68
    if ($port->can("are_baudrate")) {
69
        my @rates = $port->are_baudrate;
Christian Fibich's avatar
Christian Fibich committed
70
        if (grep(/^$baudrate$/, @rates) == 0) {
71
            $logger->error(
Christian Fibich's avatar
Christian Fibich committed
72
                "Invalid baud rate ($baudrate). Possible choices are:", {
73
74
75
76
                    filter => sub {
                        my $opts = shift;
                        my $ret  = "";
                        foreach my $o (@$opts) {
Christian Fibich's avatar
Christian Fibich committed
77
                            $ret .= sprintf("\n%d", $o);
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
                        }
                        return $ret;
                    },
                    value => \@rates
                }
            );
            return undef;
        }
    }
    $port->databits(8);
    $port->baudrate($baudrate);
    $port->parity("none");
    $port->stopbits(1);
    $port->handshake("none");
    $port->read_char_time(0);        # don't wait for each character
    $port->read_const_time(1000);    # 1 second per unfulfilled "read" call

Christian Fibich's avatar
Christian Fibich committed
95
    if (!$port->write_settings) {
96
97
98
        $logger->warn("Could not write UART settings for \"$portname\".");
        return undef;
    }
99
    $logger->debug("Using serial port $portname with baud rate $baudrate.");
100
101
102

    my %hash;
    $hash{'port'} = $port;
Christian Fibich's avatar
Christian Fibich committed
103
104
    my $r = bless(\%hash, $class);
    if (!ref($r) || !UNIVERSAL::can($r, 'can')) {
105
106
107
108
109
        $logger->error("Could not bless serial port for \"$portname\".");
        return undef;
    }
    return $r;
}
110

111
## @function public sanitize_config (%$config_ref)
112
113
114
# @brief Do a sanity check on the FIJI configuration hash.
#
# \param config_ref a reference to a hash containing a FIJI configuration consisting of
115
116
117
#     - payload: a byte array representing the FIU configurations for both time intervals
#     - t1_duration and t2_duration (optional):
#       initialization values for the t1 and t2 duration counters.
Stefan Tauner's avatar
Stefan Tauner committed
118
#     - consts: a reference to a hash representing FIJI constants (see \ref FIJI::Settings::_sanitize_design).
119
120
121
122
123
124
#   The following values are optional booleans and hence not checked:
#     - reset
#     - trigger
#
# \returns 0 if configuration seems sane.
sub sanitize_config {
125
    my $logger = get_logger("");
126
127
128
129
130
131
    my ($config_ref) = @_;

    my $consts_ref  = $config_ref->{'consts'};
    my $payload_ref = $config_ref->{'payload'};

    # check payload
Christian Fibich's avatar
Christian Fibich committed
132
    if (ref($payload_ref) ne 'ARRAY') {
133
134
135
136
137
138
        $logger->error("payload parameter is not a reference to an array.");
        return 1;
    }

    my $cfgs_per_msg = $consts_ref->{'CFGS_PER_MSG'};
    my $fiu_num      = $consts_ref->{'FIU_NUM'};
Christian Fibich's avatar
Christian Fibich committed
139
140
    if (scalar(@$payload_ref) != ($fiu_num * $cfgs_per_msg)) {
        $logger->error(sprintf("Expected %d FIU configuration bytes but got %d.", $fiu_num * $cfgs_per_msg, scalar(@$payload_ref)));
141
142
143
144
        return 1;
    }

    my $cfg_mask = 2**$consts_ref->{'FIU_CFG_BITS'} - 1;
Christian Fibich's avatar
Christian Fibich committed
145
146
    for (my $i = 0 ; $i < scalar(@$payload_ref) ; $i++) {
        if ((@$payload_ref[$i] & ~$cfg_mask) != 0) {
147
148
149
150
151
152
153
            $logger->error("Configuration of FIU #$i has undefined bits set.");
            return 1;
        }
    }

    # if payload would be a string...
    # for (my $i = 0; $i < length($payload); $i++) {
154
155
156
    # my $orig = substr($payload, $i, 1);
    # my $c = ord($orig);
    # if ($c > 127) {
157
158
    # $logger->error(sprintf("%dth byte is too big (%d).", $i, $c));
    # return 1;
159
160
161
162
    # }
    # $c <<= 1;
    # substr($payload, $i, 1) = chr($c);
    # $logger->trace(sprintf("%s (0x%02x) => %s (0x%02x).", $orig, ord($orig), substr($payload, $i, 1), ord(substr($payload, $i, 1))));
163
    # }
164

165
    # optional, positive values:
Christian Fibich's avatar
Christian Fibich committed
166
167
    foreach my $k ('t1_duration', 't2_duration') {
        if (!exists($config_ref->{$k})) {
168
169
170
            $logger->debug("$k not in configuration, using default 0.");
            $config_ref->{$k} = 0;
        } else {
Christian Fibich's avatar
Christian Fibich committed
171
172
            if ($config_ref->{$k} < 0) {
                $logger->error(sprintf("Configuration value \"%s\" is negative (%d).", $k, $config_ref->{$k}));
173
174
                return 1;
            }
Christian Fibich's avatar
Christian Fibich committed
175
176
177
            my $max_val = 2**($consts_ref->{'TIMER_WIDTH'} * 8) - 1;
            if ($config_ref->{$k} > $max_val) {
                $logger->error(sprintf("Configuration value \"%s\" is too big (%d) for %d bytes.", $k, $config_ref->{$k}, $consts_ref->{'TIMER_WIDTH'}));
178
179
180
                return 1;
            }
        }
181
182
    }

183
    return 0;
184
185
}

Stefan Tauner's avatar
Stefan Tauner committed
186
{
Christian Fibich's avatar
Christian Fibich committed
187
188
189
190
    # "static" variable for use in send_config.
    # t1 and t2 durations of the previous configuration.
    my $prev_t1 = 0;
    my $prev_t2 = 0;
Stefan Tauner's avatar
Stefan Tauner committed
191

192
## @method public send_config (%$config_ref, $run_ref, $block_till_ready, $wait_for_ready)
Christian Fibich's avatar
Christian Fibich committed
193
194
195
    # @brief Sends a complete configuration to the FI controller.
    #
    # \param config_ref a reference to a hash representing a FIJI configuration (see \ref sanitize_config).
196
    # \param run_ref a reference to a boolean indicating that no abort is requested (yet).
Christian Fibich's avatar
Christian Fibich committed
197
198
199
    # \param block_till_ready (optional) Normally the function immediately starts to transmit the new configuration. If this parameter is defined and non-zero the function first waits for a READY message (up to the timeout).
    # \param wait_for_ready (optional) Normally the function returns immediately after the CONF_DONE message is received. If this parameter is defined and non-zero the function additionally waits for a READY/UNDERRUN message.
    #
200
201
    # \returns 1 if no message could be received
    # \returns a hash if any message was received (potentially) containing msg_type, fault_detect, error, underrun_occurred
Christian Fibich's avatar
Christian Fibich committed
202
203
    sub send_config {
        my $logger = get_logger("");
204
        my ($self, $config_ref, $run_ref, $block_till_ready, $wait_for_ready) = @_;
Christian Fibich's avatar
Christian Fibich committed
205
206
207
        my $port = $self->{'port'};

        if (ref($config_ref) ne 'HASH') {
208
209
            $logger->error("Parameter is not a reference to a hash (containing a FIJI configuration).");
            return "Internal Error";
Christian Fibich's avatar
Christian Fibich committed
210
        }
211

Christian Fibich's avatar
Christian Fibich committed
212
        if (sanitize_config($config_ref) != 0) {
213
214
            $logger->error("FIJI configuration invalid");
            return "Invalid Configuration";
Christian Fibich's avatar
Christian Fibich committed
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
        }
        my $consts_ref   = $config_ref->{'consts'};
        my $cfgs_per_msg = $consts_ref->{'CFGS_PER_MSG'};
        my $fiu_num      = $consts_ref->{'FIU_NUM'};
        my $bits_per_cfg = $consts_ref->{'FIU_CFG_BITS'};

        my $pay_ref     = $config_ref->{'payload'};
        my $dryrun      = (exists($config_ref->{'dryrun'}) and ($config_ref->{'dryrun'} != 0)) ? 1 : 0;
        my $reset       = (exists($config_ref->{'reset'}) and ($config_ref->{'reset'} != 0)) ? 1 : 0;
        my $trigger_en  = (exists($config_ref->{'trigger_en'}) and ($config_ref->{'trigger_en'} != 0)) ? 1 : 0;
        my $trigger_ext = (exists($config_ref->{'trigger_ext'}) and ($config_ref->{'trigger_ext'} != 0)) ? 1 : 0;

        my $id = $consts_ref->{'ID'};

        my $t1_duration = $config_ref->{'t1_duration'};
        my @t1_duration_arr;
        for (my $i = 0 ; $i < $consts_ref->{'TIMER_WIDTH'} ; $i++) {
            push(@t1_duration_arr, ($t1_duration >> ($i * 8)) & 0xFF);
        }
234

Christian Fibich's avatar
Christian Fibich committed
235
236
237
238
239
        my $t2_duration = $config_ref->{'t2_duration'};
        my @t2_duration_arr;
        for (my $i = 0 ; $i < $consts_ref->{'TIMER_WIDTH'} ; $i++) {
            push(@t2_duration_arr, ($t2_duration >> ($i * 8)) & 0xFF);
        }
240

Christian Fibich's avatar
Christian Fibich committed
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
        # create the actual bit stream
        my $payload_per_byte = 8;
        my $cfg_bits         = $fiu_num * $bits_per_cfg * $cfgs_per_msg;
        my $stuffing         = $cfg_bits % $payload_per_byte;                                                                              # stuffing = first n bits to end payload at byte boundary
        my $stuffing_bits    = ($stuffing != 0) ? $payload_per_byte - $stuffing : 0;
        my $padd_bits        = int(($cfg_bits + $stuffing_bits + $payload_per_byte - 1) / $payload_per_byte) * (8 - $payload_per_byte);    # padding fills up each byte if there are less than 8 payload bits
        my $cfg_bits_total   = $cfg_bits + $stuffing_bits + $padd_bits;
        $logger->debug("Building the actual configuration bit string of $cfg_bits_total bits ($cfg_bits cfg bits + $stuffing_bits stuffings bits + $padd_bits padding bits)");
        my @cfg;
        my $off     = $cfgs_per_msg * $fiu_num - $cfgs_per_msg;
        my $byte    = 0;
        my $top     = $cfg_bits_total;
        my $bot     = $stuffing_bits;
        my $bit_off = $bits_per_cfg - 1;

        for (my $i = $bot ; $i < $top ; $i++) {
            if ($bit_off == $bits_per_cfg - 1) {
                $logger->trace(sprintf("New payload byte %u-%u: 0x%02x", $off / $cfgs_per_msg, $off % $cfgs_per_msg + 1, $pay_ref->[$off]));
            }
260

Christian Fibich's avatar
Christian Fibich committed
261
262
263
264
            # prepend the next bit of the current FIU
            my $b = ($pay_ref->[$off] >> ($bits_per_cfg - $bit_off - 1)) & 1;
            $byte = ($b << 7) | $byte >> 1;
            $logger->trace(sprintf("Appended %d (bit_off=%d, off=%d, i=%d): 0x%02x", $b, $bit_off, $off, $i, $byte));
265

Christian Fibich's avatar
Christian Fibich committed
266
267
268
269
270
271
272
273
274
275
276
277
278
279
            if ($bit_off == 0) {
                $bit_off = $bits_per_cfg - 1;
                $off++;
                if ($off % $cfgs_per_msg == 0) {
                    $off -= (2 * $cfgs_per_msg);
                }
            } else {
                $bit_off--;
            }
            if (($i % 8) == ($payload_per_byte - 1) || $i == $top - 1) {
                $logger->trace(sprintf("Completed config byte #%u: %b (0x%02x)", $i / 8, $byte, $byte));
                push(@cfg, $byte);
                $byte = 0;
            }
280
281
        }

Christian Fibich's avatar
Christian Fibich committed
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
        $logger->debug("The resulting configuration payload: " . join(", ", unpack("H2" x scalar(@cfg), pack("C*", @cfg))));

        my $config_byte = ($dryrun << 7) | ($reset << 2) | ($trigger_ext << 1) | ($trigger_en << 0);
        my $bitstr = pack('C*', @cfg, @t1_duration_arr, @t2_duration_arr, $config_byte, $id & 0xFF, ($id >> 8) & 0xFF,);    # oh my.

        # generate input for http://www.zorc.breitbandkatze.de/crc.html
        # printf("payload data: ");
        # for (my $i = 0; $i < length($bitstr); $i++) {
        # printf("%%%02x", ord(substr($bitstr, $i, 1)));
        # }
        # printf("\n");

        my $ctx = Digest::CRC->new(
            width  => 8,
            init   => 0xF3,
            poly   => 0x07,
            refin  => 1,
            refout => 1,
            xorout => 0,
        );
        $ctx->add($bitstr);
        my $crc = hex($ctx->hexdigest);
        $bitstr .= chr($crc);    # @FIXME: this will probably break some day

        ############
        # Timeouts #
        ############
        # Maximum timeouts for the current transfer possibly depend not only
        # on the settings of the respective configuration but also on the
        # previous one because the durations of that previous configuration
        # change the timing behavior (i.e. response times) of the hardware.
        #
        # Additionally we always add the constant below to be one the safe side.
        my $timeout_buffer = 500;    # in ms

        my @rcv_buf = ();
        my %err;
        my %fd;
        my $msg_type;

        # if block_till_ready... wait for ready message first
        if (defined($block_till_ready) && $block_till_ready != 0) {

325
            $logger->debug("Blocking till ready...");
Christian Fibich's avatar
Christian Fibich committed
326
327
328
            # Timeout: if we are waiting for the previous READY message instantly after
            # CONF_DONE, then (if no trigger was set previously) the timeout should contain
            # the t1 duration of the last configuration.
329
330
            # FIXME: conform to run_ref and abort earlier if indicated
            my $timeout = (($prev_t1 / $consts_ref->{'FREQUENCY'}) * 1000) + $timeout_buffer;
Christian Fibich's avatar
Christian Fibich committed
331
            if ((_rcv_bitstream($port, 1, $timeout, \@rcv_buf) != 0) || ((scalar @rcv_buf) != 1)) {
332
333
                my $msg = "Receiving READY message failed";
                $logger->error($msg);
Christian Fibich's avatar
Christian Fibich committed
334
                $prev_t1 = $prev_t2 = 0;
335
                return "No READY";
Christian Fibich's avatar
Christian Fibich committed
336
337
338
339
340
341
342
343
344
345
            }
            $msg_type = _parse_return_message($rcv_buf[0], \%err, \%fd);
            $logger->debug(sprintf("Received %s message (while waiting for ready before sending).", defined($msg_type) ? $msg_type : "invalid"));
            if (!defined($msg_type) || $msg_type ne 'READY') {
                $logger->error(sprintf("Received message is not a valid READY message (but %s).", defined($msg_type) ? $msg_type : "invalid"));
                return {msg_type => $msg_type, fault_detect => \%fd, error => \%err};
            }
            if ($err{'ANY'} != 0) {
                $logger->error("Received READY message indicates errors on the DUT side.");
                return {msg_type => $msg_type, fault_detect => \%fd, error => \%err};
346
347
            }
        }
Christian Fibich's avatar
Christian Fibich committed
348
349
350

        # actually send new configuration
        if (_send_bitstream($port, \$bitstr) != length($bitstr)) {
351
352
353
            my $msg = "Send failed";
            $logger->error($msg);
            return $msg;
354
355
        }

Christian Fibich's avatar
Christian Fibich committed
356
        # wait for CONF_DONE message and check for errors
357

Christian Fibich's avatar
Christian Fibich committed
358
        $msg_type = undef;
359

Christian Fibich's avatar
Christian Fibich committed
360
361
362
363
364
        # loop tries to clear away an UNDERRUN messages still in the buffer
        # else, we return to the caller too early (he might try to send another
        # pattern while the current config is still active.
        my $underrun_occurred = 0;
        my $underrun_try_cnt  = 1;
365
366

        $logger->debug("Waiting for any response...");
Christian Fibich's avatar
Christian Fibich committed
367
368
      retry_underrun:
        @rcv_buf = ();
Stefan Tauner's avatar
Stefan Tauner committed
369

Christian Fibich's avatar
Christian Fibich committed
370
371
372
373
        # Timeout: the hardware should instantly reply after receiving our sent configuration.
        # Potentially we might also receive an UNDERRUN if we were sending a bit too late.
        if ((_rcv_bitstream($port, 1, $timeout_buffer, \@rcv_buf) != 0) || ((scalar @rcv_buf) != 1)) {
            $logger->error("Receiving potential CONF_DONE message failed");
374
            return "No CONF_DONE";
Christian Fibich's avatar
Christian Fibich committed
375
376
377
378
379
380
        }
        $msg_type = _parse_return_message($rcv_buf[0], \%err, \%fd);
        $logger->debug(sprintf("Received %s message (while waiting for CONF_DONE (or UNDERRUN).", defined($msg_type) ? $msg_type : "invalid"));
        if (!defined($msg_type) || $msg_type ne 'CONF_DONE') {
            $logger->warn(sprintf("Received message is not a valid CONF_DONE message (but %s).", defined($msg_type) ? $msg_type : "invalid"));
            if (($underrun_try_cnt-- > 0) && (!defined($msg_type) || $msg_type eq 'UNDERRUN')) {
381
                $logger->info(sprintf("Retrying to fetch CONF_DONE."));
Christian Fibich's avatar
Christian Fibich committed
382
383
384
385
386
387
388
                $underrun_occurred++;
                goto retry_underrun;
            }
            $logger->error("No more tries to receive CONF_DONE allowed.");
            return {msg_type => $msg_type, fault_detect => \%fd, error => \%err};
        }
        if ($err{'ANY'} != 0) {
389
            $logger->debug("Received message indicated errors.");
Christian Fibich's avatar
Christian Fibich committed
390
391
            return {msg_type => $msg_type, fault_detect => \%fd, error => \%err};
        }
Stefan Tauner's avatar
Stefan Tauner committed
392

Christian Fibich's avatar
Christian Fibich committed
393
        # exit early if requested to not wait for another READY message
394
395
        if ((!defined($dryrun) || $dryrun == 1) || (!defined($wait_for_ready) || $wait_for_ready == 0)) {
            $logger->debug("Returning after successfully receiving CONF_DONE message due to dryrun or wait_for_ready.");
Christian Fibich's avatar
Christian Fibich committed
396
397
            return {msg_type => $msg_type, fault_detect => \%fd, error => \%err};
        }
Stefan Tauner's avatar
Stefan Tauner committed
398

399
        $logger->debug("Waiting for READY response...");
Christian Fibich's avatar
Christian Fibich committed
400
        # Timeout: the READY message come back after duration t2 of the previous + t1 of the current configuration expires.
401
402
403
404
405
        if ($trigger_en == 1) {
            $logger->debug("Trigger specified, no timeout set.");
        }

        my $tot_timeout = ($trigger_en == 1) ? undef : (((($prev_t2 + $t1_duration) / $consts_ref->{'FREQUENCY'}) * 1000) + $timeout_buffer);
406
        my $READY_WAIT_MS = 100;
Christian Fibich's avatar
Christian Fibich committed
407
        @rcv_buf = ();
408
409
      retry_ready_finish:

410
411
        if (!defined($run_ref) || $$run_ref == 0) {
            $logger->debug("Returning early (before receiving READY message) due to unset run.");
412
            return {'aborted' => 1};
413
414
        }

415
        if (defined($tot_timeout) && ($tot_timeout <= 0)) {
416
417
418
419
420
421
422
            $logger->debug("Timed out during waiting for READY message after transaction.");
            return "Timeout";
        }

        # wait for READY message
        my $ret = _rcv_bitstream($port, 1, $READY_WAIT_MS, \@rcv_buf);
        if ($ret > 0) {
423
            $logger->error("Receiving READY message failed");
424
            return "No READY";
425
        }
426
        $tot_timeout -= $READY_WAIT_MS if (defined($tot_timeout));
427
428
429
430
431
        if (scalar(@rcv_buf) == 0) {
            $logger->trace("Timeout while receiving READY message");
            goto retry_ready_finish;
        }

Christian Fibich's avatar
Christian Fibich committed
432
        $msg_type = _parse_return_message($rcv_buf[0], \%err, \%fd);
Christian Fibich's avatar
Christian Fibich committed
433
        $logger->debug(sprintf("Received %s message (while waiting for READY).", defined($msg_type) ? $msg_type : "invalid"));
Christian Fibich's avatar
Christian Fibich committed
434
435
436
        if (!defined($msg_type) || $msg_type ne 'READY') {
            $logger->error(sprintf("Received message is not a valid READY message (but %s).", defined($msg_type) ? $msg_type : "invalid"));
            return {msg_type => $msg_type, fault_detect => \%fd, error => \%err};
437
        }
Christian Fibich's avatar
Christian Fibich committed
438
        if ($err{'ANY'} != 0) {
439
440
441
            $logger->error("Received READY message indicates errors on the DUT side.");
        }

Christian Fibich's avatar
Christian Fibich committed
442
443
        $prev_t1 = $t1_duration;
        $prev_t2 = $t2_duration;
444

445
        return {'msg_type' => $msg_type, 'fault_detect' => \%fd, 'error' => \%err, 'underrun_occurred' => ($underrun_occurred != 0)};
446
    }
Christian Fibich's avatar
Christian Fibich committed
447
}    # "static" block
448

449
## @function public _send_bitstream ($port, $$str_ref, $timeout)
450
451
452
453
# @brief Sends a bitstream via a serial port
#
# \param port An initialized AnySerialPort port object
# \param str_ref A reference to the payload string
454
# \param timeout (optional) Approximate(!) timeout in ms. Unsupported on Unix.
455
456
457
#
# \returns the number of bytes actually transmitted
sub _send_bitstream {
458
    my $logger = get_logger("");
Christian Fibich's avatar
Christian Fibich committed
459
    my ($port, $str_ref, $timeout) = @_;
460

Christian Fibich's avatar
Christian Fibich committed
461
    if (!defined($port)) {
462
463
464
        $logger->error("Undefined port");
        return 1;
    }
Christian Fibich's avatar
Christian Fibich committed
465
    if (ref($str_ref) ne 'SCALAR') {
466
467
468
469
        $logger->error("Invalid reference to payload");
        return 1;
    }

Stefan Tauner's avatar
Stefan Tauner committed
470
    $timeout = 1000 unless defined($timeout) && $timeout >= 0;
471
472
473
474
475
476
    my $str = $$str_ref;

    $port->write_const_time($timeout) if $port->can("write_const_time");

    # dump all bytes in a nice hex list within a closure
    $logger->trace(
Christian Fibich's avatar
Christian Fibich committed
477
        "send_bitstream writing:", {
478
479
480
            filter => sub {
                my $payload = shift;
                my $ret     = "";
Christian Fibich's avatar
Christian Fibich committed
481
482
                for (my $i = 0 ; $i < length($payload) ; $i++) {
                    $ret .= sprintf("\n% 3d: 0x%02x", $i, ord(substr($payload, $i, 1)));
483
484
485
486
487
488
                }
                return $ret;
            },
            value => $$str_ref
        }
    );
489
490

    # CTS timeout
Christian Fibich's avatar
Christian Fibich committed
491
492
493

    if ($port->handshake eq "rts") {
        my $bits            = Device::SerialPort::Bits::get_hash();
494
        my $IOCTL_VALUE_CTS = pack('L', $bits->{'TIOCM_CTS'} || 0);
Christian Fibich's avatar
Christian Fibich committed
495
        my $t               = 0;
496
497
498
        my $s;

        do {
Christian Fibich's avatar
Christian Fibich committed
499
            my $status = pack('i', 0);
500
            $port->ioctl('TIOCMGET', \$status);
Christian Fibich's avatar
Christian Fibich committed
501
            $s = unpack('i', $status);
502
503
504
            usleep(100);
            $t++;
        } while (($s & $bits->{'TIOCM_CTS'}) == 0 && $t < 10);
Christian Fibich's avatar
Christian Fibich committed
505
506

        if ($t == 10) {
507
508
509
510
511
            $logger->warn("CTS timeout.");
            return 0;
        }
    }

512
    my $wrn = $port->write($str);
Christian Fibich's avatar
Christian Fibich committed
513
    if (!defined($wrn)) {
514
        $logger->warn("write() returned an error: $^E");
515
516
        $wrn = 0;
    }
Christian Fibich's avatar
Christian Fibich committed
517
518
    if ($wrn != length($str)) {
        $logger->warn(sprintf("Sent less (%d) than expected (%d).", $wrn, length($str)));
519
    }
520

521
522
    return $wrn;
}
523

524
## @function public _rcv_bitstream ($port, $todo, $timeout, @$out_ref)
525
526
527
528
# @brief Receives a bitstream via a serial port
#
# \param port An initialized AnySerialPort port object
# \param todo The number of bytes to read
Stefan Tauner's avatar
Stefan Tauner committed
529
# \param timeout Approximate(!) timeout for a reply in ms
530
# \param out_ref (optional) An array reference to store (append) all read bytes
531
#
532
# \returns 0 on success or timeout
533
sub _rcv_bitstream {
534
    my $logger = get_logger("");
Christian Fibich's avatar
Christian Fibich committed
535
    my ($port, $todo, $timeout, $buf_ref) = @_;
536
537

    my @bytes;
Christian Fibich's avatar
Christian Fibich committed
538
    if (!defined($buf_ref)) {
539
540
        $buf_ref = \@bytes;
        $logger->debug("Throwing away up to $todo bytes in rcv_bitstream because buf_ref not given.");
541
    } else {
Christian Fibich's avatar
Christian Fibich committed
542
        if (ref($buf_ref) ne 'ARRAY') {
543
544
545
546
            $logger->error("Parameter out_ref is not a reference to an array.");
            return 1;
        }
    }
547
    $logger->trace("Timeout = $timeout.");
Stefan Tauner's avatar
Stefan Tauner committed
548
    if ($timeout < 0) {
Christian Fibich's avatar
Christian Fibich committed
549
        my ($count, $tmp) = $port->read($todo);
Stefan Tauner's avatar
Stefan Tauner committed
550
551
        if (!defined($count) || $count != $todo) {
            $logger->debug("Only $count of $todo requested bytes were read.");
552
            return 0;
Stefan Tauner's avatar
Stefan Tauner committed
553
554
555
556
557
558
559
        }
        push(@{$buf_ref}, unpack('C*', $tmp));
    } else {
        $port->read_const_time($timeout);
        while ($todo > 0) {
            my ($count, $tmp) = $port->read($todo);
            if (!defined($count) || $count == 0) {
560
                $logger->trace("Empty read. $todo requested bytes NOT read.");
Stefan Tauner's avatar
Stefan Tauner committed
561
562
563
564
565
                last;
            } else {
                $todo -= $count;
                push(@{$buf_ref}, unpack('C*', $tmp));
            }
566
        }
567
568
    }

569
570
    # dump all bytes in a nice hex list within a closure
    $logger->trace(
Christian Fibich's avatar
Christian Fibich committed
571
        "rcv_bitstream read:", {
572
573
574
            filter => sub {
                my $buf_ref = shift;
                my $ret     = "";
Christian Fibich's avatar
Christian Fibich committed
575
                for (my $i = 0 ; $i < scalar(@$buf_ref) ; $i++) {
576
                    my $cur = @$buf_ref[$i];
Christian Fibich's avatar
Christian Fibich committed
577
578
                    $ret .= sprintf("\n% 3d: 0x%02x", $i, $cur);
                    $ret .= sprintf(" (%c)", $cur) if chr($cur) =~ /[[:print:]]/;
579
580
581
582
583
584
585
586
                }
                return $ret;
            },
            value => $buf_ref
        }
    );

    return 0;
587
588
}

589
## @function public _parse_return_message ($message_byte, %$error_ref)
590
591
#
# \returns The type of the return message, or undef in the case of errors.
592
#          Possible types are: 'CONF_DONE', 'UNDERRUN', 'READY'
593
sub _parse_return_message {
594
    my $logger = get_logger("");
Christian Fibich's avatar
Christian Fibich committed
595
596
    my ($message_byte, $error_ref, $fd_ref) = @_;
    if (defined($error_ref) && ref($error_ref) ne 'HASH') {
597
598
599
        $logger->error("Second parameter is not a reference to a hash.");
        return undef;
    }
Christian Fibich's avatar
Christian Fibich committed
600
    if (defined($fd_ref) && ref($fd_ref) ne 'HASH') {
601
602
603
604
605
606
607
608
609
610
611
        $logger->error("Third parameter is not a reference to a hash.");
        return undef;
    }

    $error_ref->{'ANY'} = 0;    # be optimistic :) and ease error handling in callers
    $fd_ref->{'ANY'}    = 0;    # be optimistic :)

    # Even parity bit calculation:
    # Hardware XORs the seven LSB and transmits result as 8th bit.
    # Code below XORs all 8 bits and checks for 0.
    my $par = 0;
Christian Fibich's avatar
Christian Fibich committed
612
613
    for (my $i = 0 ; $i < 8 ; $i++) {
        $par = $par ^ (($message_byte >> $i) & 0x01);
614
615
    }

Christian Fibich's avatar
Christian Fibich committed
616
    if ($par != 0) {
617
        $logger->warn(sprintf("Return message parity error (msg=0x%02x).", $message_byte));
618
619
620
        return undef;
    }

Christian Fibich's avatar
Christian Fibich committed
621
622
623
624
625
    if (defined($error_ref)) {
        $error_ref->{C}   = (($message_byte & 0x01) != 0);
        $error_ref->{I}   = (($message_byte & 0x02) != 0);
        $error_ref->{U}   = (($message_byte & 0x04) != 0);
        $error_ref->{ANY} = (($message_byte & 0x07) != 0);
626

Christian Fibich's avatar
Christian Fibich committed
627
        if ($error_ref->{C} != 0) {
628
629
            $logger->debug("Return message indicates CRC mismatch.");
        }
Christian Fibich's avatar
Christian Fibich committed
630
        if ($error_ref->{I} != 0) {
631
632
            $logger->debug("Return message indicates design ID mismatch.");
        }
Christian Fibich's avatar
Christian Fibich committed
633
        if ($error_ref->{U} != 0) {
634
635
636
637
            $logger->debug("Return message indicates an RX UART error.");
        }
    }

Christian Fibich's avatar
Christian Fibich committed
638
639
640
641
    if (defined($fd_ref)) {
        $fd_ref->{1}   = (($message_byte & 0x08) != 0);
        $fd_ref->{2}   = (($message_byte & 0x10) != 0);
        $fd_ref->{ANY} = (($message_byte & 0x18) != 0);
642

Christian Fibich's avatar
Christian Fibich committed
643
        if ($fd_ref->{1} != 0) {
644
645
            $logger->debug("Fault detection signal 1 active.");
        }
Christian Fibich's avatar
Christian Fibich committed
646
        if ($fd_ref->{2} != 0) {
647
648
649
650
            $logger->debug("Fault detection signal 2 active.");
        }
    }

Stefan Tauner's avatar
Stefan Tauner committed
651
652
653
654
655
656
657
658
659
    my $retmsg_type = ($message_byte >> 5) & 0x03;
    if ($retmsg_type == 0x01) {
        return 'CONF_DONE';
    } elsif ($retmsg_type == 0x02) {
        return 'READY';
    } elsif ($retmsg_type == 0x03) {
        return 'UNDERRUN';
    } else {
        return undef;
660
    }
661
662
663
}

1;