js/src/tests/Patterns.pm

   1 # -*- Mode: Perl; tab-width: 4; indent-tabs-mode: nil; -*-
   2 # ***** BEGIN LICENSE BLOCK *****
   3 # Version: MPL 1.1/GPL 2.0/LGPL 2.1
   4 #
   5 # The contents of this file are subject to the Mozilla Public License Version
   6 # 1.1 (the "License"); you may not use this file except in compliance with
   7 # the License. You may obtain a copy of the License at
   8 # http://www.mozilla.org/MPL/
   9 #
  10 # Software distributed under the License is distributed on an "AS IS" basis,
  11 # WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
  12 # for the specific language governing rights and limitations under the
  13 # License.
  14 #
  15 # The Original Code is Mozilla JavaScript Testing Utilities
  16 #
  17 # The Initial Developer of the Original Code is
  18 # Mozilla Corporation.
  19 # Portions created by the Initial Developer are Copyright (C) 2008
  20 # the Initial Developer. All Rights Reserved.
  21 #
  22 # Contributor(s): Bob Clary <bclary@bclary.com>
  23 #
  24 # Alternatively, the contents of this file may be used under the terms of
  25 # either the GNU General Public License Version 2 or later (the "GPL"), or
  26 # the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
  27 # in which case the provisions of the GPL or the LGPL are applicable instead
  28 # of those above. If you wish to allow use of your version of this file only
  29 # under the terms of either the GPL or the LGPL, and not to allow others to
  30 # use your version of this file under the terms of the MPL, indicate your
  31 # decision by deleting the provisions above and replace them with the notice
  32 # and other provisions required by the GPL or the LGPL. If you do not delete
  33 # the provisions above, a recipient may use your version of this file under
  34 # the terms of any one of the MPL, the GPL or the LGPL.
  35 #
  36 # ***** END LICENSE BLOCK *****
  37
  38 package Patterns;
  39
  40 sub getuniversekey
  41 {
  42     my ($machinerecord, $excludeduniversefield) = @_;
  43     my $i;
  44     my $key = '';
  45
  46     if ($DEBUG) {
  47         dbg("getuniversekey: \$machinerecord=" . recordtostring($machinerecord) . ", \$excludeduniversefield=$excludeduniversefield");
  48     }
  49
  50     for ($i = 0; $i < @universefields; $i++)
  51     {
  52         if ($DEBUG) {
  53             dbg("getuniversekey: \$universefields[$i]=$universefields[$i]");
  54         }
  55
  56         if ($universefields[$i] ne $excludeduniversefield)
  57         {
  58             $key .= $machinerecord->{$universefields[$i]}
  59         }
  60     }
  61
  62     if ($DEBUG) {
  63         dbg("getuniversekey=$key");
  64     }
  65
  66     return $key;
  67 }
  68
  69 sub getuniverse
  70 {
  71     my ($universekey, $excludeduniversefield) = @_;
  72     my $i;
  73     my $value;
  74     my $testrun;
  75     my @universe = ();
  76     my %universehash = ();
  77
  78     if ($DEBUG) {
  79         dbg("getuniverse: \$universekey=$universekey, \$excludeduniversefield=$excludeduniversefield");
  80     }
  81
  82     for ($i = 0; $i < @testruns; $i++)
  83     {
  84         $testrun = $testruns[$i];
  85         if ($DEBUG) {
  86             dbg("getuniverse: \$testruns[$i]=" . recordtostring($testrun));
  87         }
  88         $testrununiversekey = getuniversekey($testrun, $excludeduniversefield);
  89         if ($DEBUG) {
  90             dbg("getuniverse: \$testrununiversekey=$testrununiversekey");
  91         }
  92         if ($testrununiversekey =~ /$universekey/)
  93         {
  94             if ($DEBUG) {
  95                 dbg("getuniverse: matched \$testrununiversekey=$testrununiversekey to \$universekey=$universekey");
  96             }
  97             $value = $testrun->{$excludeduniversefield};
  98
  99             if ($DEBUG) {
 100                 dbg("getuniverse: \$testrun->{$excludeduniversefield}=$value");
 101             }
 102
 103             if (! $universehash{$value} )
 104             {
 105                 if ($DEBUG) {
 106                     dbg("getuniverse: pushing $value");
 107                 }
 108                 push @universe, ($value);
 109                 $universehash{$value} = 1;
 110             }
 111         }
 112     }
 113     @universe = sort @universe;
 114     if ($DEBUG) {
 115         dbg("getuniverse=" . join(',', @universe));
 116     }
 117     return @universe;
 118 }
 119
 120 sub recordtostring
 121 {
 122     my ($record) = @_;
 123     my $j;
 124     my $line   = '';
 125     my $field;
 126
 127     for ($j = 0; $j < @recordfields - 1; $j++)
 128     {
 129         $field = $recordfields[$j];
 130         if ($DEBUG) {
 131             dbg("recordtostring: \$field=$field, \$record->{$field}=$record->{$field}");
 132         }
 133         $line .= "$field=$record->{$field}, ";
 134     }
 135     $field = $recordfields[$#recordfields];
 136     if ($DEBUG) {
 137         dbg("recordtodtring: \$field=$field, \$record->{$field}= $record->{$field}");
 138     }
 139     $line .= "$field=$record->{$field}";
 140
 141     return $line;
 142 }
 143
 144 sub dumprecords
 145 {
 146     my $record;
 147     my $line;
 148     my $prevline = '';
 149     my $i;
 150
 151     if ($DEBUG) {
 152         dbg("dumping records");
 153     }
 154
 155 #    @records = sort sortrecords @records;
 156
 157     for ($i = 0; $i < @records; $i++)
 158     {
 159         $record = $records[$i];
 160         $line   = recordtostring($record);
 161         if ($line eq $prevline)
 162         {
 163             dbg("DUPLICATE $line") if ($DEBUG);
 164         }
 165         else
 166         {
 167             print "$line\n";
 168             $prevline = $line;
 169         }
 170     }
 171 }
 172
 173 sub sortrecords
 174 {
 175     return recordtostring($a) cmp recordtostring($b);
 176 }
 177
 178 sub dbg
 179 {
 180     if ($DEBUG)
 181     {
 182         print STDERR "DEBUG: " . join(" ", @_) . "\n";
 183     }
 184 }
 185
 186 sub copyreference
 187 {
 188     my ($fromreference) = @_;
 189     my $toreference = {};
 190     my $key;
 191
 192     foreach $key (keys %{$fromreference})
 193     {
 194         $toreference->{$key} = $fromreference->{$key};
 195     }
 196     return $toreference;
 197 }
 198
 199 BEGIN
 200 {
 201     dbg("begin");
 202
 203     my $test_dir = $ENV{TEST_DIR} || "/work/mozilla/mozilla.com/test.mozilla.com/www";
 204
 205     $DEBUG = $ENV{DEBUG};
 206
 207     @recordfields   = ('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');
 208     @sortkeyfields  = ('TEST_ID', 'TEST_RESULT', 'TEST_EXITSTATUS', 'TEST_DESCRIPTION', 'TEST_BRANCH', 'TEST_REPO', 'TEST_BUILDTYPE', 'TEST_TYPE', 'TEST_OS', 'TEST_KERNEL', 'TEST_PROCESSORTYPE', 'TEST_MEMORY', 'TEST_TIMEZONE', 'TEST_OPTIONS');
 209     @universefields = ('TEST_BRANCH', 'TEST_REPO', 'TEST_BUILDTYPE', 'TEST_TYPE', 'TEST_OS', 'TEST_KERNEL', 'TEST_PROCESSORTYPE', 'TEST_MEMORY', 'TEST_TIMEZONE', 'TEST_OPTIONS');
 210
 211     @records = ();
 212
 213     @testruns = ();
 214
 215     my $UNIVERSE = $ENV{TEST_UNIVERSE} || "$test_dir/tests/mozilla.org/js/universe.data";
 216
 217     dbg "UNIVERSE=$UNIVERSE";
 218
 219     open TESTRUNS, "<$UNIVERSE" or die "$?";
 220
 221     while (<TESTRUNS>) {
 222
 223         chomp;
 224
 225         dbg("BEGIN: \$_=$_\n");
 226
 227         my $record = {};
 228
 229         my ($test_os, $test_kernel, $test_processortype, $test_memory, $test_timezone, $test_jsoptions, $test_branch, $test_repo, $test_buildtype, $test_type) = $_ =~
 230             /^TEST_OS=([^,]*), TEST_KERNEL=([^,]*), TEST_PROCESSORTYPE=([^,]*), TEST_MEMORY=([^,]*), TEST_TIMEZONE=([^,]*), TEST_OPTIONS=([^,]*), TEST_BRANCH=([^,]*), TEST_REPO=([^,]*), TEST_BUILDTYPE=([^,]*), TEST_TYPE=([^,]*)/;
 231
 232         $record->{TEST_ID}            = 'dummy';
 233         $record->{TEST_RESULT}        = 'dummy';
 234         $record->{TEST_EXITSTATUS}    = 'dummy';
 235         $record->{TEST_DESCRIPTION}   = 'dummy';
 236
 237         $record->{TEST_BRANCH}        = $test_branch;
 238         $record->{TEST_REPO}          = $test_repo;
 239         $record->{TEST_BUILDTYPE}     = $test_buildtype;
 240         $record->{TEST_TYPE}          = $test_type;
 241         $record->{TEST_OS}            = $test_os;
 242         $record->{TEST_KERNEL}        = $test_kernel;
 243         $record->{TEST_PROCESSORTYPE} = $test_processortype;
 244         $record->{TEST_MEMORY}        = $test_memory;
 245         $record->{TEST_TIMEZONE}      = $test_timezone;
 246         $record->{TEST_OPTIONS}       = $test_jsoptions;
 247
 248         dbg("BEGIN: testrun: " . recordtostring($record));
 249
 250         push @testruns, ($record);
 251     }
 252
 253     close TESTRUNS;
 254
 255 }
 256
 257 1;