зеркало из https://github.com/mozilla/gecko-dev.git
265 строки
7.9 KiB
Perl
Executable File
265 строки
7.9 KiB
Perl
Executable File
#!/usr/bin/perl
|
|
# -*- Mode: Perl; tab-width: 4; indent-tabs-mode: nil; -*-
|
|
|
|
# ***** BEGIN LICENSE BLOCK *****
|
|
# Version: MPL 1.1/GPL 2.0/LGPL 2.1
|
|
#
|
|
# The contents of this file are subject to the Mozilla Public License Version
|
|
# 1.1 (the "License"); you may not use this file except in compliance with
|
|
# the License. You may obtain a copy of the License at
|
|
# http://www.mozilla.org/MPL/
|
|
#
|
|
# Software distributed under the License is distributed on an "AS IS" basis,
|
|
# WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
|
|
# for the specific language governing rights and limitations under the
|
|
# License.
|
|
#
|
|
# The Original Code is Mozilla JavaScript Testing Utilities
|
|
#
|
|
# The Initial Developer of the Original Code is
|
|
# Mozilla Corporation.
|
|
# Portions created by the Initial Developer are Copyright (C) 2007
|
|
# the Initial Developer. All Rights Reserved.
|
|
#
|
|
# Contributor(s): Bob Clary <bclary@bclary.com>
|
|
#
|
|
# Alternatively, the contents of this file may be used under the terms of
|
|
# either the GNU General Public License Version 2 or later (the "GPL"), or
|
|
# the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
|
|
# in which case the provisions of the GPL or the LGPL are applicable instead
|
|
# of those above. If you wish to allow use of your version of this file only
|
|
# under the terms of either the GPL or the LGPL, and not to allow others to
|
|
# use your version of this file under the terms of the MPL, indicate your
|
|
# decision by deleting the provisions above and replace them with the notice
|
|
# and other provisions required by the GPL or the LGPL. If you do not delete
|
|
# the provisions above, a recipient may use your version of this file under
|
|
# the terms of any one of the MPL, the GPL or the LGPL.
|
|
#
|
|
# ***** END LICENSE BLOCK *****
|
|
|
|
# make stderr, stdout unbuffered
|
|
|
|
select STDERR; $| = 1;
|
|
select STDOUT; $| = 1;
|
|
|
|
my $regchars = '\[\^\-\]\|\{\}\?\*\+\.\<\>\$\(\)';
|
|
|
|
sub escape_patterns;
|
|
sub unescape_patterns;
|
|
sub debug;
|
|
|
|
my $debug = $ENV{DEBUG};
|
|
my @outputlines = ();
|
|
my @inputlines = ();
|
|
|
|
while (<ARGV>) {
|
|
chomp;
|
|
|
|
# remove irrelevant data the caller is required to remove any
|
|
# other data which should not be considered during the
|
|
# consolidation such as TEST_MACHINE, etc.
|
|
|
|
s/TEST_DATE=[^,]*,/TEST_DATE=.*,/;
|
|
|
|
push @inputlines, ($_);
|
|
|
|
}
|
|
|
|
my @fieldnames = ('TEST_BRANCH', 'TEST_BUILDTYPE', 'TEST_TYPE', 'TEST_OS', 'TEST_PROCESSORTYPE', 'TEST_KERNEL', 'TEST_TIMEZONE');
|
|
|
|
my $pass = 0;
|
|
my $changed = 1;
|
|
|
|
while ($changed) {
|
|
|
|
# repeated loop until no changes are made.
|
|
|
|
++$pass;
|
|
$changed = 0;
|
|
|
|
debug "pass $pass, " . ($#inputlines + 1) . " inputlines, " . ($#outputlines + 1) . " outputlines\n";
|
|
|
|
foreach $field (@fieldnames) {
|
|
|
|
debug "pass $pass, processing $field, " . ($#inputlines + 1) . " inputlines, " . ($#outputlines + 1) . " outputlines\n";
|
|
|
|
# process each field across all lines so that later consolidations
|
|
# will match consolidated field values
|
|
|
|
while ($inputline = shift(@inputlines)) {
|
|
|
|
debug "inputline $inputline\n";
|
|
|
|
# get the current field value from the current input line
|
|
|
|
($inputvalue) = $inputline =~ /$field=\(?([^,\)]*)\)?,/;
|
|
|
|
if ($inputvalue eq '.*') {
|
|
|
|
# if the current input value is the any wildcard,
|
|
# then there is no need to perform a consolidation
|
|
# on the field.
|
|
|
|
push @outputlines, ($inputline);
|
|
|
|
next;
|
|
}
|
|
|
|
# turn "off" any regular expression characters in the input line
|
|
|
|
$pattern = escape_pattern($inputline);
|
|
|
|
# Make the current field in the current pattern an any
|
|
# wildcard so that it will match any value. We are looking
|
|
# for all other lines that only differ from the current line by
|
|
# the current field value
|
|
|
|
$pattern =~ s/$field=[^,]*,/$field=.*,/;
|
|
|
|
# find the matches to the current pattern
|
|
|
|
debug "pattern: $pattern\n";
|
|
|
|
@matched = grep /$pattern/, (@inputlines, @outputlines);
|
|
@unmatched = grep !/$pattern/, @inputlines;
|
|
|
|
debug "" . ($#matched + 1) . " matched, " . ($#unmatched + 1) . " unmatched, " . ($#inputlines + 1) . " inputlines, " . ($#outputlines + 1) . " outputlines\n";
|
|
|
|
if (@matched) {
|
|
|
|
# the input line matched others
|
|
|
|
$outputvalue = $inputvalue;
|
|
|
|
foreach $matchline (@matched) {
|
|
|
|
($matchvalue) = $matchline =~ /$field=\(?([^,\)]*)\)?,/;
|
|
|
|
if ( $inputvalue !~ /$matchvalue/ && $matchvalue !~ /$inputvalue/) {
|
|
|
|
# the current match value and input value
|
|
# do not overlap so add the match
|
|
# field value as regular expression
|
|
# alternation | to the current field value
|
|
|
|
debug "adding regexp alternation to $field: inputvalue: $inputvalue, matchvalue: $matchvalue";
|
|
|
|
$outputvalue .= "|$matchvalue";
|
|
}
|
|
} # foreach matchline
|
|
|
|
# replace the current inputs field value with the
|
|
# consolidated value
|
|
|
|
if ($outputvalue =~ /\|/) {
|
|
$outputvalue = "(" . join('|', sort(split(/\|/, $outputvalue))) . ")";
|
|
}
|
|
$inputline =~ s/$field=[^,]*,/$field=$outputvalue,/;
|
|
debug "$inputline\n";
|
|
|
|
$changes = 1;
|
|
}
|
|
push @outputlines, ($inputline);
|
|
|
|
@inputlines = @unmatched;
|
|
|
|
} # while inputline
|
|
|
|
@inputlines = @outputlines;
|
|
@outputlines = ();
|
|
|
|
} # foreach field
|
|
}
|
|
|
|
@inputlines = sort @inputlines;
|
|
|
|
my $output = join"\n", @inputlines;
|
|
|
|
debug "output: " . ($#inputlines + 1) . " lines\n";
|
|
|
|
print "$output\n";
|
|
|
|
### # look for over specified failures
|
|
###
|
|
### $field = 'TEST_DESCRIPTION';
|
|
###
|
|
### while ($inputline = shift(@inputlines)) {
|
|
###
|
|
### debug "inputline $inputline\n";
|
|
###
|
|
### # turn "off" any regular expression characters in the input line
|
|
###
|
|
### $pattern = escape_pattern($inputline);
|
|
###
|
|
### # Make the TEST_DESCRIPTION field in the current pattern an any
|
|
### # wildcard so that it will match any value. We are looking
|
|
### # for all other lines that only differ from the current line by
|
|
### # the TEST_DESCRIPTION. These will be the potentially overspecified
|
|
### # failures.
|
|
###
|
|
### $pattern =~ s/$field=[^,]*,/$field=.*,/;
|
|
###
|
|
### # find the matches to the current pattern
|
|
###
|
|
### debug "pattern: $pattern\n";
|
|
###
|
|
### @matched = grep /$pattern/, @inputlines;
|
|
### @unmatched = grep !/$pattern/, @inputlines;
|
|
###
|
|
### debug "" . ($#matched + 1) . " matched, " . ($#unmatched + 1) . " unmatched, " . ($#inputlines + 1) . " inputlines, " . ($#outputlines + 1) . " outputlines\n";
|
|
###
|
|
### if (@matched) {
|
|
###
|
|
### # the inputline overspecifies an error
|
|
###
|
|
### push @matched, ($inputline);
|
|
###
|
|
### foreach $matchline (@matched) {
|
|
###
|
|
### print STDERR "OVERSPECIFIED? : $matchline\n";
|
|
###
|
|
### } # foreach matchline
|
|
###
|
|
### }
|
|
###
|
|
### @inputlines = @unmatched;
|
|
###
|
|
### } # while inputline
|
|
###
|
|
|
|
|
|
|
|
sub escape_pattern {
|
|
|
|
# unlike the known-failures.pl, this escape escapes the entire
|
|
# line to make it not contain any active regular expression patterns
|
|
# so that any matched will be literal and not regular
|
|
my $line = shift;
|
|
|
|
chomp;
|
|
|
|
# replace unescaped regular expression characters in the
|
|
# description so they are not interpreted as regexp chars
|
|
# when matching descriptions. leave the escaped regexp chars
|
|
# `regexp alone so they can be unescaped later and used in
|
|
# pattern matching.
|
|
|
|
# see perldoc perlre
|
|
|
|
$line =~ s/\\/\\\\/g;
|
|
|
|
# escape regexpchars
|
|
$line =~ s/([$regchars])/\\$1/g;
|
|
|
|
return "$line";
|
|
|
|
}
|
|
|
|
sub debug {
|
|
my $msg;
|
|
if ($debug) {
|
|
$msg = shift;
|
|
print "DEBUG: $msg\n";
|
|
}
|
|
}
|