js/src/tests/pattern-extracter.pl

   1 #!/usr/bin/perl -w
   2 # -*- Mode: Perl; tab-width: 4; indent-tabs-mode: nil; -*-
   3 # ***** BEGIN LICENSE BLOCK *****
   4 # Version: MPL 1.1/GPL 2.0/LGPL 2.1
   5 #
   6 # The contents of this file are subject to the Mozilla Public License Version
   7 # 1.1 (the "License"); you may not use this file except in compliance with
   8 # the License. You may obtain a copy of the License at
   9 # http://www.mozilla.org/MPL/
  10 #
  11 # Software distributed under the License is distributed on an "AS IS" basis,
  12 # WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
  13 # for the specific language governing rights and limitations under the
  14 # License.
  15 #
  16 # The Original Code is Mozilla JavaScript Testing Utilities
  17 #
  18 # The Initial Developer of the Original Code is
  19 # Mozilla Corporation.
  20 # Portions created by the Initial Developer are Copyright (C) 2008
  21 # the Initial Developer. All Rights Reserved.
  22 #
  23 # Contributor(s): Bob Clary <bclary@bclary.com>
  24 #
  25 # Alternatively, the contents of this file may be used under the terms of
  26 # either the GNU General Public License Version 2 or later (the "GPL"), or
  27 # the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
  28 # in which case the provisions of the GPL or the LGPL are applicable instead
  29 # of those above. If you wish to allow use of your version of this file only
  30 # under the terms of either the GPL or the LGPL, and not to allow others to
  31 # use your version of this file under the terms of the MPL, indicate your
  32 # decision by deleting the provisions above and replace them with the notice
  33 # and other provisions required by the GPL or the LGPL. If you do not delete
  34 # the provisions above, a recipient may use your version of this file under
  35 # the terms of any one of the MPL, the GPL or the LGPL.
  36 #
  37 # ***** END LICENSE BLOCK *****
  38
  39 # usage: pattern-extracter.pl knownfailures.expanded > knownfailures
  40 #
  41 # pattern-extracter.pl reads the specified expanded knownfailures file
  42 # (see pattern-expander.pl) and writes to stdout a set of knownfailures
  43 # where repetitions of values found in the universe.data file are
  44 # replaced with wildcards ".*".
  45
  46 use lib $ENV{TEST_DIR} . "/tests/mozilla.org/js";
  47
  48 use Patterns;
  49
  50 package Patterns;
  51
  52
  53 my $universefield;
  54
  55 processfile();
  56
  57 sub processfile
  58 {
  59     my $recordcurr = {};
  60     my $recordprev;
  61
  62     my @output;
  63     my $keycurr = '';
  64     my $keyprev = '';
  65     my @values = ();
  66     my $universefielduniversekey; # universekey for universefield
  67     my @universefielduniverse;
  68     my $i;
  69     my $j;
  70     my $v;
  71
  72     while (<ARGV>) {
  73
  74         chomp;
  75
  76         $recordcurr = {};
  77
  78         my ($test_id, $test_branch, $test_repo, $test_buildtype, $test_type, $test_os, $test_kernel, $test_processortype, $test_memory, $test_timezone, $test_options, $test_result, $test_exitstatus, $test_description) = $_ =~
  79             /TEST_ID=([^,]*), TEST_BRANCH=([^,]*), TEST_REPO=([^,]*), TEST_BUILDTYPE=([^,]*), TEST_TYPE=([^,]*), TEST_OS=([^,]*), TEST_KERNEL=([^,]*), TEST_PROCESSORTYPE=([^,]*), TEST_MEMORY=([^,]*), TEST_TIMEZONE=([^,]*), TEST_OPTIONS=([^,]*), TEST_RESULT=([^,]*), TEST_EXITSTATUS=([^,]*), TEST_DESCRIPTION=(.*)/;
  80
  81         $recordcurr->{TEST_ID}            = $test_id;
  82         $recordcurr->{TEST_BRANCH}        = $test_branch;
  83         $recordcurr->{TEST_REPO}          = $test_repo;
  84         $recordcurr->{TEST_BUILDTYPE}     = $test_buildtype;
  85         $recordcurr->{TEST_TYPE}          = $test_type;
  86         $recordcurr->{TEST_OS}            = $test_os;
  87         $recordcurr->{TEST_KERNEL}        = $test_kernel;
  88         $recordcurr->{TEST_PROCESSORTYPE} = $test_processortype;
  89         $recordcurr->{TEST_MEMORY}        = $test_memory;
  90         $recordcurr->{TEST_TIMEZONE}      = $test_timezone;
  91         $recordcurr->{TEST_OPTIONS}       = $test_options;
  92         $recordcurr->{TEST_RESULT}        = $test_result;
  93         $recordcurr->{TEST_EXITSTATUS}    = $test_exitstatus;
  94         $recordcurr->{TEST_DESCRIPTION}   = $test_description;
  95
  96         push @records, ($recordcurr);
  97     }
  98
  99     for ($j = $#universefields; $j >= 0; $j--)
 100     {
 101         $universefield   = $universefields[$j];
 102
 103         @records = sort {getkey($a, $universefield) cmp getkey($b, $universefield);} @records;
 104
 105         $recordprev = $records[0];
 106         $keyprev    = getkey($recordprev, $universefield);
 107         @values     = ();
 108
 109         my $recordtemp;
 110         my $keytemp;
 111
 112         dbg("processfile: begin processing records for \$universefields[$j]=$universefield");
 113
 114         for ($i = 0; $i < @records; $i++)
 115         {
 116             $recordcurr = $records[$i];
 117             $keycurr = getkey($recordcurr, $universefield);
 118
 119             dbg("processfile: processing record[$i]");
 120             dbg("processfile: recordprev: " . recordtostring($recordprev));
 121             dbg("processfile: recordcurr: " . recordtostring($recordcurr));
 122             dbg("processfile: \$keyprev=$keyprev");
 123             dbg("processfile: \$keycurr=$keycurr");
 124
 125             if ($keycurr ne $keyprev)
 126             {
 127                 # key changed, must output previous record
 128                 dbg("processfile: new key");
 129                 $universefielduniversekey = getuniversekey($recordprev, $universefield);
 130                 @universefielduniverse = getuniverse($universefielduniversekey, $universefield);
 131                 dbg("processfile: \@values: ". join(',', @values));
 132                 dbg("processfile: \$universefielduniversekey=$universefielduniversekey, \@universefielduniverse=" . join(',', @universefielduniverse));
 133                 @values = ('.*') if (arraysequal($universefield, \@values, \@universefielduniverse));
 134                 dbg("processfile: \@values=" . join(',', @values));
 135
 136                 for ($v = 0; $v < @values; $v++)
 137                 {
 138                     dbg("processfile: stuffing $values[$v]");
 139                     $recordtemp = copyreference($recordprev);
 140                     $recordtemp->{$universefield} = $values[$v];
 141                     dbg("processfile: stuffed $recordtemp->{$universefield}");
 142                     dbg("processfile: recordprev: " . recordtostring($recordprev));
 143                     dbg("processfile: output: " . recordtostring($recordtemp));
 144                     push @output, ($recordtemp);
 145                 }
 146                 @values = ();
 147             }
 148             dbg("processfile: collecting \$recordcurr->{$universefield}=$recordcurr->{$universefield}");
 149             push @values, ($recordcurr->{$universefield});
 150             $keyprev = $keycurr;
 151             $recordprev = $recordcurr;
 152         }
 153         dbg("processfile: finish processing records for \$universefields[$j]=$universefield");
 154         if (@values)
 155         {
 156             dbg("processfile: last record for \$universefields[$j]=$universefield has pending values");
 157             $universefielduniversekey = getuniversekey($recordprev, $universefield);
 158             @universefielduniverse = getuniverse($universefielduniversekey, $universefield);
 159             dbg("processfile: \@values: ". join(',', @values));
 160             dbg("processfile: \$universefielduniversekey=$universefielduniversekey, \@universefielduniverse=" . join(',', @universefielduniverse));
 161             @values = ('.*') if (arraysequal($universefield, \@values, \@universefielduniverse));
 162             dbg("processfile: \@values=" . join(',', @values));
 163
 164             for ($v = 0; $v < @values; $v++)
 165             {
 166                 dbg("processfile: stuffing $values[$v]");
 167                 $recordtemp = copyreference($recordprev);
 168                 $recordtemp->{$universefield} = $values[$v];
 169                 dbg("processfile: stuffed $recordprev->{$universefield}");
 170                 dbg("processfile: recordprev: " . recordtostring($recordprev));
 171                 dbg("processfile: output: " . recordtostring($recordtemp));
 172                 push @output, ($recordtemp);
 173             }
 174             @values = ();
 175         }
 176         @records = @output;
 177         @output = ();
 178     }
 179
 180     @records = sort sortrecords @records;
 181     dumprecords();
 182 }
 183
 184
 185 sub getkey
 186 {
 187     my ($record, $universefield) = @_;
 188
 189     my $i;
 190
 191     my $key = '';
 192
 193     for ($i = 0; $i < @sortkeyfields; $i++)
 194     {
 195         if ($sortkeyfields[$i] ne $universefield)
 196         {
 197             $key .= $record->{$sortkeyfields[$i]}
 198         }
 199     }
 200     return $key;
 201 }
 202
 203 sub arraysequal
 204 {
 205     my ($universefield, $larrayref, $rarrayref) = @_;
 206     my $i;
 207
 208     dbg("arraysequal: checking $universefield if " . (join ',', @{$larrayref}) . " is equal to " . (join ',', @{$rarrayref}));
 209
 210     # fail if lengths not equal
 211     return 0 if (@{$larrayref} != @{$rarrayref});
 212
 213     # if the universe field is 'important', fail if lengths are 1,
 214     # so that important field singletons are not replaced by wildcards.
 215     my @importantfields = ('TEST_BRANCH', 'TEST_REPO', 'TEST_BUILDTYPE', 'TEST_TYPE', 'TEST_OS');
 216     my @matches = grep /$universefield/, @importantfields;
 217
 218     return 0 if ( @matches && @{$larrayref} == 1);
 219
 220     for ($i = 0; $i < @{$larrayref}; $i++)
 221     {
 222         return 0 if ($rarrayref->[$i] ne $larrayref->[$i]);
 223     }
 224     dbg("arraysequal: equal");
 225     return 1;
 226 }
 227