line |
stmt |
code |
1
|
|
# Copyright 2009-2013 Bernhard M. Wiedemann |
2
|
|
# Copyright 2012-2021 SUSE LLC |
3
|
|
# SPDX-License-Identifier: GPL-2.0-or-later |
4
|
|
|
5
|
|
|
6
|
|
use Mojo::Base -strict, -signatures; |
7
|
94
|
use autodie ':all'; |
|
94
|
|
|
94
|
|
8
|
94
|
use Fcntl ':flock'; |
|
94
|
|
|
94
|
|
9
|
94
|
use Time::HiRes qw(sleep); |
|
94
|
|
|
94
|
|
10
|
94
|
use IO::Socket; |
|
94
|
|
|
94
|
|
11
|
94
|
use Carp; |
|
94
|
|
|
94
|
|
12
|
94
|
use Mojo::JSON qw(encode_json); |
|
94
|
|
|
94
|
|
13
|
94
|
use Cpanel::JSON::XS (); |
|
94
|
|
|
94
|
|
14
|
94
|
use File::Path 'remove_tree'; |
|
94
|
|
|
94
|
|
15
|
94
|
use Data::Dumper; |
|
94
|
|
|
94
|
|
16
|
94
|
use Mojo::Log; |
|
94
|
|
|
94
|
|
17
|
94
|
use Mojo::File qw(path); |
|
94
|
|
|
94
|
|
18
|
94
|
use Term::ANSIColor; |
|
94
|
|
|
94
|
|
19
|
94
|
|
|
94
|
|
|
94
|
|
20
|
|
use Exporter 'import'; |
21
|
94
|
|
|
94
|
|
|
94
|
|
22
|
|
our $VERSION; |
23
|
|
our @EXPORT_OK = qw(diag fctres fctinfo fctwarn modstate save_vars); |
24
|
|
|
25
|
|
require IPC::System::Simple; |
26
|
|
use log; |
27
|
94
|
|
|
94
|
|
|
94
|
|
28
|
|
sub mydie; |
29
|
|
|
30
|
|
$| = 1; |
31
|
|
|
32
|
|
|
33
|
|
our $default_timeout = 30; # assert timeout, 0 is a valid timeout |
34
|
|
our $openqa_default_share = '/var/lib/openqa/share'; |
35
|
|
|
36
|
|
my @ocrrect; |
37
|
|
|
38
|
|
our $screenshotpath = "qemuscreenshot"; |
39
|
|
|
40
|
|
# global vars |
41
|
|
|
42
|
|
# Known locations of OVMF (UEFI) firmware: first is openSUSE, second is |
43
|
|
# the kraxel.org nightly packages, third is Fedora's edk2-ovmf package, |
44
|
|
# fourth is Debian's ovmf package. |
45
|
|
our @ovmf_locations = ( |
46
|
|
'/usr/share/qemu/ovmf-x86_64-ms-code.bin', '/usr/share/edk2.git/ovmf-x64/OVMF_CODE-pure-efi.fd', |
47
|
|
'/usr/share/edk2/ovmf/OVMF_CODE.fd', '/usr/share/OVMF/OVMF_CODE.fd' |
48
|
|
); |
49
|
|
|
50
|
|
our %vars; |
51
|
|
tie %vars, 'bmwqemu::tiedvars', %vars; |
52
|
|
|
53
|
|
|
54
|
192
|
# deprecated functions, moved to log module |
|
192
|
|
|
192
|
|
55
|
|
{ |
56
|
|
no warnings 'once'; |
57
|
|
*log_format_callback = \&log::log_format_callback; |
58
|
94
|
*diag = \&log::diag; |
|
94
|
|
|
94
|
|
59
|
|
*fctres = \&log::fctres; |
60
|
|
*fctinfo = \&log::fctinfo; |
61
|
|
*fctwarn = \&log::fctwarn; |
62
|
|
*modstate = \&log::modstate; |
63
|
|
*logger = \&log::logger; |
64
|
|
*init_logger = \&log::init_logger; |
65
|
|
} |
66
|
|
|
67
|
|
use constant STATE_FILE => 'base_state.json'; |
68
|
|
|
69
|
94
|
# Write a JSON representation of the process termination to disk |
|
94
|
|
|
94
|
|
70
|
|
bmwqemu::fctwarn($state{msg}) if delete $state{error}; |
71
|
|
bmwqemu::diag($state{msg}) if delete $state{log}; |
72
|
14
|
return undef if -e STATE_FILE; |
|
14
|
|
|
14
|
|
73
|
14
|
eval { path(STATE_FILE)->spurt(encode_json(\%state)) }; |
74
|
14
|
bmwqemu::diag("Unable to serialize fatal error: $@") if $@; |
75
|
14
|
} |
76
|
8
|
|
|
8
|
|
77
|
8
|
my $fn = "vars.json"; |
78
|
|
my $ret = {}; |
79
|
|
local $/; |
80
|
33
|
my $fh; |
|
33
|
|
81
|
33
|
eval { open($fh, '<', $fn) }; |
82
|
33
|
return 0 if $@; |
83
|
33
|
eval { $ret = Cpanel::JSON::XS->new->relaxed->decode(<$fh>); }; |
84
|
33
|
die "parse error in vars.json:\n$@" if $@; |
85
|
33
|
close($fh); |
|
33
|
|
86
|
33
|
%vars = %{$ret}; |
87
|
22
|
return; |
|
22
|
|
88
|
22
|
} |
89
|
22
|
|
90
|
22
|
my $fn = "vars.json"; |
|
22
|
|
91
|
22
|
unlink "vars.json" if -e "vars.json"; |
92
|
|
open(my $fd, ">", $fn); |
93
|
|
flock($fd, LOCK_EX) or die "cannot lock vars.json: $!\n"; |
94
|
85
|
truncate($fd, 0) or die "cannot truncate vars.json: $!\n"; |
|
85
|
|
|
85
|
|
95
|
85
|
|
96
|
85
|
my $write_vars = \%vars; |
97
|
85
|
if ($args{no_secret}) { |
98
|
85
|
$write_vars = {}; |
99
|
85
|
$write_vars->{$_} = $vars{$_} for (grep !/(^_SECRET_|_PASSWORD)/, keys(%vars)); |
100
|
|
} |
101
|
85
|
|
102
|
85
|
# make sure the JSON is sorted |
103
|
23
|
my $json = Cpanel::JSON::XS->new->pretty->canonical; |
104
|
23
|
print $fd $json->encode($write_vars); |
105
|
|
close($fd); |
106
|
|
return; |
107
|
|
} |
108
|
85
|
|
109
|
85
|
our $gocrbin = "/usr/bin/gocr"; |
110
|
85
|
|
111
|
85
|
# set from isotovideo during initialization |
112
|
|
our $scriptdir; |
113
|
|
|
114
|
|
load_vars(); |
115
|
|
|
116
|
|
$vars{BACKEND} ||= "qemu"; |
117
|
|
|
118
|
|
# remove directories for asset upload |
119
|
29
|
remove_tree("assets_public"); |
|
29
|
|
120
|
29
|
remove_tree("assets_private"); |
121
|
|
|
122
|
29
|
remove_tree(result_dir); |
123
|
|
mkdir result_dir; |
124
|
|
mkdir join('/', result_dir, 'ulogs'); |
125
|
29
|
|
126
|
29
|
log::init_logger; |
127
|
|
} |
128
|
29
|
|
129
|
29
|
return 0 unless my $nd = $vars{NUMDISKS}; |
130
|
29
|
my @hdds = map { $vars{"HDD_$_"} } 1 .. $nd; |
131
|
|
for my $i (1 .. $nd) { |
132
|
29
|
for my $type (qw(STORE PUBLISH FORCE_PUBLISH)) { |
133
|
|
my $name = $type . "_HDD_$i"; |
134
|
|
next unless my $out = $vars{$name}; |
135
|
27
|
die "HDD_$i also specified in $name. This is not supported" if grep { $_ && $_ eq $out } @hdds; |
|
27
|
|
136
|
27
|
} |
137
|
2
|
} |
|
2
|
|
138
|
2
|
return 1; |
139
|
2
|
} |
140
|
5
|
|
141
|
5
|
# defaults |
142
|
2
|
$vars{QEMUPORT} ||= 15222; |
|
2
|
|
143
|
|
$vars{VNC} ||= 90; |
144
|
|
# openQA already sets a random string we can reuse |
145
|
1
|
$vars{JOBTOKEN} ||= random_string(10); |
146
|
|
|
147
|
|
if ($gocrbin && !-x $gocrbin) { |
148
|
26
|
$gocrbin = undef; |
|
26
|
|
149
|
|
} |
150
|
26
|
|
151
|
26
|
die "CASEDIR variable not set, unknown test case directory" if !defined $vars{CASEDIR}; |
152
|
|
die "No scripts in CASEDIR '$vars{CASEDIR}'\n" unless -e $vars{CASEDIR}; |
153
|
26
|
_check_publish_vars(); |
154
|
|
save_vars(); |
155
|
26
|
} |
156
|
26
|
|
157
|
|
## some var checks end |
158
|
|
|
159
|
26
|
# global vars end |
160
|
25
|
|
161
|
25
|
# local vars |
162
|
25
|
|
163
|
|
our $backend; |
164
|
|
|
165
|
|
# local vars end |
166
|
|
|
167
|
|
# util and helper functions |
168
|
|
|
169
|
|
require autotest; |
170
|
|
no warnings 'once'; |
171
|
|
return $autotest::current_test; |
172
|
|
} |
173
|
|
|
174
|
|
return unless current_test; |
175
|
|
return unless current_test->{script}; |
176
|
|
my @out; |
177
|
272
|
my $casedir = $vars{CASEDIR} // ''; |
|
272
|
|
178
|
272
|
for (my $i = 10; $i > 0; $i--) { |
179
|
94
|
my ($package, $filename, $line, $subroutine) = caller($i); |
|
94
|
|
|
94
|
|
180
|
272
|
next unless $filename && $filename =~ /\Q$casedir/; |
181
|
|
$filename =~ s@$casedir/?@@; |
182
|
|
push @out, "$filename:$line called $subroutine"; |
183
|
251
|
} |
|
251
|
|
184
|
251
|
log::logger->debug(join(' -> ', @out)); |
185
|
21
|
return; |
186
|
1
|
} |
187
|
1
|
|
188
|
1
|
# pretty print like Data::Dumper but without the "VAR1 = " prefix |
189
|
10
|
# FTR, I actually hate Data::Dumper. |
190
|
10
|
my $value_with_trailing_newline = Data::Dumper->new(\@args)->Terse(1)->Useqq(1)->Dump(); |
191
|
10
|
chomp($value_with_trailing_newline); |
192
|
10
|
return $value_with_trailing_newline; |
193
|
|
} |
194
|
1
|
|
195
|
1
|
# Use special argument `-masked` to hide the given value in log output. |
196
|
|
# It can be specified multiple times and or the value can be a ARRAY_REF or |
197
|
|
# scalar. |
198
|
|
my $fname = (caller(1))[3]; |
199
|
925
|
update_line_number(); |
|
925
|
|
|
925
|
|
200
|
|
|
201
|
925
|
# extract -masked parameter out of argument list |
202
|
925
|
my @masked; |
203
|
925
|
my @effective_args; |
204
|
|
while (@args) { |
205
|
|
my $v = shift @args; |
206
|
|
if (defined($v) && $v eq '-masked' && @args) { |
207
|
|
my $mval = shift @args; |
208
|
|
push @masked, ref($mval) eq 'ARRAY' ? @$mval : $mval; |
209
|
249
|
} else { |
|
249
|
|
|
249
|
|
210
|
249
|
push @effective_args, $v; |
211
|
249
|
} |
212
|
|
} |
213
|
|
|
214
|
249
|
my $params; |
215
|
|
if (@effective_args == 1) { |
216
|
249
|
$params = pp($effective_args[0]); |
217
|
1812
|
} |
218
|
1812
|
else { |
219
|
9
|
# key/value pairs |
220
|
9
|
my @result; |
221
|
|
while (my ($key, $value) = splice(@effective_args, 0, 2)) { |
222
|
1803
|
if ($key =~ tr/0-9a-zA-Z_//c) { |
223
|
|
# only quote if needed |
224
|
|
$key = pp($key); |
225
|
|
} |
226
|
249
|
push @result, join("=", $key, pp($value)); |
227
|
249
|
} |
228
|
1
|
$params = join(", ", @result); |
229
|
|
} |
230
|
|
|
231
|
|
foreach (@masked) { |
232
|
248
|
my $mask = pp($_); |
233
|
248
|
$mask =~ s/^"(.*)"$/$1/; |
234
|
901
|
$params =~ s/\Q$mask\E/[masked]/g; |
235
|
|
} |
236
|
1
|
|
237
|
|
log::logger->debug('<<< ' . $fname . "($params)"); |
238
|
901
|
return; |
239
|
|
} |
240
|
248
|
|
241
|
|
# util and helper functions end |
242
|
|
|
243
|
249
|
# backend management |
244
|
11
|
|
245
|
11
|
return unless $backend; |
246
|
11
|
my $ret = $backend->stop(); |
247
|
|
return $ret; |
248
|
|
} |
249
|
249
|
|
250
|
249
|
log_call(cause_of_death => $cause_of_death); |
251
|
|
croak "mydie"; |
252
|
|
} |
253
|
|
|
254
|
|
# runtime information gathering functions end |
255
|
|
|
256
|
|
|
257
|
3
|
# store the obj as json into the given filename |
|
3
|
|
258
|
3
|
open(my $fd, ">", "$fn.new"); |
259
|
3
|
my $json = Cpanel::JSON::XS->new->pretty->canonical->encode($result); |
260
|
3
|
print $fd $json; |
261
|
|
close($fd); |
262
|
|
return rename("$fn.new", $fn); |
263
|
9
|
} |
|
9
|
|
|
9
|
|
264
|
9
|
|
265
|
9
|
return $timeout * ($vars{TIMEOUT_SCALE} // 1); |
266
|
|
} |
267
|
|
|
268
|
|
=head2 random_string |
269
|
|
|
270
|
|
random_string([$count]); |
271
|
|
|
272
|
1
|
Just a random string useful for pseudo security or temporary files. |
|
1
|
|
|
1
|
|
|
1
|
|
273
|
1
|
=cut |
274
|
1
|
$count //= 4; |
275
|
1
|
my $string; |
276
|
1
|
my @chars = ('a' .. 'z', 'A' .. 'Z'); |
277
|
1
|
$string .= $chars[rand @chars] for 1 .. $count; |
278
|
|
return $string; |
279
|
|
} |
280
|
41
|
|
|
41
|
|
|
41
|
|
281
|
41
|
# sleeping for one second should ensure that one more screenshot is taken |
282
|
|
|
283
|
|
use Tie::Hash; |
284
|
|
use base qw/ Tie::StdHash /; # no:style prevent style warning regarding use of Mojo::Base and base in this file |
285
|
|
use Carp (); |
286
|
|
|
287
|
|
my $self = bless { |
288
|
|
data => {%args}, |
289
|
|
}, $class; |
290
|
555
|
} |
|
555
|
|
|
555
|
|
291
|
555
|
|
292
|
555
|
warn Carp::longmess "Settings key '$key' is invalid" unless $key =~ m/^(?:[A-Z0-9_]+)\z/; |
293
|
555
|
$self->{data}->{$key} = $val; |
294
|
555
|
} |
295
|
555
|
|
296
|
|
my $data = $self->{data}; |
297
|
|
my @k = keys %$data; # reset |
298
|
|
my $next = each %$data; |
299
|
1
|
} |
|
1
|
|
|
1
|
|
300
|
|
|
301
|
|
my $data = $self->{data}; |
302
|
94
|
my $next = each %$data; |
|
94
|
|
|
94
|
|
303
|
94
|
} |
|
94
|
|
|
94
|
|
304
|
94
|
|
|
94
|
|
|
94
|
|
305
|
|
my $val = $self->{data}->{$key}; |
306
|
94
|
} |
|
94
|
|
|
94
|
|
|
94
|
|
307
|
94
|
|
308
|
|
|
309
|
|
|
310
|
|
|
311
|
|
|
312
|
868
|
1; |
|
868
|
|
|
868
|
|
|
868
|
|
|
868
|
|