Utils.pm 8.31 KB
Newer Older
1
2
3
4
#-----------------------------------------------------------------------
# Fault InJection Instrumenter (FIJI)
# https://embsys.technikum-wien.at/projects/vecs/fiji
#
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>
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
#
# This module is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
# 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.
#
# See the LICENSE file for more details.
#-----------------------------------------------------------------------

## @file Utils.pm
# @brief Contains class \ref FIJI::Utils

## @class FIJI::Utils
# @brief Various (non-TK) helper functions for FIJI

Stefan Tauner's avatar
Stefan Tauner committed
29
package FIJI::Utils;
30

31
32
use strict;
use warnings;
33

Stefan Tauner's avatar
Stefan Tauner committed
34
use Log::Log4perl qw(get_logger);
35
use Log::Log4perl::Level;
36
use File::Basename qw(basename);
37
use Cwd 'realpath';
38
39
40
use if $^O eq "MSWin32", 'Win32::TieRegistry';
use if $^O eq "MSWin32", 'File::DosGlob' => qw(glob);
use if $^O ne "MSWin32", 'File::Glob' => qw(:bsd_glob);
41
use FIJI qw(:fiji_version);
42
43
44
45
46
47
48
49
50
51
52
53
54
55

use Data::Dumper;

sub glob_path {
    my $path = shift;
    if ($^O ne "MSWin32") {
        $path = bsd_glob($path);
    } else {
        # Do this for windows
        $path = glob($path);
    }
    # TODO: Validate path here, apply realpath?
    return $path;
}
Stefan Tauner's avatar
Stefan Tauner committed
56

Stefan Tauner's avatar
Stefan Tauner committed
57
58
59
60
61
62
63
64
65
## function increase_verbosity($verbosity_delta)
#
# @brief Increase the verbosity of user-visible loggers (appenders).
#
# @param verbosity_delta    An integer >= 0 that specifies how many levels the verbosity should be increased
# @return                   Returns the now active threshold level
sub increase_verbosity {
    my $verbosity_delta = shift;
    return $Log::Log4perl::Logger::APPENDER_BY_NAME{"screen"}->threshold() unless defined($verbosity_delta) && ($verbosity_delta > 0);
66

67
    my $logger = get_logger("");
68
69
70
71
72
73
74
75
    my $new_threshold;
    # We set the verbosity only for the appenders listed here.
    # This excludes for example the log file appender that should
    # always write the TRACE output.
    foreach my $app_name ("screen", "string") {
        my $appender = $Log::Log4perl::Logger::APPENDER_BY_NAME{$app_name};
        next if !defined($appender);
        my $old_threshold = $appender->threshold();
Stefan Tauner's avatar
Stefan Tauner committed
76
77
        $new_threshold = $appender->threshold(Log::Log4perl::Level::get_lower_level($old_threshold, $verbosity_delta));
        $logger->debug("Verbosity delta: $verbosity_delta. Decreased log threshold for " . $appender->{'name'} . " from ", Log::Log4perl::Level::to_level( $old_threshold ), " to ", Log::Log4perl::Level::to_level( $new_threshold ));
78
    }
79
    return $new_threshold;
80
81
}

Stefan Tauner's avatar
Stefan Tauner committed
82
sub system {
Christian Fibich's avatar
Christian Fibich committed
83
84
85
    my $logger = get_logger("");
    my @cli    = @_;
    my $ret    = undef;
Stefan Tauner's avatar
Stefan Tauner committed
86
87
    my $output = `@cli 2>&1`;
    if ($? == -1) {
88
89
90
        my $msg = "failed to execute \"@_\": $!";
        $logger->error($msg);
        $ret .= $msg;
Stefan Tauner's avatar
Stefan Tauner committed
91
    } elsif ($? & 127) {
Christian Fibich's avatar
Christian Fibich committed
92
93
94
95
        my $err = sprintf(
            "Child died due to signal %d, %s coredump\n",
            ($? & 127), ($? & 128) ? 'with' : 'without'
        );
Stefan Tauner's avatar
Stefan Tauner committed
96
97
98
99
100
101
102
103
104
105
106
        $logger->error($err);
        $ret .= $err;
    } elsif (($? >> 8) != 0) {
        my $err = sprintf("Child %s exited with value %d\n", $cli[0], $? >> 8);
        $logger->error($err);
        $ret .= $err;
    }
    $logger->debug("Output was: $output") if $output;
    return $ret;
}

