gecko/js/tests/create-patterns.pl

265 lines
7.9 KiB
Perl
Raw Normal View History

#!/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";
}
}