« back to all changes in this revision
Viewing changes to utils/Report.pm
- browse files at revision 1
- compare with another revision
- download diff
- download tarball
- view history from revision 1
- Committer: biga
- Date: 2009-04-24 14:16:44 UTC
- Revision ID: biga@spidey.linux-foundation.org-20090424141644-7evzd6mjocix7e68
init
- files added:
- bin
- config
- package
- ptyshell
- utils
- utils/Tests
- utils/Tests/templates
- utils/Tests/templates/manual
- webui
- webui/public_html
- webui/public_html/css
- webui/public_html/images
- webui/public_html/images/app_battery
added
removed
utils/Report.pm
1
# LSB Test Execution Framework
2
# Report Generation Routines (Report.pm)
3
#
4
# Copyright (C) 2007-2009 The Linux Foundation. All rights reserved.
5
#
6
# This program has been developed by ISP RAS for LF.
7
# The ptyshell tool is originally written by Jiri Dluhos <jdluhos@suse.cz>
8
# Copyright (C) 2005-2007 SuSE Linux Products GmbH
9
#
10
# This program is free software; you can redistribute it and/or
11
# modify it under the terms of the GNU General Public License
12
# version 2 as published by the Free Software Foundation.
13
#
14
# This program is distributed in the hope that it will be useful,
15
# but WITHOUT ANY WARRANTY; without even the implied warranty of
16
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17
# GNU General Public License for more details.
18
#
19
# You should have received a copy of the GNU General Public License
20
# along with this program; if not, write to the Free Software
21
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
22
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
23
24
package Report;
25
use strict;
26
27
use Common;
28
29
# Export symbols
30
require Exporter;
31
our @ISA = qw(Exporter);
32
our @EXPORT = qw(
33
&html &pre_wrap
34
);
35
#----------------------------------------------------------------------
36
37
# Journal structure:
38
# $jstruct -> {
39
# FILE, TESTSUITE,
40
# KIND => TET|SIMPLE|TCL|PYTHON, # kind of the journal
41
# STATS => { PASSED, WARNINGS, TESTS_TOTAL, NOTICES, FIPS, TESTS_EXPECTED,
42
# TESTSUITE_ERRORS, UNTESTED, FAILURES, QUELLED }, # statistical data
43
#
44
# # @ARR elements can be of two types.
45
# # Passed and untested test cases are stored as scalars (to save memory),
46
# # and their format is "$severity:$test_name",
47
# # where $severity is an empty line "" for passed test cases.
48
# # Hash type is for other test result types and can contain various details.
49
# ARR => [ $testcase_ok |
50
# {TEST_NAME, TEST_POINT, TEST_NUM, SEVERITY, MESSAGE, LINE_NUM, COMMENT}
51
# ],
52
# TESTS_EXPECTED, # expected number of test cases
53
# INFO_TABLES, # information from journal header
54
# };
55
56
# Map of TET result codes to human-readable severity names.
57
our %result_code_map = (
58
0 => "Passed",
59
1 => "Failed",
60
2 => "Unresolved",
61
3 => "Unused",
62
4 => "Unsupported",
63
5 => "Untested",
64
6 => "Uninitiated",
65
7 => "Unreported",
66
65 => "Time expired",
67
101 => "Warning",
68
102 => "FIP",
69
103 => "Unimplemented",
70
104 => "Unapproved",
71
);
72
73
#----------------------------------------------------------------------
74
75
our %severity_map = (
76
"passed" => 'passed',
77
78
"failed" => 'failed',
79
"unresolved" => 'failed',
80
"uninitiated" => 'failed',
81
"unreported" => 'failed',
82
"time expired" => 'failed',
83
84
"unused" => 'untested',
85
"unsupported" => 'untested',
86
"untested" => 'untested',
87
"unimplemented" => 'untested',
88
"unapproved" => 'untested',
89
90
"fip" => 'fip',
91
92
"warning" => 'warning',
93
"testsuite_warning" => 'warning',
94
95
"notice" => 'notice',
96
"testsuite_notice" => 'notice',
97
98
"testsuite_error" => 'testsuite_error',
99
);
100
101
#----------------------------------------------------------------------
102
103
# HTML colors used in the report.
104
my $dark_gray = "#555555";
105
my $gray = "#C8C8C8";
106
my $neutral_gray = "#888888";
107
my $light_gray = "#F0F0F0";
108
my $dark_blue = "#000080";
109
my $dark_green = "#006600";
110
my $fluorescent_green = "#40FF40";
111
my $fluorescent_yellow = "#FFFF40";
112
my $fluorescent_red = "#FF6060";
113
my $green = "#00A000";
114
115
#----------------------------------------------------------------------
116
117
# Problem database records
118
our $problem_database;
119
120
my $box_id = 0; # To generate unique IDs for HTML elements.
121
122
our $cert_mode = 0; # For TRIAL-USE tests
123
124
our $result_dir = undef;
125
126
#----------------------------------------------------------------------
127
128
# Loads the problem database which is used for automatic identification
129
# of known test suite failures, warnings and false positives.
130
sub load_problem_database {
131
my ($file_name) = @_;
132
133
# Open the database file.
134
open FILE, $file_name
135
or return error "Failed to open problem database '$file_name': $!";
136
137
# The problem record being read.
138
my $problem;
139
140
while ( my $line = <FILE> ) {
141
142
$line =~ s/^\s+//; # Remove spaces in the beginning of the line
143
$line =~ s/\s+$//; # Remove trailing spaces
144
145
next if $line eq ""; # Skip empty lines
146
next if $line =~ /^#/; # Skip comments
147
148
if ( !$problem ) {
149
# The 'test' line starts a new test record.
150
# It contains the name of the test and the test point number.
151
if ($line =~ /^test\s+(.*)$/) {
152
my $test_name = $1;
153
154
# Clear the old record and prepare a clean one.
155
$problem = {
156
'test_name' => $test_name,
157
};
158
159
next;
160
}
161
else {
162
warning "problem_db: $.:"
163
." Unexpected text beyound a test block: '$line'";
164
}
165
}
166
167
# The 'expected_severity' line indicates the severity
168
# expected to be reported by the test suite.
169
if ( $line =~ /^expected_severity\s+(.*)/ ) {
170
my $expected_severity = lc($1);
171
172
# Check if the expected severity is one of the predefined values.
173
if ( !defined $severity_map{$expected_severity} ) {
174
warning "problem_db: $.:"
175
.($problem ? " ".$problem->{'test_name'}.":" : "")
176
." unrecognized expected_severity '$expected_severity'."
177
." Allowed values are: ".(join ", ", keys %severity_map);
178
}
179
180
$problem->{'expected_severity'} = $expected_severity;
181
}
182
# The 'marker' line contains a marker which can be found
183
# to identify the particular problem from the messages.
184
# There may be (and typically are) more markers, each on its own
185
# 'marker' line.
186
elsif ( $line =~ /^marker\s+(.*)/ ) {
187
my $marker = $1;
188
push @{$problem->{'markers'}}, $marker;
189
}
190
# The 'resolution' line contains the resolution of the problem.
191
elsif ($line =~ /^resolution\s+(.*)/) {
192
my $resolution = $1;
193
$problem->{'resolution'} = $resolution;
194
}
195
# If the 'quell' line is present, the problem is considered harmless
196
# regardless of severity. This is used for already solved bugs
197
# and false positives.
198
elsif ($line =~ /^quell(\s+(.*))?/) {
199
my $force_severity = $2;
200
$force_severity = 1 if !$force_severity;
201
202
$problem->{'quell'} = $force_severity;
203
}
204
# The 'comment' line holds a comment for human reader
205
# which is copied to the problem report. There can be more
206
# comment lines.
207
elsif ($line =~ /^comment\s+(.*)/) {
208
my $text = $1;
209
210
$problem->{'comment'} .= "\n" if $problem->{'comment'};
211
$problem->{'comment'} .= $text;
212
}
213
# The 'lsb_report_id' contains the LSB problem report ID.
214
elsif ($line =~ /^lsb_report_id\s+(\S+)$/) {
215
$problem->{'lsb_report_id'} = $1;
216
}
217
# The 'lsb_resolution_id' contains the LSB resolution ID.
218
elsif ($line =~ /^lsb_resolution_id\s+(\S+)$/) {
219
$problem->{'lsb_resolution_id'} = $1;
220
}
221
# 'dup' means that problem description should be copied for
222
# another test case.
223
# NOTE: 'dup' should go AFTER all records to be copied.
224
# In other words, if you put something below 'dup', it won't be copied.
225
elsif ($line =~ /^dup\s+(.*)$/) {
226
my $dup_test_name = $1;
227
228
my $copy = { %$problem };
229
$copy->{'test_name'} = $dup_test_name;
230
231
# Add the same problem record to the database with another key.
232
push @{$problem_database->{$dup_test_name}}, $copy;
233
}
234
# The 'end' line finishes one problem entry.
235
elsif ($line =~ /^end/) {
236
237
# Check if this problem report has all required fields.
238
unless ( $problem->{'expected_severity'} ) {
239
warning "problem_db: $.:"
240
.($problem ? " ".$problem->{'test_name'}.":" : "")
241
." expected_severity field is required.";
242
}
243
244
# The problem record database is indexed by the test name.
245
# Add the problem record to the database.
246
push @{$problem_database->{$problem->{'test_name'}}}, $problem;
247
248
$problem = undef; # Close the problem record.
249
}
250
# Anything else is a syntax error.
251
else {
252
warning "problem_db: $.:"
253
.($problem ? " ".$problem->{'test_name'}.":" : "")
254
." Unrecognized line: '$line'";
255
}
256
}
257
close FILE;
258
259
return 1; # OK
260
}
261
#---------------------------------------------------------------------
262
263
# Finds problem record in the database.
264
sub find_problem_record {
265
my ( %data ) = @_;
266
267
my $test_name = $data{TEST_NAME};
268
my $test_point = $data{TEST_POINT};
269
my $severity = $data{SEVERITY};
270
my $test_messages = $data{MESSAGE};
271
272
# Some automatically generated problem reports have no test name or point;
273
# these are not meant to be searched in the database but directly reported
274
# to the user.
275
return undef if !$test_name;
276
277
# TODO: bind each problem record to version(s) of test suite.
278
# TODO: regexp in matcher.
279
280
# The basic record key is the name of the test and the test point number.
281
my $record_key = $test_name;
282
$record_key .= " " . $test_point if defined $test_point && $test_point ne "";
283
284
# Get all records matching the key
285
( $problem_database ) or return undef;
286
my $found_records = $problem_database->{$record_key};
287
288
return undef if !$found_records || !@$found_records; # Nothing found;
289
290
# Try finding the problem record.
291
PROBLEM_RECORD:
292
foreach my $problem_record ( @$found_records ) {
293
294
# Check if the severity matches.
295
my $expected_severity = $problem_record->{'expected_severity'};
296
next PROBLEM_RECORD unless lc($severity) eq lc($expected_severity);
297
298
# Look which distinguishing markers the problem should have.
299
my $markers = $problem_record->{'markers'};
300
301
# Check if the markers are found in the test messages.
302
foreach my $marker ( @$markers ) {
303
unless ( index($test_messages, $marker) >= 0 ) {
304
# The message doesn't match to marker.
305
next PROBLEM_RECORD; # Try another problem record.
306
}
307
}
308
309
# All the markes match.
310
# Yup, this is the problem report we looked for.
311
return $problem_record;
312
}
313
314
# Nothing was found.
315
return undef;
316
}
317
#---------------------------------------------------------------------
318
319
# Escape HTML entities
320
sub html {
321
my ($text) = @_;
322
323
( defined $text ) or return error "Undefined parameter";
324
325
$text =~ s/&/&/g;
326
327
$text =~ s/</</g;
328
$text =~ s/>/>/g;
329
330
return $text;
331
}
332
#----------------------------------------------------------------------
333
334
# Wrap long lines
335
sub pre_wrap {
336
my ($text, $max) = @_;
337
338
$max = 95 unless $max;
339
340
my $res = ""; my $line = ""; my $q = 0;
341
my $text_len = length $text;
342
343
for ( my $i=0; $i < $text_len; $i++ ) {
344
my $c = substr( $text, $i, 1 );
345
$line .= $c; $q++; # increase the line
346
if ( $c eq "\n" ) {
347
$res .= $line; # flush the line
348
$line = ""; $q = 0;
349
}
350
elsif ( $q >= $max && $i+1 < $text_len ) {
351
# Wrap the line
352
for ( ; $q > 0; $q-- ) {
353
last if ( substr($line, $q-1, 1) =~ /^\s+$/ );
354
}
355
$q > 0 or $q = $max;
356
357
$res .= substr( $line, 0, $q )."\n";
358
$line = substr( $line, $q ); $q = length $line;
359
}
360
}
361
$res .= $line;
362
363
return $res;
364
}
365
#----------------------------------------------------------------------
366
367
sub ErrMessage {
368
my ($message) = @_;
369
370
my $res = "";
371
372
$res = '<pre class="errmsg">'.html(pre_wrap($message, 80)).'</pre>';
373
374
return $res;
375
}
376
#----------------------------------------------------------------------
377
378
# Makes a hyperlink to a file in the "results" subdir.
379
sub local_href {
380
my ($href, $content, $more) = @_;
381
382
( defined $href ) or return error "Undefined parameter";
383
384
$content = $href if !defined $href;
385
386
if ( !defined $more ) {
387
$more = 'target="_blank"';
388
}
389
390
my $res = "";
391
392
my $link = $href;
393
if ( $link !~ /^\// && defined $result_dir ) {
394
$link = $result_dir.'/'.$link;
395
}
396
if ( $link =~ /^\// ) {
397
$res .= '<a class="view_srv" '.$more.' href="'.html('/get.pl?file='.$link).'">'
398
.$content.'</a>';
399
}
400
401
if ( defined $result_dir && $href =~ /^\// ) {
402
if ( substr($href,0,length($result_dir)) eq $result_dir ) {
403
$href = substr($href,length($result_dir));
404
$href =~ s{^/+}{};
405
}
406
}
407
if ( $href !~ /^\.*\// ) {
408
$href = "./".$href;
409
}
410
$href =~ s/\?.*//; # remove get parameters if any
411
$res .= '<a class="view_as_is" '.$more.' href="'.html($href).'">'.$content.'</a>';
412
413
return $res;
414
}
415
#----------------------------------------------------------------------
416
417
sub ParseJournal {
418
my ($jstruct) = @_;
419
420
( defined $jstruct ) or return error "Undefined parameter";
421
( ref($jstruct) eq 'HASH' ) or return error "Wrong parameter";
422
423
my $kind = $jstruct->{KIND} or return error "Journal kind undefined";
424
my $file = $jstruct->{FILE} or return error "Journal file undefined";
425
426
if ( $kind eq 'TET' ) {
427
is_ok ParseTetJournal( $jstruct )
428
or return error "Failed to parse TET journal '$file'", $Error::Last;
429
}
430
elsif ( $kind eq 'SIMPLE' ) {
431
is_ok ParseSimpleJournal( $jstruct )
432
or return error "Failed to parse Simple journal '$file'", $Error::Last;
433
}
434
elsif ( $kind eq 'TCL' ) {
435
is_ok ParseTclJournal( $jstruct )
436
or return error "Failed to parse TCL journal '$file'", $Error::Last;
437
}
438
elsif ( $kind eq 'PYTHON' ) {
439
is_ok ParsePythonJournal( $jstruct )
440
or return error "Failed to parse Python journal '$file'", $Error::Last;
441
}
442
else {
443
return error "Unknown journal kind: '$kind'";
444
}
445
446
# Calculate statistics
447
my $stats = {
448
TESTS_TOTAL => 0,
449
PASSED => 0,
450
FAILURES => 0,
451
WARNINGS => 0,
452
QUELLED => 0,
453
NOTICES => 0,
454
UNTESTED => 0,
455
FIPS => 0,
456
TESTS_EXPECTED => undef,
457
TESTSUITE_ERRORS => 0,
458
};
459
460
foreach my $obj ( @{$jstruct->{ARR}} ) {
461
$stats->{TESTS_TOTAL}++;
462
463
if ( ref($obj) eq "" ) {
464
my $severity;
465
my $testcase;
466
if ( $obj =~ /^([^:]*):(.*)$/ ) {
467
$severity = $1;
468
if ( $severity eq "" ) { $severity = "passed" }
469
$testcase = $2;
470
}
471
else {
472
warning "Wrong jstruct entry: '$obj'";
473
next;
474
}
475
476
my $gen_severity = $severity;
477
$gen_severity = $severity_map{$severity} if defined $severity_map{$severity};
478
479
if ( $gen_severity eq 'passed' ) {
480
$stats->{PASSED}++;
481
}
482
elsif ( $gen_severity eq 'untested' ) {
483
$stats->{UNTESTED}++;
484
}
485
else {
486
warning "Unknown severity code: '$severity'";
487
next;
488
}
489
490
next;
491
}
492
# else:
493
494
if ( ref($obj) ne "HASH" ) {
495
warning "Wrong entry type in jstruct";
496
next;
497
}
498
499
my $severity = $obj->{SEVERITY};
500
501
my $gen_severity = $severity;
502
$gen_severity = $severity_map{$severity} if defined $severity_map{$severity};
503
504
$stats->{TESTS_TOTAL}-- if $severity =~ /^testsuite_/; # Not a real test case
505
506
if ( $severity =~ /(quelled|waived)/ ) { # Contains "quelled" or "waived"
507
$stats->{QUELLED}++; # Increment the quelled tests count statistic.
508
}
509
elsif ( $gen_severity eq "testsuite_error" ) {
510
$stats->{TESTSUITE_ERRORS}++;
511
}
512
elsif ( $gen_severity eq "failed" ) {
513
$stats->{FAILURES}++; # Increment the number of failures reported.
514
}
515
elsif ( $gen_severity eq "warning" ) {
516
$stats->{WARNINGS}++; # Increment the number of warnings reported.
517
}
518
elsif ( $gen_severity eq "fip" ) {
519
$stats->{FIPS}++; # Increment the number of FIPs reported.
520
}
521
elsif ( $gen_severity eq "notice" ) {
522
$stats->{NOTICES}++; # Increment the number of notices reported.
523
}
524
else {
525
warning "Unhandled severity: '$severity' {$gen_severity}";
526
}
527
}
528
529
if ( defined $jstruct->{TESTS_EXPECTED} ) {
530
$stats->{TESTS_EXPECTED} = $jstruct->{TESTS_EXPECTED};
531
532
if ( $stats->{TESTS_EXPECTED} < 0 ) {
533
$stats->{TESTS_EXPECTED} = $stats->{TESTS_TOTAL} + (-$stats->{TESTS_EXPECTED});
534
}
535
}
536
537
if ( $stats->{TESTS_TOTAL} == 0 ) {
538
wrong_structure ( { JS => $jstruct }, "No tests in journal",
539
"The test journal contains no test records.", "testsuite_error" );
540
$stats->{TESTSUITE_ERRORS}++;
541
}
542
543
$jstruct->{STATS} = $stats;
544
545
return $jstruct;
546
}
547
#----------------------------------------------------------------------
548
549
sub ParseTetJournal {
550
my ($jstruct) = @_;
551
552
my $file = $jstruct->{FILE} or return error "Journal file undefined";
553
554
open JOURNAL_FH, $file
555
or return error "Can't open file for reading: '$file': $!";
556
557
# Flags indicating that we are inside a some block.
558
my $inside_test = 0;
559
my $inside_test_point = 0;
560
561
my $test_comment = undef;
562
my $test_messages = undef;
563
my $test_points_in_this_case;
564
my $line_number = 0;
565
566
my $context = { JS => $jstruct };
567
568
$context->{TEST_NAME} = undef;
569
570
my %config_vars = (); # For lines with Code 30 -- Configuration Variables.
571
572
# Read the journal line by line.
573
while ( my $line = <JOURNAL_FH> ) {
574
chomp $line;
575
576
$line_number++;
577
578
#$context->{LINE_TEXT} = $line;
579
$context->{LINE_NUM} = $line_number;
580
581
# Each journal line consists of three parts, separated by
582
# a vertical bar:
583
#
584
# 1. A numeric line code, determining the meaning of the line.
585
# 2. Additional data, format depends on line code.
586
# 3. Additional text (message for the user, or some comment).
587
# e.g. '400|0 1 1 20:04:00|IC Start'
588
589
my ($line_code, $line_data, $line_text);
590
if ( $line =~ /^(\d*)\|([^\|]*)\|(.*)$/ ) {
591
$line_code = $1;
592
$line_data = $2;
593
$line_text = $3;
594
}
595
else {
596
# Lines that do not conform to this format are reported
597
# to the user and skipped.
598
wrong_structure ( $context, -NAME, "Wrong syntax",
599
"Unrecognized entry in journal." );
600
next;
601
}
602
603
## Determine the type of the line and process it appropriately.
604
605
if ($line_code == 0) {
606
# Code 0 -- Test Case Controller Start.
607
# 0|version time date|who
608
my ($test_engine_version, $test_start_time, $test_start_date);
609
if ( $line_data =~ /^(\S*)\s+(\S*)\s+(\S*)$/ ) {
610
$test_engine_version = $1;
611
$test_start_time = $2;
612
$test_start_date = $3;
613
}
614
else {
615
wrong_structure ( $context, -NAME, "Wrong syntax",
616
"Unrecognized entry in journal." );
617
next;
618
}
619
620
# Print the test engine version, time and date to the output.
621
my $info_table = {};
622
$info_table->{TITLE} = "Information about the test suit from the journal";
623
push @{$info_table->{ROWS}}, {LEFT => "Test Engine Version", RIGHT => $test_engine_version};
624
push @{$info_table->{ROWS}}, {LEFT => "Test Started At", RIGHT => $test_start_time." ".$test_start_date};
625
push @{$info_table->{ROWS}}, {LEFT => "Test Command Line", RIGHT => $line_text};
626
627
push @{$jstruct->{INFO_TABLES}}, $info_table;
628
}
629
elsif ($line_code == 5) {
630
# Code 5 -- Local System Information.
631
# The line structure is:
632
# 5|sysname nodename release date machine|text
633
my ($system_name, $node_name, $release, $date, $machine);
634
if ( $line =~ /^5\|(\S+)\s+(\S+)\s+(\S+)\s+#(.+)\s+(\S+)\|/ ) {
635
$system_name = $1;
636
$node_name = $2;
637
$release = $3;
638
$date = $4;
639
$machine = $5;
640
}
641
else {
642
wrong_structure ( $context, -NAME, "Wrong syntax",
643
"Unrecognized entry in journal." );
644
next;
645
}
646
647
# Save the local system data.
648
my $info_table = {};
649
$info_table->{TITLE} = "Information about the system under test from the journal";
650
push @{$info_table->{ROWS}}, {LEFT => "System Name", RIGHT => $system_name};
651
push @{$info_table->{ROWS}}, {LEFT => "Node Name", RIGHT => $node_name};
652
push @{$info_table->{ROWS}}, {LEFT => "Release", RIGHT => $release.' #'.$date};
653
push @{$info_table->{ROWS}}, {LEFT => "Machine", RIGHT => $machine};
654
655
push @{$jstruct->{INFO_TABLES}}, $info_table;
656
}
657
elsif ($line_code == 10) {
658
# Code 10 -- Test Case Start.
659
# The line structure is:
660
# 10|activitynum test_name hh:mm:ss|list of invocable components
661
# * Timestamp is omitted in perl test reports. (Bug?)
662
my ($activitynum, $testname_param, $timestamp);
663
if ($line_data =~ /^(\d+)\s+(\S+)\s*(\S*)$/) {
664
$activitynum = $1;
665
$testname_param = $2;
666
$timestamp = $3;
667
}
668
else {
669
wrong_structure ( $context, -NAME, "Wrong syntax",
670
"Unrecognized entry in journal." );
671
next;
672
}
673
674
if ( defined $context->{TEST_NAME} ) {
675
# The previous test case was not properly finished;
676
# issue a warning.
677
wrong_structure ( $context, -NAME, "Previous TC hasn't finished",
678
"Test case ($testname_param) starts before"
679
." the previous one (".$context->{TEST_NAME}.") has finished"
680
);
681
}
682
683
# Set the test name and number.
684
$context->{TEST_NUM} = $activitynum;
685
$context->{TEST_NAME} = $testname_param;
686
687
# Reset the test point number and counter.
688
$context->{TEST_POINT} = 0;
689
$test_points_in_this_case = 0;
690
}
691
elsif ($line_code == 15) {
692
# Code 15 -- Test Case Manager Start.
693
}
694
elsif ($line_code == 20) {
695
# Code 20 -- Local/Remote System Configuration Start.
696
}
697
elsif ($line_code == 30) {
698
# Code 30 -- Configuration Variables.
699
# Format: 30||VARIABLE=value
700
if ($line =~ /^30\|\|([^=]+)=(.*)/) {
701
my $varname = $1;
702
my $value = $2;
703
704
$config_vars{$varname} = $value;
705
}
706
}
707
elsif ($line_code == 40) {
708
# Code 40 -- Configuration End.
709
}
710
elsif ($line_code == 50) {
711
# Code 50 -- Test Case Controller Message.
712
# Format: 50||Message
713
process_test_point_result ( %$context,
714
SEVERITY => "testsuite_error",
715
COMMENT => "Test case controller reports a problem:",
716
MESSAGE => $line_text, );
717
}
718
elsif ($line_code == 70) {
719
# Code 70 -- Scenario Information.
720
721
# LSB-runtime-test only:
722
# for the .os sections need to double expected counts to allow
723
# for the macro versions.
724
if ( $line =~ /^70\|.*total tests in (ANSI|POSIX|LSB|PTHR).os ([0-9]+)/ ) {
725
$jstruct->{TESTS_EXPECTED} += $2 * 2;
726
}
727
elsif ( $line =~ /^70\|.*total tests in ([A-Za-z.0-9_-]+) ([0-9]+)/ ) {
728
$jstruct->{TESTS_EXPECTED} += $2;
729
}
730
elsif ( $line =~ /total\s+tests\s+in/ ) {
731
wrong_structure ( $context, "Wrong syntax",
732
"Unrecognized entry in journal." );
733
}
734
}
735
elsif ($line_code == 80) {
736
# Code 80 -- Test Case End.
737
if ( !defined $context->{TEST_NAME} ) {
738
# Test case end found when no test case was started;
739
# issue a warning.
740
wrong_structure ( $context, "Unexpected TC End",
741
"A Test Case End entry found when no test case seems to be running" );
742
}
743
744
# Warn if the test case seems to be empty.
745
if ( $test_points_in_this_case == 0 ) {
746
wrong_structure ( $context, "No test points",
747
"The test case contains no test points" );
748
}
749
750
# Check the test point returned any result
751
if ( $context->{TEST_POINT} > 0 ) {
752
wrong_structure ( $context, "No result",
753
"The test case returned no result", "unreported" );
754
}
755
756
# Clear the test name, number, messages, and others.
757
$context->{TEST_NAME} = undef;
758
$context->{TEST_NUM} = 0;
759
$test_comment = undef;
760
$test_messages = undef;
761
$test_points_in_this_case = 0;
762
}
763
elsif ($line_code == 90) {
764
# Code 90 -- User Abort.
765
process_test_point_result ( %$context,
766
SEVERITY => "testsuite_error",
767
RESOLUTION => "Interrupted by the user",
768
COMMENT => "Test suite execution was interrupted by the user"
769
);
770
}
771
elsif ($line_code == 100) {
772
# Code 100 -- Captured Output.
773
}
774
elsif ($line_code == 110) {
775
# Code 110 -- Build Start.
776
}
777
elsif ($line_code == 130) {
778
# Code 130 -- Build End.
779
}
780
elsif ($line_code == 200) {
781
# Code 200 -- Test Purpose Start.
782
# The structure of the line is as follows:
783
# 200|activitynum pointnum hh:mm:ss|comment
784
if ($line =~ /^\d*\|(\d*)\s*(\d*)/) {
785
}
786
else {
787
wrong_structure ( $context, "Wrong syntax",
788
"Unrecognized entry in journal." );
789
next;
790
}
791
792
# Check if the previous test point was properly finished.
793
if ( $context->{TEST_POINT} > 0 ) {
794
if ( $context->{TEST_POINT} == $2 ) {
795
# Some test suites have a strange habit of re-starting
796
# the test point.
797
798
# TODO: some switch
799
if ( 0 ) {
800
wrong_structure ( $context, "Restarted in the middle",
801
"The test was restarted in the middle", "testsuite_notice");
802
}
803
}
804
else {
805
# Notify about a disappeared test.
806
wrong_structure ( $context, "Previous test point hasn't finished",
807
"A test point starts before the previous one"
808
." (".$context->{TEST_POINT}.") has finished" );
809
}
810
}
811
812
if ( $line_text ne "" && $line_text ne "TP Start" ) {
813
$test_comment = "Test Purpose Comment: ".$line_text;
814
} else {
815
$test_comment = undef;
816
}
817
818
# Clear the messages.
819
$test_messages = undef;
820
821
# Change the test point number.
822
$context->{TEST_POINT} = $2;
823
824
# Increment the number of test points.
825
$test_points_in_this_case++;
826
}
827
elsif ($line_code == 220) {
828
# Code 220 -- Test Purpose Result.
829
# The structure of the line is as follows:
830
# 220|activitynum pointnum result time|comment
831
my ($activitynum, $pointnum, $result_code, $timestamp);
832
if ($line_data =~ /^(\d+)\s+(\d+)?\s+(\d+)\s+(\S+)$/) {
833
$activitynum = $1;
834
$pointnum = $2;
835
$result_code = $3;
836
$timestamp = $4;
837
}
838
else {
839
wrong_structure ( $context, "Wrong syntax",
840
"Unrecognized entry in journal." );
841
next;
842
}
843
844
# Print a warning if the test purpose seems to never been started.
845
if ( $context->{TEST_POINT} == 0 ) {
846
wrong_structure ( $context, "Unexpected test result entry",
847
"A test result entry found but the test point had not started" );
848
}
849
850
# Print a warning if the test purpose number is different from
851
# what we expected.
852
if ( defined $pointnum && $context->{TEST_POINT} != $pointnum) {
853
wrong_structure ( $context, "Unexpected TP number",
854
"The test purpose number ($2) differs"
855
." from the one (".$context->{TEST_POINT}.") at the beginning of the test." );
856
}
857
858
# Find the meaning of the result code (severity).
859
if ( !defined $result_code_map{$result_code} ) {
860
wrong_structure ( $context, "Unknown result code",
861
"Unrecognized test result code ($result_code)" );
862
next;
863
}
864
865
my $severity = $result_code_map{$result_code};
866
867
# Process the result.
868
process_test_point_result ( %$context,
869
SEVERITY => lc $severity,
870
MESSAGE => $test_messages,
871
COMMENT => $test_comment,
872
);
873
874
# Clear the test point number.
875
$context->{TEST_POINT} = 0;
876
}
877
elsif ($line_code == 310) {
878
# 310 -- Clean Start.
879
}
880
elsif ($line_code == 320) {
881
# 320 -- Clean End.
882
}
883
elsif ($line_code == 400) {
884
# 400 -- Invocable Component Start.
885
}
886
elsif ($line_code == 410) {
887
# 410 -- Invocable Component End.
888
889
# Check the test point returned any result
890
if ( $context->{TEST_POINT} > 0 ) {
891
wrong_structure ( $context, "No result",
892
"The test case returned no result", "unreported" );
893
$context->{TEST_POINT} = 0;
894
}
895
}
896
elsif ($line_code == 510) {
897
# 510 -- Error reported by the underlying test suite.
898
# Format: 510|testnum|Message
899
process_test_point_result ( %$context,
900
SEVERITY => "testsuite_error",
901
COMMENT => "Error reported by the test suite:",
902
MESSAGE => $line_text, );
903
}
904
elsif ($line_code == 520) {
905
# 520 -- Message from the underlying test suite.
906
907
# Coalesce consequent rows of spaces in the message
908
# to a single space. This improves matching with markers.
909
my $message = $line_text;
910
$message =~ s/\s+/ /g;
911
912
# Add the message to the accumulated messages.
913
$test_messages .= $message."\n";
914
}
915
elsif ($line_code == 600) {
916
# 600 -- Parallel Start.
917
}
918
elsif ($line_code == 620) {
919
# 620 -- Parallel End.
920
}
921
elsif ($line_code == 630) {
922
# 630 -- Implied Sequential Start.
923
}
924
elsif ($line_code == 640) {
925
# 640 -- Implied Sequential End.
926
}
927
elsif ($line_code == 700) {
928
# 700 -- Repeat Start.
929
}
930
elsif ($line_code == 720) {
931
# 720 -- Repeat End.
932
}
933
elsif ($line_code == 730) {
934
# 730 -- Timed Loop Start.
935
}
936
elsif ($line_code == 740) {
937
# 740 -- Timed Loop End.
938
}
939
elsif ($line_code == 750) {
940
# 750 -- Random Start.
941
}
942
elsif ($line_code == 760) {
943
# 760 -- Random End.
944
}
945
elsif ($line_code == 800) {
946
# 800 -- Remote Start.
947
}
948
elsif ($line_code == 820) {
949
# 820 -- Remote End.
950
}
951
elsif ($line_code == 830) {
952
# 830 -- Distributed Start.
953
}
954
elsif ($line_code == 840) {
955
# 840 -- Distributed End.
956
}
957
elsif ($line_code == 900) {
958
# 900 -- Test Case Controller End.
959
}
960
else {
961
# Other lines are notified to the user and otherwise ignored.
962
wrong_structure ( $context, "Unrecognized entry",
963
"Unrecognized journal entry" );
964
}
965
}
966
967
# Close the file
968
close JOURNAL_FH;
969
970
# Save the configuration info.
971
if ( %config_vars ) {
972
my $info_table = {};
973
$info_table->{TITLE} = "Configuration information from the journal";
974
975
for my $varname qw(VSX_NAME LSB_VERSION LSB_MODULES TET_VERSION XT_FONTPATH) {
976
if ( defined $config_vars{$varname} ) {
977
push @{$info_table->{ROWS}},
978
{ LEFT => $varname, RIGHT => $config_vars{$varname} };
979
delete $config_vars{$varname};
980
}
981
}
982
983
push @{$jstruct->{INFO_TABLES}}, $info_table;
984
}
985
}
986
#----------------------------------------------------------------------
987
988
sub ParseSimpleJournal {
989
my ($jstruct) = @_;
990
991
my $file = $jstruct->{FILE} or return error "Journal file undefined";
992
993
open JOURNAL_FH, $file
994
or return error "Can't open file for reading: '$file': $!";
995
996
# Flags indicating that we are inside a some block.
997
my $finished = 0;
998
999
my $test_description = undef;
1000
my $test_comment = undef;
1001
my $test_message = undef;
1002
1003
my $line_number = 0;
1004
1005
my $context = { JS => $jstruct };
1006
1007
$context->{TEST_NAME} = undef;
1008
1009
# Read the journal line by line.
1010
while ( my $line = <JOURNAL_FH> ) {
1011
chomp $line;
1012
1013
$line_number++;
1014
1015
$line =~ s/^\s+//; # Trim spaces
1016
$line =~ s/\s+$//;
1017
1018
next if $line eq ""; # Skip empty lines
1019
next if $line =~ /^#/; # Skip comments
1020
1021
$context->{LINE_NUM} = $line_number;
1022
#$context->{LINE_TEXT} = $line;
1023
1024
my ($linetype, $value);
1025
1026
# Format: "LINETYPE: some text"
1027
if ( $line =~ /^([A-Z_\-]+)\s*(:\s*(.*))?$/ ) {
1028
$linetype = $1;
1029
$value = $3;
1030
}
1031
else {
1032
# Lines that do not conform to this format are reported
1033
# to the user and skipped.
1034
wrong_structure( $context, -NAME, "Wrong syntax",
1035
"Unrecognized entry in journal." );
1036
next;
1037
}
1038
1039
if ( $linetype eq 'TEST') {
1040
# Ignore
1041
}
1042
elsif ( $linetype eq 'TESTS_EXPECTED' ) {
1043
$jstruct->{TESTS_EXPECTED} = $value;
1044
}
1045
elsif ( $linetype eq 'TESTCASE' ) {
1046
if ( defined $context->{TEST_NAME} ) {
1047
# Previous test case wasn't closed
1048
wrong_structure_line( $context, "Unclosed test case",
1049
"New testcase '$value' was started"
1050
." before the previous one has closed: '".$context->{TEST_NAME}."'." );
1051
}
1052
1053
$context->{TEST_NAME} = $value;
1054
$test_description = undef;
1055
$test_comment = undef;
1056
$test_message = undef;
1057
}
1058
elsif ( $linetype =~ /^(DESCR|COMMENT|MESSAGE)$/ ) {
1059
if ( !defined $context->{TEST_NAME} ) {
1060
wrong_structure ( $context, "Unexpected line",
1061
"$linetype beyond a test block." );
1062
next;
1063
}
1064
1065
if ( $linetype eq 'DESCR' ) {
1066
$test_description .= $value."<br />\n";
1067
}
1068
elsif ( $linetype eq 'COMMENT' ) {
1069
$test_comment .= $value."<br />\n";
1070
}
1071
elsif ( $linetype eq 'MESSAGE' ) {
1072
$test_message .= $value."\n";
1073
}
1074
else {
1075
wrong_structure ( $context, "Missed line type",
1076
"Missed line type: '$linetype'." );
1077
}
1078
}
1079
elsif ( $linetype eq 'RESULT' ) {
1080
# Process the result.
1081
process_test_point_result ( %$context,
1082
SEVERITY => lc $value,
1083
DESCRIPTION => $test_description,
1084
COMMENT => $test_comment,
1085
MESSAGE => $test_message,
1086
);
1087
1088
$context->{TEST_NAME} = undef;
1089
$test_description = undef;
1090
$test_comment = undef;
1091
$test_message = undef;
1092
}
1093
elsif ( $linetype eq 'FINISHED' ) {
1094
# This record indicates the journal was closed correctly
1095
$finished = 1;
1096
}
1097
else {
1098
wrong_structure( $context, "Wrong syntax",
1099
"Unhandled line type: '$linetype'." );
1100
}
1101
}
1102
1103
if ( defined $context->{TEST_NAME} ) {
1104
# Unclosed test case
1105
wrong_structure ( $context, "Unclosed test case",
1106
"Unclosed test case: '".$context->{TEST_NAME}."'." );
1107
}
1108
1109
if ( !$finished ) {
1110
# Unclosed test case
1111
wrong_structure ( $context, -NAME, "Incomplete journal",
1112
"The journal wasn't closed correctly." );
1113
}
1114
}
1115
#----------------------------------------------------------------------
1116
1117
# The Tcl-style journal parser function.
1118
sub ParseTclJournal {
1119
my ($jstruct) = @_;
1120
1121
my $file = $jstruct->{FILE} or return error "Journal file undefined";
1122
1123
open JOURNAL_FH, $file
1124
or return error "Can't open file for reading: '$file': $!";
1125
1126
# Flags indicating that we are inside a some block.
1127
my $finished = 0;
1128
1129
my $test_messages = undef;
1130
1131
my $line_number = 0;
1132
1133
my $context = { JS => $jstruct };
1134
1135
$context->{TEST_NAME} = undef;
1136
1137
# Read the journal line by line.
1138
while ( my $line = <JOURNAL_FH> ) {
1139
chomp $line;
1140
1141
$line_number++;
1142
1143
# Do not trim spaces at the beginning!
1144
$line =~ s/\s+$//; # Trim spaces at the end of the line.
1145
1146
# Don't skip empty lines
1147
1148
$context->{LINE_NUM} = $line_number;
1149
#$context->{LINE_TEXT} = $line;
1150
1151
# A test record message ends with a line with a rough format
1152
# '==== testname result'
1153
if ( $line =~ /^=+\s*([a-zA-Z0-9_\-\.]+)\s*FAILED/ ) {
1154
1155
if ( !defined $context->{TEST_NAME} ) {
1156
# Oops, we have missed something...
1157
wrong_structure ( $context, "Failure",
1158
"End of a test record found but no start was seen." );
1159
}
1160
1161
# Process the result.
1162
process_test_point_result ( %$context,
1163
SEVERITY => "failed",
1164
MESSAGE => $test_messages,
1165
);
1166
1167
# Clear the previous test messages.
1168
$test_messages = undef;
1169
1170
# Finish the test record.
1171
$context->{TEST_NAME} = undef;
1172
}
1173
# A failure report starts with a line with a rough format
1174
# '==== testname errormessage result'.
1175
elsif ($line =~ /^=+\s*([a-zA-Z0-9_\-\.]+)\s*(.+)\s*FAILED/) {
1176
1177
# Load the test name.
1178
$context->{TEST_NAME} = $1;
1179
1180
# Add the error message to the test messages.
1181
$test_messages .= $2."\n";
1182
}
1183
# A line that contains only the name of the test (which ends
1184
# with '.test', marks a passed test.
1185
# There could be some garbage at the beginning of the line (from a previous test).
1186
elsif ($line =~ /^(.*\s+)?([a-zA-Z0-9_\-]+)\.test$/) {
1187
$context->{TEST_NAME} = $2;
1188
$test_messages = undef;
1189
1190
# Process the result.
1191
process_test_point_result ( %$context,
1192
SEVERITY => "passed",
1193
);
1194
$context->{TEST_NAME} = undef;
1195
}
1196
# Anything else?
1197
else {
1198
if ( defined $context->{TEST_NAME} ) {
1199
# We are inside a test point result record, so it will be
1200
# a test message.
1201
$test_messages .= $line."\n";
1202
}
1203
else {
1204
# Anything else is better ignored (there is too much noise
1205
# for considering unrecognized lines to be errors).
1206
}
1207
}
1208
}
1209
}
1210
1211
#----------------------------------------------------------------------
1212
1213
# The Python-style journal parser function.
1214
sub ParsePythonJournal {
1215
my ($jstruct) = @_;
1216
1217
my $file = $jstruct->{FILE} or return error "Journal file undefined";
1218
1219
open JOURNAL_FH, $file
1220
or return error "Can't open file for reading: '$file': $!";
1221
1222
my $severity = undef;
1223
my $test_messages = undef;
1224
my $line_number = 0;
1225
my $finished = 0;
1226
1227
my $context = { JS => $jstruct };
1228
1229
local *check_prev_tc = sub {
1230
my ($new_test_name) = @_;
1231
1232
if ( defined $context->{TEST_NAME} && $context->{TEST_NAME} ne $new_test_name ) {
1233
# Save the previous test case
1234
process_test_point_result ( %$context,
1235
SEVERITY => $severity,
1236
MESSAGE => $test_messages
1237
);
1238
}
1239
};
1240
1241
# Read the journal line by line.
1242
while (my $line = <JOURNAL_FH>) {
1243
chomp $line;
1244
1245
$line_number++;
1246
1247
# Do not trim spaces at the beginning!
1248
$line =~ s/\s+$//; # Trim spaces at the end of the line.
1249
1250
# Don't skip empty lines
1251
1252
#$context->{LINE_TEXT} = $line;
1253
$context->{LINE_NUM} = $line_number;
1254
1255
if ( $line =~ /^(test_[a-zA-Z0-9_]+)$/ ) {
1256
# Looks like a test name
1257
check_prev_tc($1);
1258
1259
$context->{TEST_NAME} = $1;
1260
$severity = "passed";
1261
$test_messages = undef;
1262
}
1263
# A line in form 'testname skipped -- ...' marks a test
1264
# that was skipped, and the end of the line contains
1265
# the description why.
1266
elsif ( $line =~ /^(test_[a-zA-Z0-9_]+)\s*skipped\s*--\s*(.*)$/ ) {
1267
check_prev_tc($1);
1268
1269
$context->{TEST_NAME} = $1;
1270
$severity = "unsupported";
1271
$test_messages = $2;
1272
}
1273
# A line in form 'test testname failed -- ...' marks a failed test.
1274
elsif ( $line =~ /^test\s*([a-zA-Z0-9_]+)\s*(failed|crashed)\s*--\s*(.*)$/ ) {
1275
check_prev_tc($1);
1276
1277
$context->{TEST_NAME} = $1;
1278
$severity = lc $2;
1279
$severity = "failed" if $severity eq "crashed";
1280
$test_messages = $3;
1281
}
1282
else {
1283
if ( $line =~ /^(\d+) tests OK/ ) {
1284
# End of the journal
1285
check_prev_tc("");
1286
1287
$context->{TEST_NAME} = undef;
1288
$finished = 1;
1289
next;
1290
}
1291
1292
if ( defined $context->{TEST_NAME} ) {
1293
# Just append this line to the test record messages
1294
# and continue by the next line.
1295
$test_messages .= $line."\n";
1296
} else {
1297
check_prev_tc("");
1298
1299
# This should be lines with some statistics at the end of the journal.
1300
if ( $line =~ /^(\d+)\s+skips\s+unexpected/ ) {
1301
$jstruct->{TESTS_EXPECTED} = -$1; # Negative value means SKIPS_UNEXPECTED
1302
# TESTS_EXPECTED = TESTS_TOTAL + SKIPS_UNEXPECTED;
1303
}
1304
else {
1305
# Other lines are ignored.
1306
}
1307
}
1308
}
1309
}
1310
1311
if ( !$finished ) {
1312
wrong_structure ($context, -NAME, "Journal wasn't finished");
1313
}
1314
}
1315
#----------------------------------------------------------------------
1316
1317
sub wrong_structure {
1318
my $context = shift;
1319
my %data = %$context;
1320
if ( defined $_[0] && ref($_[0]) eq '' && $_[0] eq '-NAME' ) {
1321
delete $data{TEST_NAME};
1322
delete $data{TEST_POINT};
1323
shift;
1324
}
1325
my $resolution = shift || "Wrong structure";
1326
my $comment = shift || $resolution;
1327
my $severity = shift || "testsuite_warning";
1328
1329
process_test_point_result ( %data,
1330
SEVERITY => lc $severity,
1331
RESOLUTION => $resolution,
1332
COMMENT => $comment,
1333
);
1334
}
1335
#----------------------------------------------------------------------
1336
1337
sub process_test_point_result {
1338
my ( %data ) = @_;
1339
1340
( defined $data{SEVERITY} ) or return error "undefined severity";
1341
1342
my $gen_severity = ( $severity_map{$data{SEVERITY}} or $data{SEVERITY} );
1343
my $severity_ok = ( $gen_severity eq "passed" || $gen_severity eq "untested" );
1344
1345
my $problem_record = undef;
1346
1347
unless ( $severity_ok ) {
1348
# Search for the problem record in the database.
1349
$problem_record = find_problem_record( %data );
1350
if ( !is_ok($problem_record) ) {
1351
warning $Error::Last;
1352
$problem_record = undef;
1353
}
1354
}
1355
1356
if ( $problem_record ) {
1357
1358
$data{PROBLEM_INFO} = $problem_record;
1359
1360
if ( $problem_record->{'quell'} ) {
1361
if ( defined $severity_map{ $problem_record->{'quell'} } ) {
1362
# If 'quell' contains severity name, that severity will be forced.
1363
$data{SEVERITY} = lc $problem_record->{'quell'};
1364
} else {
1365
# Add the "(quelled)" keyword to the severity if the problem is quelled.
1366
# This means it can be safely ignored.
1367
if ( $problem_record->{'lsb_report_id'} ) {
1368
$data{SEVERITY} .= " (waived)";
1369
} else {
1370
$data{SEVERITY} .= " (quelled)";
1371
}
1372
}
1373
}
1374
1375
$data{RESOLUTION} = $problem_record->{"resolution"} if $problem_record->{"resolution"};
1376
1377
if ( $data{RESOLUTION} =~ /^\s*$/ ) {
1378
# If resolution is empty, put "..." in its place to indicate,
1379
# that some information about the problem is available.
1380
$data{RESOLUTION} = "...";
1381
}
1382
}
1383
1384
my $testcase = $data{TEST_NAME};
1385
$testcase = "***" if !defined $testcase; # testsuite error
1386
1387
$testcase .= " ".$data{TEST_POINT} if defined $data{TEST_POINT} && $data{TEST_POINT} ne "";
1388
1389
if ( $severity_ok ) {
1390
# For severity_ok save the testcase only (scalar)
1391
if ( $data{SEVERITY} eq "passed" ) {
1392
push @{$data{JS}->{ARR}}, ":".$testcase;
1393
} else {
1394
push @{$data{JS}->{ARR}}, $data{SEVERITY}.":".$testcase;
1395
}
1396
} else {
1397
# For problems save the entire record (hashref)
1398
my $record = { %data };
1399
delete $record->{JS};
1400
1401
push @{$data{JS}->{ARR}}, $record;
1402
}
1403
}
1404
#----------------------------------------------------------------------
1405
1406
sub print_info_table {
1407
my ($info_table) = @_;
1408
1409
my $res = "";
1410
1411
# Print the local system data.
1412
$res .= '<table class="info">'."\n";
1413
if ( $info_table->{TITLE} ) { # Table title
1414
$res .= '<tr><th colspan="2" class="title">'.$info_table->{TITLE}.'</th></tr>'."\n";
1415
}
1416
foreach my $row ( @{$info_table->{ROWS}} ) {
1417
my $first_column = $row->{LEFT};
1418
my $second_column = $row->{RIGHT};
1419
my $background_color = $row->{BG_COLOR};
1420
my $foreground_color = $row->{FG_COLOR};
1421
$res .= info_line( $first_column, $second_column, $background_color, $foreground_color );
1422
}
1423
$res .= '</table>';
1424
1425
return $res;
1426
}
1427
#----------------------------------------------------------------------
1428
1429
# Prints a single line of a two-column table.
1430
#
1431
# Arguments:
1432
# $1 - The first column.
1433
# $2 - The second column.
1434
# $3 (optional) - The foreground color of the second column.
1435
# $4 (optional) - The background color of the second column.
1436
sub info_line {
1437
my ($first_column, $second_column, $background_color, $foreground_color ) = @_;
1438
1439
if ( !defined $second_column ) {
1440
$second_column = '<i style="color:'.$neutral_gray.'">(undef)</i>';
1441
}
1442
1443
# Compile the style of the first column
1444
my $style1 = "white-space:nowrap;";
1445
1446
$style1 = ' style="'.$style1.'"';
1447
1448
# Compile the style of the second column
1449
my $style2 = "";
1450
1451
$style2 .= "text-align:right;";
1452
1453
if ( $foreground_color ) {
1454
$style2 .= "color:$foreground_color;";
1455
}
1456
if ($background_color) {
1457
$style2 .= "background-color:$background_color;";
1458
}
1459
1460
$style2 = ' style="'.$style2.'"';
1461
1462
# Print the line with appropriate decorations.
1463
my $res = "<tr><th".$style1.">".$first_column."</th>\n"
1464
."<td".$style2.">".$second_column."</td>\n"
1465
."</tr>\n";
1466
1467
return $res;
1468
}
1469
#----------------------------------------------------------------------
1470
1471
sub JournalReport {
1472
my ($jstruct) = @_;
1473
1474
my $no_problems = 1;
1475
1476
my $pt = "";
1477
1478
$pt .= problem_table_header();
1479
1480
foreach my $obj ( @{$jstruct->{ARR}} ) {
1481
next if ref($obj) eq "";
1482
1483
if ( ref($obj) ne "HASH" ) {
1484
warning "Wrong jstruct element: '$obj'";
1485
next;
1486
}
1487
1488
$no_problems = 0 if $no_problems;
1489
1490
$pt .= problem_table_line( $obj, $jstruct );
1491
}
1492
1493
$pt .= "</table>\n";
1494
1495
my $res = "";
1496
1497
if ( defined $jstruct->{INFO_TABLES} ) {
1498
$res .= print_info_table($_) foreach ( @{$jstruct->{INFO_TABLES}} );
1499
}
1500
1501
if ( $no_problems ) {
1502
$res .= '<h4>Problem summary:</h4>';
1503
$res .= '<p style="font-weight:bold;color:'.$dark_green.'">'
1504
.'No problems were detected.</p>';
1505
return $res;
1506
}
1507
else {
1508
$res .= $pt;
1509
}
1510
1511
return $res;
1512
}
1513
#----------------------------------------------------------------------
1514
1515
# Prints a header of the problem table.
1516
sub problem_table_header {
1517
my $res = <<HERETEXT;
1518
<h4>Problem Summary</h4>
1519
1520
<p>Click on lines in the table to see the details about each problem.</p>
1521
1522
<table width="100%" class="problem_table">
1523
<thead><tr style="background-color:$gray">
1524
<th>Test Name</th><th>Severity</th><th>Resolution</th>
1525
</tr></thead>
1526
1527
HERETEXT
1528
}
1529
1530
#---------------------------------------------------------------------
1531
1532
sub problem_table_line {
1533
my ( $data, $jstruct ) = @_;
1534
1535
my $severity = $data->{SEVERITY};
1536
my $gen_severity = ( $severity_map{$severity} or $severity );
1537
1538
my $color = "red";
1539
if ( $severity =~ /(quelled|waived)/i ) {
1540
# Anything what is quelled is harmless, so use neutral gray
1541
# for all quelled problems.
1542
$color = "gray";
1543
}
1544
elsif ( $gen_severity eq "failed" || $gen_severity eq "testsuite_error" ) {
1545
$color = "red"; # Use fluorescent red for various failures.
1546
}
1547
elsif ( $gen_severity eq "warning" ) {
1548
$color = "yellow"; # Use fluorescent yellow for warnings.
1549
}
1550
elsif ( $gen_severity eq "fip" ) {
1551
$color = "green"; # Use fluorescent green for FIPs.
1552
1553
$severity .= '<span class="view_srv"> '
1554
.'<a href="tests_help.pl#FIP" title="Help">' # HELP icon
1555
.'<img src="images/question.png" width="16" height="17" alt="[?]" />'
1556
.'</a></span>';
1557
}
1558
elsif ( $gen_severity eq "notice" || $gen_severity eq "untested" ) {
1559
# Actually, untested test cases shouldn't displayed
1560
$color = "gray"; # Use neutral gray for harmless messages.
1561
}
1562
else {
1563
warning "Unrecognized severity: '$severity'";
1564
$severity = "Unrecognized severity: '$severity'";
1565
}
1566
1567
my $res = "";
1568
1569
# Give the box a unique ID.
1570
my $message_box_id = "m".(++$box_id);
1571
1572
# Start the line
1573
# (with attached script that opens the detail block on clicking).
1574
$res .= '<tr class="ptl_'.$color.'" title="Click here!"'
1575
.' onclick="flip(\''.$message_box_id.'\');">';
1576
1577
# Print the test name and test point (if available).
1578
$res .= "<td>";
1579
if ( defined $data->{TEST_NAME} ) {
1580
$res .= html( $data->{TEST_NAME} );
1581
} else {
1582
$res .= "<i>(none)</i>";
1583
}
1584
1585
if ( defined $data->{TEST_POINT} ) {
1586
$res .= ' <span style="color:'.$dark_blue.';">'
1587
.html($data->{TEST_POINT}).'</span>';
1588
}
1589
$res .= "</td>\n";
1590
1591
# Print severity
1592
$severity = ($data->{SEVERITY} or "");
1593
$severity =~ s/ +/ /g; # Make spaces nonbreakable
1594
$res .= '<td class="fw1">'.$severity."</td>\n";
1595
1596
# Print resolution
1597
$res .= '<td class="fw2">'.($data->{RESOLUTION} or "")."</td>\n";
1598
1599
# Finish the line.
1600
$res .= "</tr>\n";
1601
1602
# Print the detail block, which is initially hidden and unrolls when
1603
# the table row is clicked (via the javascript).
1604
$res .= '<tr>'."\n";
1605
$res .= '<td colspan="3" class="pdu">';
1606
$res .= '<div class="ptd_'.$color.'" id="'.$message_box_id.'"'
1607
.' style="display:none">';
1608
1609
if ( defined $data->{DESCRIPTION} ) { # Test description
1610
$res .= '<h4>Test description:</h4>'."\n";
1611
#$res .= '<pre>'.html(pre_wrap($data->{DESCRIPTION}, 100)).'</pre>'."\n";
1612
$res .= '<p>'.$data->{DESCRIPTION}.'</p>'."\n";
1613
$res .= '<hr />';
1614
}
1615
1616
if ( defined $data->{MESSAGE} ) {
1617
$res .= '<pre>'.html(pre_wrap($data->{MESSAGE}, 100)).'</pre>'."\n";
1618
$res .= '<hr />';
1619
}
1620
1621
if ( defined $data->{COMMENT} && $data->{COMMENT} ne "" ) {
1622
$res .= '<p>'.$data->{COMMENT}.'</p>'."\n";
1623
}
1624
1625
{
1626
$res .= '<h4>Open the journal:</h4>'."\n";
1627
$res .= '<p>';
1628
1629
my $href = $jstruct->{FILE};
1630
$href .= '&line='.$data->{LINE_NUM}.'#line'.$data->{LINE_NUM} if defined $data->{LINE_NUM};
1631
1632
my $text = $jstruct->{FILE};
1633
$text .= ':'.$data->{LINE_NUM} if defined $data->{LINE_NUM};
1634
1635
$res .= local_href($href, $text);
1636
1637
$res .= '</p>'."\n";
1638
$res .= '<hr />';
1639
}
1640
1641
# Problem info from problem DB
1642
my $pr_info = $data->{PROBLEM_INFO};
1643
if ( $pr_info ) {
1644
$res .= '<h4>Problem info:</h4>'."\n";
1645
1646
if ( $pr_info->{'comment'} ) {
1647
$res .= '<p>'.html($pr_info->{'comment'}).'</p>'."\n";
1648
}
1649
if ( $pr_info->{'lsb_report_id'} ) {
1650
my $pr_id = $pr_info->{'lsb_report_id'};
1651
my $link = "https://www.linuxfoundation.org/lsbprs/pr/".$pr_id;
1652
$res .= '<p>Reported to the LSB Committee as'
1653
.' <a href="'.$link.'" target="_blank">PR '.$pr_id.'</a>.</p>'."\n";
1654
}
1655
1656
$res .= '<hr />';
1657
}
1658
1659
# "Report bug in test" button.
1660
if ( $color eq "red" # If a bug
1661
&& (!$pr_info || !$pr_info->{'lsb_report_id'} ) # And not yet reported
1662
)
1663
{
1664
local *quot = sub {
1665
my ($s) = @_;
1666
$s =~ s/&/&/g;
1667
$s =~ s/'/\\'/g;
1668
return $s;
1669
};
1670
1671
my $test_suite = quot($jstruct->{TESTSUITE} or "undef");
1672
1673
my $test_case = ( $data->{TEST_NAME} or "..." );
1674
if ( defined $data->{TEST_POINT} && $data->{TEST_POINT} ne "" ) {
1675
$test_case .= ' '.$data->{TEST_POINT};
1676
}
1677
$test_case = quot($test_case);
1678
1679
$severity = quot($data->{SEVERITY} or "");
1680
my $file = quot($jstruct->{FILE} or "");
1681
1682
$res .= <<HERETEXT;
1683
<div align="right">
1684
<input type="button" value="Report Bug in the Test"
1685
onclick="javascript:bug_report('$test_suite', '$test_case', '$severity', '$file');"
1686
title="Press this button if you believe the problem is in the test, not in your system." />
1687
</div>
1688
HERETEXT
1689
#
1690
}
1691
1692
# Finish the table line
1693
$res .= "</div>";
1694
$res .= "</td></tr>\n";
1695
1696
return $res;
1697
}
1698
#----------------------------------------------------------------------
1699
1700
sub Compile {
1701
# Read the runconfig file
1702
my $runconfig = read_config( $result_dir."/runconfig" );
1703
is_ok($runconfig) or return error "Failed to read runconfig", $Error::Last;
1704
1705
my $tests = $runconfig->{SECTIONS};
1706
1707
# Information in the 'runconfig' file is for non-executed tests
1708
# For executed tests information is obtained from <test>.info files.
1709
1710
# Read tests' .info files
1711
my @info_files = glob($result_dir."/results/*.info");
1712
foreach my $info_file ( @info_files ) {
1713
my $test_info = read_config( $info_file );
1714
my $test_name = $test_info->{NAME} or next;
1715
$tests->{$test_name} = $test_info;
1716
}
1717
1718
for my $test_name ( keys %$tests ) {
1719
my $test_info = $tests->{$test_name};
1720
1721
if ( !$test_info->{VERDICT} ) { $test_info->{VERDICT} = "incomplete"; }
1722
1723
$test_info->{REPORT} = "";
1724
1725
# Title:
1726
$test_info->{REPORT} .= '<h2>';
1727
1728
$test_info->{REPORT} .= '<a name="'.$test_info->{NAME}.'"></a>'
1729
.'<font color="#336699">'.html($test_info->{DISPLAYNAME}).'</font>'
1730
.' ' ;
1731
1732
if ( defined $test_info->{VERSION} ) {
1733
$test_info->{REPORT} .= '<font size="-1" color="'.$neutral_gray.'">'
1734
.'v. '.html($test_info->{VERSION}).'</font>';
1735
}
1736
1737
if ( $test_info->{TRIAL_USE} && $cert_mode ) {
1738
$test_info->{REPORT} .= ' <span style="color:'.$fluorescent_green.'">'
1739
.'TRIAL USE</span>';
1740
}
1741
1742
$test_info->{REPORT} .= '</h2>'."\n";
1743
1744
# Read .report.part1 file
1745
my $report_filename = $result_dir."/results/".$test_info->{NAME}.".report.part1";
1746
my $report_part = read_file( $report_filename );
1747
if ( is_ok($report_part) ) {
1748
$test_info->{REPORT} .= $report_part;
1749
}
1750
1751
# Test info table
1752
if ( !$test_info->{STARTED} ) {
1753
if ( $test_info->{MANUAL} ) {
1754
$test_info->{REPORT} .= "<p>The test hasn't been prepared.</p>\n";
1755
} else {
1756
$test_info->{REPORT} .= "<p>The test hasn't been executed.</p>\n";
1757
}
1758
} else {
1759
$test_info->{REPORT} .= print_testinfo_table( $test_info );
1760
}
1761
1762
# Add .report.part2 file
1763
$report_filename = $result_dir."/results/".$test_info->{NAME}.".report.part2";
1764
$report_part = read_file( $report_filename );
1765
if ( is_ok($report_part) ) {
1766
$test_info->{REPORT} .= $report_part;
1767
}
1768
1769
$test_info->{REPORT} .= "\n<hr />\n\n";
1770
}
1771
1772
my @auto_tests = grep {!$_->{MANUAL} && !($cert_mode && $_->{TRIAL_USE})} values %$tests;
1773
my $verdict = "";
1774
if ( @auto_tests ) {
1775
$verdict = overall_verdict( map {$_->{VERDICT}} @auto_tests );
1776
}
1777
my @man_tests = grep {$_->{MANUAL} && !($cert_mode && $_->{TRIAL_USE})} values %$tests;
1778
my $verdict_man = "";
1779
if ( @man_tests ) {
1780
$verdict_man = overall_verdict( map {$_->{VERDICT}} @man_tests );
1781
}
1782
1783
my $res = "";
1784
1785
$res .= Head( $runconfig );
1786
1787
my @sort_order = ();
1788
$res .= Tree_toc( $tests, \@sort_order );
1789
1790
$res .= "\n<hr />\n\n";
1791
1792
my @tests = sort { in_array($a, @sort_order) <=> in_array($b, @sort_order) } keys %$tests;
1793
1794
foreach my $test_name ( @tests ) {
1795
if ( !defined $tests->{$test_name}->{REPORT} ) {
1796
warning "No report for '$test_name'";
1797
next;
1798
}
1799
$res .= $tests->{$test_name}{REPORT};
1800
}
1801
1802
$res .= Footer();
1803
1804
# Write the report to file
1805
my $report_file = $result_dir."/report.htm";
1806
is_ok write_string_as_file( $report_file, $res)
1807
or complain "Failed to write the report to '$report_file'", $Error::Last;
1808
1809
return $verdict, $verdict_man;
1810
} # End of Compile()
1811
#-----------------------------------------------------------------------
1812
1813
sub print_testinfo_table {
1814
my ($test_info) = @_;
1815
1816
my $res = "";
1817
1818
# Start/stop time
1819
my $start_time = $test_info->{START_TIME};
1820
my $finish_time = $test_info->{FINISH_TIME};
1821
1822
$res .= '<table class="info">'."\n";
1823
1824
if ( $start_time ) {
1825
$res .= info_line('Started At', format_time($start_time) );
1826
if ( $finish_time ) {
1827
$res .= info_line('Execution Time', format_duration($finish_time - $start_time) );
1828
}
1829
} else {
1830
if ( !$test_info->{MANUAL} ) {
1831
$res .= info_line('Started At', "NOT STARTED", $fluorescent_red );
1832
}
1833
}
1834
1835
$res .= info_line( 'Verdict:',
1836
verdict_text( $test_info->{VERDICT} ),
1837
verdict_color( $test_info->{VERDICT} )
1838
);
1839
1840
$res .= '</table>'."\n";
1841
1842
return $res;
1843
}
1844
1845
sub verdict {
1846
my ($stats) = @_;
1847
1848
# Deduce the verdict
1849
my $verdict = undef;
1850
if ( $stats->{FAILURES} || $stats->{TESTSUITE_ERRORS} ) {
1851
$verdict = "failed";
1852
}
1853
elsif ( $stats->{WARNINGS} ) {
1854
$verdict = "warning";
1855
}
1856
elsif ( defined $stats->{TESTS_EXPECTED} && defined $stats->{TESTS_TOTAL}
1857
&& $stats->{TESTS_EXPECTED} != $stats->{TESTS_TOTAL} )
1858
{
1859
$verdict = "warning";
1860
}
1861
else {
1862
$verdict = "passed";
1863
}
1864
return $verdict;
1865
}
1866
#-----------------------------------------------------------------------
1867
1868
my %verdict_sort = ( 'undefined' => 0, 'incomplete' => 1, 'run_problems' => 2, 'failed' => 3,
1869
'warning' => 4, 'passed' => 5 , '' => 6 );
1870
1871
sub overall_verdict {
1872
my $res = "";
1873
1874
foreach my $verdict ( @_ ) {
1875
$verdict = "" if !defined $verdict;
1876
if ( $verdict_sort{$verdict} < $verdict_sort{$res} ) {
1877
$res = $verdict;
1878
}
1879
}
1880
1881
if ( $res eq 'undefined' ) { warning "Undefined verdict"; }
1882
1883
return $res;
1884
}
1885
#----------------------------------------------------------------------
1886
1887
sub Head {
1888
my ($runconfig) = @_;
1889
1890
my $res = "";
1891
1892
# TODO: read from file ../webui/public_html/css/report.css
1893
1894
$res .= <<HEREDOC;
1895
<html>
1896
<head>
1897
<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
1898
<title>Test Results</title>
1899
1900
<style type="text/css">
1901
1902
html, body {
1903
font-family: sans-serif;
1904
font-size: x-small;
1905
}
1906
1907
h1 { border-bottom: 1px solid #aaa; }
1908
h2 { border-bottom: 1px dashed #aaa; }
1909
1910
a {
1911
text-decoration: none;
1912
color: #336699;
1913
background: none;
1914
}
1915
a:hover {
1916
text-decoration: underline;
1917
color: #336699;
1918
}
1919
1920
.toclink {
1921
font-weight: bold;
1922
}
1923
1924
.errmsg {
1925
background: #f9ffaa;
1926
border: dashed 1px red;
1927
color: red;
1928
margin-bottom: 15px;
1929
padding: 3pt;
1930
padding-left: 15pt;
1931
font-size: 120%;
1932
}
1933
1934
table.info {
1935
margin: 1em 1em 6pt 0;
1936
background: #f9f9f9;
1937
border: 1px #aaaaaa solid;
1938
border-collapse: collapse;
1939
}
1940
table.info th, table.info td {
1941
border: 1px #aaaaaa solid;
1942
padding: 0.2em;
1943
padding-left: 0.4em;
1944
padding-right: 0.4em;
1945
}
1946
1947
table.toc {
1948
border-collapse: collapse;
1949
background: #E6E6E6;
1950
}
1951
table.toc th, table.toc td {
1952
border: 1px #FFFFFF solid;
1953
padding: 0.2em;
1954
padding-left: 0.4em;
1955
padding-right: 0.4em;
1956
}
1957
1958
table.info th, table.toc th {
1959
background: #f2f2f2;
1960
text-align: left;
1961
}
1962
table.info th.title {
1963
background: #E5E5E5;
1964
}
1965
1966
table.problem_table {
1967
width: 100%;
1968
border-collapse: collapse;
1969
}
1970
table.problem_table thead th {
1971
background-color: $gray;
1972
}
1973
1974
table.problem_table tr td {
1975
border: 1px solid white;
1976
}
1977
1978
td.pd, td.pdu { /* Problem details */
1979
margin: 0;
1980
padding: 0;
1981
border: 0;
1982
}
1983
td.pdu {
1984
width:100%;
1985
}
1986
1987
.fw1 { width:12%; text-align: center; }
1988
.fw2 { width:25% }
1989
1990
.ptl_gray { background: #E6E6E6;}
1991
.ptl_gray:hover { background: #D6D6F0;}
1992
1993
.ptl_green { background: #CDFFCD;}
1994
.ptl_green:hover { background: #A0FFA0;}
1995
1996
.ptl_yellow { background: #FFFFCD;}
1997
.ptl_yellow:hover { background: #FFFF90;}
1998
1999
.ptl_red { background: #FFCDCD;}
2000
.ptl_red:hover { background: #FFA0A0;}
2001
2002
.ptl_gray, .ptl_green, .ptl_yellow, .ptl_red { cursor: pointer }
2003
2004
.ptd_gray, .ptd_green, .ptd_yellow, .ptd_red {
2005
padding: 1pt 16pt 5pt 16pt;
2006
margin: 3pt 5pt 10pt 5pt;
2007
}
2008
.ptd_gray { border-left: 5pt solid #D6D6F0 }
2009
.ptd_green { border-left: 5pt solid #A0FFA0 }
2010
.ptd_yellow { border-left: 5pt solid #FFFF90 }
2011
.ptd_red { border-left: 5pt solid #FFA0A0 }
2012
2013
.view_srv { display: none; }
2014
2015
.legal-text { width: 100%; font-size: xx-small; text-align:center; color: gray; }
2016
2017
</style>
2018
</head>
2019
HEREDOC
2020
2021
my $rep_platform = "All";
2022
if ( $runconfig->{'HOST_architecture'} ) {
2023
$rep_platform = $runconfig->{'HOST_architecture'};
2024
if ( $rep_platform eq 'x86' ) { $rep_platform = 'IA32'; }
2025
if ( $rep_platform eq 'x86-64' ) { $rep_platform = 'AMD64'; }
2026
if ( !in_array($rep_platform, "IA32", "AMD64", "IA64", "PPC32", "PPC64", "S390", "S390X") ) {
2027
$rep_platform = "All";
2028
}
2029
}
2030
my $op_sys = "All";
2031
if ( $runconfig->{'HOST_OS'} ) {
2032
for my $s ( "Asianux", "BOSS", "Booyo", "Debian", "Fedora", "Linpus", "Mandriva",
2033
"OpenSuse", "Red Flag", "Red Hat", "Sun Wah", "SuSE", "ThizLinux", "Turbolinux",
2034
"Ubuntu", "United Linux", "Xandros" )
2035
{
2036
my $re = $s;
2037
$re =~ s/\s+/.?/;
2038
if ( $runconfig->{'HOST_OS'} =~ /$re/ ) {
2039
$op_sys = $s;
2040
last;
2041
}
2042
}
2043
}
2044
2045
$res .= <<HEREDOC;
2046
<body>
2047
<!-- Bugreport form. Used when one clicks "Report bug" button. -->
2048
<form name="bugreport" style="display:none" method="get" action="http://bugs.linuxbase.org/enter_bug.cgi" target="_blank">
2049
<input type="hidden" name="product" value="Distribution Tests" />
2050
<input type="hidden" name="format" value="problemreport" />
2051
<input type="hidden" name="rep_platform" value="$rep_platform" />
2052
<input type="hidden" name="op_sys" value="$op_sys" />
2053
<input type="hidden" name="short_desc" value="" />
2054
<input type="hidden" name="comment" value="" />
2055
</form>
2056
2057
<script language="javascript" type="text/javascript">
2058
// <![CDATA[
2059
function flip (message_box_id) {
2060
msgbox = document.getElementById(message_box_id);
2061
if (msgbox.style.display != 'none') {
2062
msgbox.style.display = 'none';
2063
}
2064
else {
2065
msgbox.style.display = '';
2066
}
2067
}
2068
function bug_report(test_suite, test_case, severity, file) {
2069
document.bugreport.short_desc.value = test_suite+": "+test_case+" "+severity;
2070
document.bugreport.comment.value = "Enter a description of the problem here\\n\\n---\\nDTK Manager: Please use the 'Add an attachment' button below to attach the following test journal:\\n "+file;
2071
document.bugreport.submit();
2072
}
2073
// ]]>
2074
</script>
2075
2076
HEREDOC
2077
2078
# Main title
2079
$res .= '<h1>Automatic test results for '.html($runconfig->{'HOST_OS'})
2080
.' on '.html($runconfig->{'HOST_architecture'}).'</h1>';
2081
2082
if ( -f "$result_dir/log" ) {
2083
$res .= '<p>The complete console output log is available '
2084
.local_href( "log", 'here' ).'.</p>';
2085
}
2086
if ( -f "$result_dir/verbose_log" ) {
2087
$res .= '<p>The '.local_href( "verbose_log", 'verbose log' )
2088
.' is also available.</p>';
2089
}
2090
2091
$res .= '<table class="info">';
2092
$res .= info_line("Standard", $runconfig->{'STANDARD'});
2093
$res .= info_line("Machine", $runconfig->{'HOST_machine'}." (".$runconfig->{'HOST_architecture'}.")");
2094
$res .= info_line("Package Manager", $runconfig->{'HOST_package_manager'});
2095
$res .= info_line("Kernel", $runconfig->{'HOST_kernel'});
2096
$res .= info_line("Operation System", $runconfig->{'HOST_OS'});
2097
$res .= info_line("/etc/issue", $runconfig->{'HOST_etc_issue'});
2098
$res .= '</table>';
2099
2100
return $res;
2101
}
2102
2103
sub Footer {
2104
my $res = "";
2105
2106
$res .= <<HEREDOC;
2107
2108
</body>
2109
</html>
2110
HEREDOC
2111
2112
return $res;
2113
}
2114
#----------------------------------------------------------------------
2115
my @toc_groups = ("Certification Tests", "Command Tests", "Static Interface Tests",
2116
"Runtime Interface Tests", "Automated Application Battery Tests", "Manual Tests" );
2117
2118
sub Tree_toc {
2119
my ($tests, $sort_arr) = @_;
2120
2121
my $res = "";
2122
2123
# Building a tree structure;
2124
my $tree = {};
2125
2126
foreach my $test_info ( values %$tests ) {
2127
my $tmp = $tree;
2128
2129
$test_info->{TREE} = "Undefined" if !defined $test_info->{TREE};
2130
2131
# Enter the groups
2132
foreach my $group_name ( split "/", $test_info->{TREE} ) {
2133
if ( $group_name =~ s/^<([^>]*)>// ) {
2134
# Standard group
2135
$group_name = $1;
2136
( in_array($group_name, @toc_groups) )
2137
or warning "Wrong group name: '$group_name'";
2138
}
2139
$tmp->{CHILDREN}->{$group_name} = {} if !$tmp->{CHILDREN}->{$group_name};
2140
$tmp = $tmp->{CHILDREN}->{$group_name};
2141
}
2142
# If this test has subtests, we shouldn't lose them.
2143
if ( defined $tmp->{CHILDREN}->{$test_info->{DISPLAYNAME}}->{CHILDREN} ) {
2144
$test_info->{CHILDREN} = $tmp->{CHILDREN}->{$test_info->{NAME}}->{CHILDREN};
2145
}
2146
# Add the test
2147
$tmp->{CHILDREN}->{$test_info->{DISPLAYNAME}} = $test_info;
2148
}
2149
2150
# Print the tree
2151
$res .= '<table class="toc">'."\n";
2152
2153
if ( $tree->{CHILDREN} ) {
2154
$res .= print_toc_subtree( $tree, 0, $sort_arr );
2155
}
2156
2157
$res .= '</table>'."\n";
2158
2159
return $res;
2160
}
2161
2162
sub print_toc_subtree {
2163
my ($subtree, $deep, $sort_arr) = @_;
2164
2165
my $res = "";
2166
2167
if ( $subtree->{CHILDREN} ) {
2168
my @keys = keys %{$subtree->{CHILDREN}};
2169
2170
@keys = sort {
2171
my $ap = in_array($a, @toc_groups);
2172
my $bp = in_array($b, @toc_groups);
2173
2174
return $ap <=> $bp if ( $ap && $bp );
2175
return $a cmp $b if ( !$ap && !$bp );
2176
return 1 if !$ap;
2177
return -1 if !$bp;
2178
} @keys;
2179
2180
foreach my $node ( @keys ) {
2181
my $child = $subtree->{CHILDREN}->{$node};
2182
push @$sort_arr, $child->{NAME} if $child->{NAME};
2183
$res .= print_toc_node( $node, $child, $deep, $sort_arr );
2184
}
2185
}
2186
2187
return $res;
2188
}
2189
2190
sub print_toc_node {
2191
my ($name, $subtree, $deep, $sort_arr) = @_;
2192
2193
my $res = "";
2194
2195
my $padding = 5 + $deep * 6;
2196
my $style_padding = "padding-left:$padding pt";
2197
2198
my $color = $deep <= 3 ? 160 + 30 * $deep : 250;
2199
$color = sprintf ('#%02X%02X%02X', $color, $color, 250);
2200
my $style_color = "background:$color";
2201
2202
if ( $subtree->{NAME} ) {
2203
my $test_info = $subtree;
2204
2205
# Test name as a link to the corresponding part of the report.
2206
$res .= '<tr style="'.$style_color.'">';
2207
$res .= '<td style="'.$style_padding.'"'
2208
.(defined $test_info->{VERSION} ? '' : ' colspan="2"').'>'."\n";
2209
$res .= '<a href="#'.$test_info->{NAME}.'" class="toclink">'
2210
.html($test_info->{DISPLAYNAME}).'</a>';
2211
$res .= '</td>';
2212
2213
# Version
2214
if ( defined $test_info->{VERSION} ) {
2215
$res .= '<td style="color:'.$dark_gray.'">'
2216
.'v '.html($test_info->{VERSION})
2217
.'</td>';
2218
}
2219
2220
$res .= '<td style="background-color:'.verdict_color($test_info->{VERDICT}, $color).'">'
2221
.verdict_text($test_info->{VERDICT}, "Undefined").'</td>'."\n";
2222
2223
$res .= '</tr>';
2224
}
2225
else {
2226
$res .= '<tr><th style="'.$style_color.";".$style_padding.'" colspan="3">'."\n";
2227
$res .= html($name);
2228
$res .= '</th></tr>';
2229
}
2230
if ( $subtree->{CHILDREN} ) {
2231
$res .= print_toc_subtree( $subtree, $deep + 1, $sort_arr );
2232
}
2233
2234
return $res;
2235
}
2236
#----------------------------------------------------------------------
2237
2238
sub verdict_color {
2239
my ($verdict, $default_color) = @_;
2240
2241
if ( !defined $verdict || $verdict eq "undefined" ) { # undef
2242
return $default_color;
2243
}
2244
elsif ( $verdict eq "run_problems" ) {
2245
return $fluorescent_red;
2246
}
2247
elsif ( $verdict eq "passed" ) {
2248
return $fluorescent_green;
2249
}
2250
elsif ( $verdict eq "warning" || $verdict eq "incomplete" ) {
2251
return $fluorescent_yellow;
2252
}
2253
elsif ( $verdict eq "failed" ) {
2254
return $fluorescent_red;
2255
}
2256
else {
2257
warning "Unhandled verdict: '$verdict'";
2258
}
2259
}
2260
2261
sub verdict_text {
2262
my ($verdict, $default_text) = @_;
2263
$default_text = "" if !defined $default_text;
2264
2265
if ( !$verdict || $verdict eq "undefined" ) {
2266
return $default_text;
2267
}
2268
elsif ( $verdict eq "run_problems" ) {
2269
return "There are problems";
2270
}
2271
elsif ( $verdict =~ m/^(passed|warning|incomplete|failed)$/ ) {
2272
return ucfirst $verdict;
2273
}
2274
else {
2275
warning "Unhandled verdict: '$verdict'";
2276
}
2277
}
2278
2279
sub print_stats {
2280
my ($stats) = @_;
2281
2282
my $tests_total = $stats->{TESTS_TOTAL};
2283
my $tests_passed = $stats->{PASSED};
2284
my $failures = $stats->{FAILURES};
2285
my $warnings = $stats->{WARNINGS};
2286
my $quelled = $stats->{QUELLED};
2287
my $notices = $stats->{NOTICES};
2288
my $untested = $stats->{UNTESTED};
2289
my $fips = $stats->{FIPS};
2290
my $tests_expected = $stats->{TESTS_EXPECTED};
2291
my $testsuite_errors = $stats->{TESTSUITE_ERRORS};
2292
2293
my $res = "";
2294
2295
$res .= '<h4>Journal statistics:</h4>'."\n";
2296
$res .= '<table class="info">'."\n";
2297
2298
if ( defined $tests_expected && defined $tests_total
2299
&& $tests_expected != $tests_total )
2300
{
2301
$res .= info_line('Tests Expected', $tests_expected, $fluorescent_yellow );
2302
}
2303
2304
$res .= info_line('Tests Total', $tests_total ) if defined $tests_total;
2305
2306
if ( defined $tests_passed ) { # zero value is printed too
2307
$res .= info_line('Tests Passed', $tests_passed, $fluorescent_green )
2308
}
2309
$res .= info_line('Tests Failed', $failures, $fluorescent_red ) if $failures;
2310
$res .= info_line('Test suite errors', $testsuite_errors, $fluorescent_red ) if $testsuite_errors;
2311
$res .= info_line('Warnings', $warnings, $fluorescent_yellow ) if $warnings;
2312
$res .= info_line('Quelled problems', $quelled ) if $quelled;
2313
$res .= info_line('Tests not relevant/not applicable', $untested ) if $untested;
2314
$res .= info_line('Notices', $notices ) if $notices;
2315
$res .= info_line('FIPs', $fips ) if $fips;
2316
2317
$res .= '</table>'."\n";
2318
2319
return $res;
2320
}
2321
2322
#----------------------------------------------------------------------
2323
1; # Return value
Loggerhead is a web-based interface for Breezy
Version: 2.0.1