107
108
# @param tests_name  either a path relative to the given tests file, or
#                    an absolute path, pointing to the Perl script to execute.
109
110
111
112
113
114
115
sub execute_completion_script {
    my $logger  = get_logger("");
    my ($script_name, $tests_name, $downloader_reply, $starttime, $endtime, $faulty_test, $logmessages) = @_;
    if (defined($script_name) && ($script_name ne "")) {
        my $rv;
        {
            local @ARGV = ($downloader_reply, $starttime, $endtime, $faulty_test, $logmessages);
116
117
118
119
120
121
122
            my $script;
            if (!File::Spec->file_name_is_absolute($script_name)) {
                my ($basevolume, $basedirs, $fn) = File::Spec->splitpath($tests_name);
                $script = realpath(File::Spec->catpath($basevolume, $basedirs, $script_name));
            } else {
                $script = $script_name;
            }
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
            $logger->info("Executing completion script \"$script\"");
            $rv = do $script;
            if (!defined $rv) {
                my $script_msg = "Executing COMPLETION_SCRIPT failed: ";
                if ($@) {
                    $script_msg .= $@;
                } elsif ($!) {
                    $script_msg .= $!;
                } else {
                    $script_msg .= "An unknown error ocurred.";
                }
                $logger->error($script_msg);
            } else {
                $logger->debug("Completion script returned $rv.");
            }
        }
        return $rv;
    }
}

143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
# @function log_start($load_config, $use_string_buffer, ...)
# Initializes the logger and logs application parameters
#
# @param load_config        (Re-)Load the logger configuration from a file.
# @param use_string_buffer  The default logger configuration saves all log lines into
#                           a buffer to make it available to the application. This
#                           option allows for explicitly disabling this buffer.
# @param ...                @ARGV
sub log_start {
    my $load_config = shift;
    my $use_string_buffer = shift;

    if ($load_config) {
        my $log_conf = File::Spec->catfile($FindBin::Bin, 'logger.conf');
        Log::Log4perl::init_and_watch($log_conf, 'HUP');
    }
    # No need for buffered log output?
    if (!$use_string_buffer) {
        Log::Log4perl->eradicate_appender("string");
    }

    my $name = basename($0);
    $name =~ s/\.p[lm]//;
    my $logger = get_logger("");
    my $fiji_version = FIJI_VERSION;
    $logger->info("=== Starting new execution of $name $fiji_version ===");
    $logger->info(sprintf("%d argument(s)%s", scalar(@_), scalar(@_) > 0 ? ": @_" : ""));
}

Stefan Tauner's avatar
Stefan Tauner committed
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
sub add_appender {
    my $logger = get_logger("");
    my ($custom_appender, $log4p_level) = @_;
    my $conf = Log::Log4perl::Config::PropertyConfigurator->new();
    my $logger_conf = Log::Log4perl::Config::watcher()->file();
    $conf->file($logger_conf);
    eval{$conf->parse()}; # would die() on error
    my $layout_pattern_short;
    if ($@) {
        $layout_pattern_short = "%d{HH:mm:ss.SSS} %p - %m%n";
        $logger->error("Could not parse $logger_conf to get shortened pattern for live logging)\n".
                       "Using \"$layout_pattern_short\" instead.");
    } else {
        $layout_pattern_short = $conf->value("layout_pattern_short");
    }
    my $layout = Log::Log4perl::Layout::PatternLayout->new($layout_pattern_short);
    $custom_appender->layout($layout);
    $custom_appender->threshold($log4p_level);
    $logger->add_appender($custom_appender);
}

193
194
195
196
197
sub get_uart_devs {
    my $logger  = get_logger("");
    my $choices = [];
    my @s;
    if ($^O eq "MSWin32") {
198
        my $reg = new Win32::TieRegistry("LMachine\\Hardware\\DEVICEMAP\\",{Access=>Win32::TieRegistry::KEY_READ(),Delimiter=>"\\"});
199
200
201
        if (!defined $reg) {
            $logger->error("Can't access registry key: $^E");
        } else {
202
203
204
205
206
207
208
            my $serialcomm = $reg->Open("SERIALCOMM\\");
            if (!defined $serialcomm) {
                $logger->error("No serial ports found: $^E");
            } else {
                foreach my $port ($serialcomm->ValueNames) {
                    push(@s, $serialcomm->GetValue($port));
                }
209
210
            }
        }
211
212
    } elsif ($^O eq "cygwin") {
        @s = glob("/dev/ttyS*");
213
214
215
    } elsif ($^O eq "linux") {
        # This relies on udev persistent serial rules.
        # They do only cover devices detected by udev thus
216
217
218
219
220
221
222
        # may exclude native UARTs (e.g., /dev/ttyS0)
        # We also try to include symlinks named /dev/tty* that
        # point to actual UARTs.
        @s = map {
            my $tty = $_;
            my @uart_ttys = grep { realpath($tty) eq realpath($_) } glob("/dev/tty*");
        } map {realpath($_)} glob("/dev/serial/by-id/*");
223
224
225
226
227
    }
    $choices = \@s;
    return $choices;
}

Stefan Tauner's avatar
Stefan Tauner committed
228
1;