js/src/tests/known-failures.pl

   1 #!/usr/bin/perl
   2 # -*- Mode: Perl; tab-width: 4; indent-tabs-mode: nil; -*-
   3
   4 # ***** BEGIN LICENSE BLOCK *****
   5 # Version: MPL 1.1/GPL 2.0/LGPL 2.1
   6 #
   7 # The contents of this file are subject to the Mozilla Public License Version
   8 # 1.1 (the "License"); you may not use this file except in compliance with
   9 # the License. You may obtain a copy of the License at
  10 # http://www.mozilla.org/MPL/
  11 #
  12 # Software distributed under the License is distributed on an "AS IS" basis,
  13 # WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
  14 # for the specific language governing rights and limitations under the
  15 # License.
  16 #
  17 # The Original Code is Mozilla JavaScript Testing Utilities
  18 #
  19 # The Initial Developer of the Original Code is
  20 # Mozilla Corporation.
  21 # Portions created by the Initial Developer are Copyright (C) 2007
  22 # the Initial Developer. All Rights Reserved.
  23 #
  24 # Contributor(s): Bob Clary <bclary@bclary.com>
  25 #
  26 # Alternatively, the contents of this file may be used under the terms of
  27 # either the GNU General Public License Version 2 or later (the "GPL"), or
  28 # the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
  29 # in which case the provisions of the GPL or the LGPL are applicable instead
  30 # of those above. If you wish to allow use of your version of this file only
  31 # under the terms of either the GPL or the LGPL, and not to allow others to
  32 # use your version of this file under the terms of the MPL, indicate your
  33 # decision by deleting the provisions above and replace them with the notice
  34 # and other provisions required by the GPL or the LGPL. If you do not delete
  35 # the provisions above, a recipient may use your version of this file under
  36 # the terms of any one of the MPL, the GPL or the LGPL.
  37 #
  38 # ***** END LICENSE BLOCK *****
  39
  40 use strict;
  41 use Getopt::Mixed "nextOption";
  42
  43 # predeclarations
  44 sub debug;
  45 sub usage;
  46 sub parse_options;
  47 sub escape_string;
  48 sub escape_pattern;
  49 sub unescape_pattern;
  50
  51 # option arguments
  52
  53 my $option_desc = "b=s branch>b T=s buildtype>T R=s repo>R t=s testtype>t o=s os>o K=s kernel>K A=s arch>A M=s memory>M z=s timezone>z J=s jsoptions>J l=s rawlogfile>l f=s failurelogfile>f r=s patterns>r O=s outputprefix>O D debug>D";
  54
  55 my $testid;
  56 my $branch;
  57 my $repo;
  58 my $buildtype;
  59 my $testtype;
  60 my $rawlogfile;
  61 my $failurelogfile;
  62 my $os;
  63 my $patterns;
  64 my $timezone;
  65 my $jsoptions;
  66 my $outputprefix;
  67 my $arch;
  68 my $kernel;
  69 my $memory;
  70 my $debug = $ENV{DEBUG};
  71
  72 # pattern variables
  73
  74 my $knownfailurebranchpattern;
  75 my $failurebranchpattern;
  76 my $knownfailureospattern;
  77 my $failureospattern;
  78 my $knownfailurerepopattern;
  79 my $failurerepopattern;
  80 my $knownfailurebuildtypepattern;
  81 my $failurebuildtypepattern;
  82 my $knownfailuretesttypepattern;
  83 my $failuretesttypepattern;
  84 my $knownfailuretimezonepattern;
  85 my $failuretimezonepattern;
  86 my $knownfailurejsoptionspattern;
  87 my $failurejsoptionspattern;
  88 my $knownfailurearchpattern;
  89 my $failurearchpattern;
  90 my $knownfailurekernelpattern;
  91 my $failurekernelpattern;
  92 my $knownfailurememorypattern;
  93 my $failurememorypattern;
  94
  95 my @patterns;
  96 my $pattern;
  97 my @failures;
  98 my @fixes;
  99 my @excludedtests;
 100 my $excludedtest;
 101 my $excludedfile;
 102 my %includedtests = {};
 103 my $includedfile;
 104 my @results;
 105
 106 my $regchars = '\[\^\-\]\|\{\}\?\*\+\.\<\>\$\(\)';
 107
 108
 109 &parse_options;
 110
 111 my $jsdir = $ENV{TEST_JSDIR};
 112
 113 if (!defined($jsdir)) {
 114      $jsdir = "/work/mozilla/mozilla.com/test.mozilla.com/www/tests/mozilla.org/js";
 115 }
 116
 117 my @excludedfiles = ("excluded-$branch-$testtype-$buildtype.tests");
 118 my @includedfiles = ("included-$branch-$testtype-$buildtype.tests");
 119
 120  # create working patterns file consisting of matches to users selection
 121  # and which has the test description patterns escaped
 122
 123  # remove the excluded tests from the possible fixes log
 124
 125
 126 foreach $excludedfile ( @excludedfiles ) {
 127     open EXCLUDED, "<$jsdir/$excludedfile" or die "Unable to open excluded file $jsdir/$excludedfile: $!\n";
 128     while (<EXCLUDED>) {
 129         chomp;
 130
 131         next if ($_ =~ /^\#/);
 132
 133         s/\s+$//;
 134
 135         push @excludedtests, ($_);
 136     }
 137     close EXCLUDED;
 138 }
 139
 140 @excludedtests = sort @excludedtests;
 141
 142 foreach $includedfile ( @includedfiles ) {
 143     open INCLUDED, "<$jsdir/$includedfile" or die "Unable to open included file $jsdir/$includedfile: $!\n";
 144     while (<INCLUDED>) {
 145         chomp;
 146
 147         next if ($_ =~ /^\#/);
 148
 149         s/\s+$//;
 150
 151         $includedtests{$_} = 1;
 152     }
 153     close INCLUDED;
 154 }
 155
 156 debug "loading patterns $patterns";
 157 debug "pattern filter: ^TEST_ID=[^,]*, TEST_BRANCH=$knownfailurebranchpattern, TEST_REPO=$knownfailurerepopattern, TEST_BUILDTYPE=$knownfailurebuildtypepattern, TEST_TYPE=$knownfailuretesttypepattern, TEST_OS=$knownfailureospattern, TEST_KERNEL=$knownfailurekernelpattern, TEST_PROCESSORTYPE=$knownfailurearchpattern, TEST_MEMORY=$knownfailurememorypattern, TEST_TIMEZONE=$knownfailuretimezonepattern, TEST_OPTIONS=$knownfailurejsoptionspattern,";
 158
 159 open PATTERNS, "<$patterns" or die "Unable to open known failure patterns file $patterns: $!\n";
 160 while (<PATTERNS>) {
 161     chomp;
 162
 163     s/\s+$//;
 164
 165     ($testid) = $_ =~ /^TEST_ID=([^,]*),/;
 166
 167     if (!$includedtests{$testid})
 168     {
 169         debug "test $testid was not included during this run";
 170     }
 171     elsif ($_ =~ /^TEST_ID=[^,]*, TEST_BRANCH=$knownfailurebranchpattern, TEST_REPO=$knownfailurerepopattern, TEST_BUILDTYPE=$knownfailurebuildtypepattern, TEST_TYPE=$knownfailuretesttypepattern, TEST_OS=$knownfailureospattern, TEST_KERNEL=$knownfailurekernelpattern, TEST_PROCESSORTYPE=$knownfailurearchpattern, TEST_MEMORY=$knownfailurememorypattern, TEST_TIMEZONE=$knownfailuretimezonepattern, TEST_OPTIONS=$knownfailurejsoptionspattern,/) {
 172         debug "adding pattern  : $_";
 173         push @patterns, (escape_pattern($_));
 174     }
 175     else {
 176         debug "skipping pattern: $_";
 177     }
 178
 179 }
 180 close PATTERNS;
 181
 182  # create a working copy of the current failures which match the users selection
 183
 184 debug "failure filter: ^TEST_ID=[^,]*, TEST_BRANCH=$failurebranchpattern, TEST_REPO=$failurerepopattern, TEST_BUILDTYPE=$failurebuildtypepattern, TEST_TYPE=$failuretesttypepattern, TEST_OS=$failureospattern, TEST_KERNEL=$failurekernelpattern, TEST_PROCESSORTYPE=$failurearchpattern, TEST_MEMORY=$failurememorypattern, TEST_TIMEZONE=$failuretimezonepattern, TEST_OPTIONS=$failurejsoptionspattern, TEST_RESULT=FAIL[^,]*,/";
 185
 186 if (defined($rawlogfile)) {
 187
 188     $failurelogfile = "$outputprefix-results-failures.log";
 189     my $alllog      = "$outputprefix-results-all.log";
 190
 191     debug "writing failures $failurelogfile";
 192
 193     open INPUTLOG, "$jsdir/post-process-logs.pl $rawlogfile |" or die "Unable to open $rawlogfile $!\n";
 194     open ALLLOG, ">$alllog" or die "Unable to open $alllog $!\n";
 195     open FAILURELOG, ">$failurelogfile" or die "Unable to open $failurelogfile $!\n";
 196
 197     while (<INPUTLOG>) {
 198         chomp;
 199
 200         print ALLLOG "$_\n";
 201
 202         if ($_ =~ /^TEST_ID=[^,]*, TEST_BRANCH=$failurebranchpattern, TEST_REPO=$failurerepopattern, TEST_BUILDTYPE=$failurebuildtypepattern, TEST_TYPE=$failuretesttypepattern, TEST_OS=$failureospattern, TEST_KERNEL=$failurekernelpattern, TEST_PROCESSORTYPE=$failurearchpattern, TEST_MEMORY=$failurememorypattern, TEST_TIMEZONE=$failuretimezonepattern, TEST_OPTIONS=$failurejsoptionspattern, TEST_RESULT=FAIL[^,]*,/) {
 203             debug "failure: $_";
 204             push @failures, ($_);
 205             print FAILURELOG "$_\n";
 206         }
 207     }
 208     close INPUTLOG;
 209     my $inputrc = $?;
 210     close ALLLOG;
 211     close FAILURELOG;
 212
 213     die "FATAL ERROR in post-process-logs.pl" if $inputrc != 0;
 214 }
 215 else
 216 {
 217     debug "loading failures $failurelogfile";
 218
 219     my $failurelogfilemode;
 220
 221     if ($failurelogfile =~ /\.bz2$/)
 222     {
 223         $failurelogfilemode = "bzcat $failurelogfile|";
 224     }
 225     elsif ($failurelogfile =~ /\.gz$/)
 226     {
 227         $failurelogfilemode = "zcat $failurelogfile|";
 228     }
 229     else
 230     {
 231         $failurelogfilemode = "<$failurelogfile";
 232     }
 233
 234     open FAILURES, "$failurelogfilemode" or die "Unable to open current failure log $failurelogfile: $!\n";
 235     while (<FAILURES>) {
 236         chomp;
 237
 238         if ($_ =~ /^TEST_ID=[^,]*, TEST_BRANCH=$failurebranchpattern, TEST_REPO=$failurerepopattern, TEST_BUILDTYPE=$failurebuildtypepattern, TEST_TYPE=$failuretesttypepattern, TEST_OS=$failureospattern, TEST_KERNEL=$failurekernelpattern, TEST_PROCESSORTYPE=$failurearchpattern, TEST_MEMORY=$failurememorypattern, TEST_TIMEZONE=$failuretimezonepattern, TEST_OPTIONS=$failurejsoptionspattern, TEST_RESULT=FAIL[^,]*,/) {
 239             debug "failure: $_";
 240             push @failures, ($_);
 241         }
 242     }
 243     close FAILURES;
 244 }
 245
 246 debug "finding fixed bugs";
 247
 248 unlink "$outputprefix-results-possible-fixes.log";
 249
 250 foreach $pattern (@patterns) {
 251     # look for known failure patterns that don't have matches in the
 252     # the current failures selected by the user.
 253
 254     debug "searching for matches to $pattern\n";
 255
 256     @results = grep m@^$pattern@, @failures;
 257
 258     if ($debug) {
 259         my $failure;
 260         foreach $failure (@failures) {
 261             if ($failure =~ $pattern) {
 262                 debug "MATCH: $pattern - $failure\n";
 263             }
 264             else {
 265                 debug "NOMATCH: $pattern - $failure\n";
 266             }
 267         }
 268     }
 269     if ($#results == -1) {
 270         debug "fix: '$pattern'";
 271         push @fixes, ($pattern)
 272     }
 273 }
 274
 275 foreach $excludedtest ( @excludedtests ) {
 276     # remove any potential fixes which are due to the test being excluded
 277
 278     if ($debug) {
 279         @results = grep m@$excludedtest@, @fixes;
 280         if ($#results > -1) {
 281             print "excluding: " . (join ', ', @results) . "\n";
 282         }
 283     }
 284
 285     @results = grep !m@$excludedtest@, @fixes;
 286
 287     @fixes = @results;
 288 }
 289
 290 my $fix;
 291 open OUTPUT, ">$outputprefix-results-possible-fixes.log" or die "Unable to open $outputprefix-results-possible-fixes.log: $!";
 292 foreach $fix (@fixes) {
 293     print OUTPUT unescape_pattern($fix) . "\n";
 294     if ($debug) {
 295         debug "fix: $fix";
 296     }
 297 }
 298 close OUTPUT;
 299
 300 print STDOUT "log: $outputprefix-results-possible-fixes.log\n";
 301
 302 debug "finding regressions";
 303
 304 my $pass = 0;
 305 my $changed = ($#patterns != -1);
 306
 307 debug "changed=$changed, \$#patterns=$#patterns, \$#failures=$#failures";
 308
 309 while ($changed) {
 310
 311     $pass = $pass + 1;
 312
 313     $changed = 0;
 314
 315     debug "pass $pass";
 316
 317     foreach $pattern (@patterns) {
 318
 319         debug "Pattern: $pattern";
 320
 321         my @nomatches = grep !m@^$pattern@, @failures;
 322         my @matches   = grep m@^$pattern@, @failures;
 323
 324         if ($debug) {
 325             my $temp = join ', ', @nomatches;
 326             debug "nomatches: $#nomatches $temp";
 327             $temp = join ', ', @matches;
 328             debug "matches: $#matches $temp";
 329         }
 330
 331         @failures = @nomatches;
 332
 333         if ($#matches > -1) {
 334             $changed = 1;
 335         }
 336
 337         debug "*****************************************";
 338     }
 339
 340 }
 341
 342 debug "\$#excludedtests=$#excludedtests, \$#failures=$#failures";
 343
 344 foreach $excludedtest ( @excludedtests ) {
 345
 346     if ($debug) {
 347         @results = grep m@$excludedtest@, @failures;
 348         if ($#results > -1) {
 349             print "excluding: " . (join ', ', @results) . "\n";
 350         }
 351     }
 352
 353     @results = grep !m@$excludedtest@, @failures;
 354
 355     debug "\$#results=$#results, \$excludedtest=$excludedtest, \$#failures=$#failures";
 356
 357     @failures = @results;
 358 }
 359
 360 debug "possible regressions: \$#failures=$#failures";
 361
 362 open OUTPUT, ">$outputprefix-results-possible-regressions.log" or die "Unable to open $outputprefix-results-possible-regressions.log: $!";
 363
 364 my $failure;
 365 foreach $failure (@failures) {
 366     print OUTPUT "$failure\n";
 367     if ($debug) {
 368         debug "regression: $failure";
 369     }
 370 }
 371 close OUTPUT;
 372
 373 print STDOUT "log: $outputprefix-results-possible-regressions.log\n";
 374
 375
 376 sub debug {
 377     if ($debug) {
 378         my $msg = shift;
 379         print STDERR "DEBUG: $msg\n";
 380     }
 381 }
 382
 383 sub usage {
 384
 385     my $msg = shift;
 386
 387     print STDERR <<EOF;
 388
 389 usage: $msg
 390
 391 known-failures.pl [-b|--branch] branch
 392                   [-T|--buildtype] buildtype
 393                   [-t|--testtype] testtype
 394                   [-o|--os] os
 395                   [-K|--kernel] kernel
 396                   [-A|--arch] arch
 397                   [-M|--memory] memory
 398                   [-z|--timezone] timezone
 399                   [-J|--jsoptions] jsoptions
 400                   [-r|--patterns] patterns
 401                   ([-f|--failurelogfile] failurelogfile|[-l|--logfile] rawlogfile])
 402                   [-O|--outputprefix] outputprefix
 403                   [-D]
 404
 405     variable            description
 406     ===============     ============================================================
 407     -b branch           branch 1.8.0, 1.8.1, 1.9.0, all
 408     -R repository       CVS for 1.8.0, 1.8.1, 1.9.0 branches,
 409                         mercurial repository name for 1.9.1 and later branches
 410                         (\`basename http://hg.mozilla.org/repository\`)
 411     -T buildtype        build type opt, debug, all
 412     -t testtype         test type browser, shell, all
 413     -o os               operating system nt, darwin, linux, all
 414     -K kernel           kernel, all or a specific pattern
 415     -A arch             architecture, all or a specific pattern
 416     -M memory           memory in Gigabytes, all or a specific pattern
 417     -z timezone         -0400, -0700, etc. default to user\'s zone
 418     -J jsoptions        JavaScript options
 419     -l rawlogfile       raw logfile
 420     -f failurelogfile   failure logfile
 421     -r patterns         known failure patterns
 422     -O outputprefix     output files will be generated with this prefix
 423     -D                  turn on debugging output
 424 EOF
 425
 426     exit(2);
 427 }
 428
 429 sub parse_options {
 430     my ($option, $value);
 431
 432     Getopt::Mixed::init ($option_desc);
 433     $Getopt::Mixed::order = $Getopt::Mixed::RETURN_IN_ORDER;
 434
 435     while (($option, $value) = nextOption()) {
 436
 437         if ($option eq "b") {
 438             $branch = $value;
 439         }
 440         elsif ($option eq "R") {
 441             $repo = $value;
 442         }
 443         elsif ($option eq "T") {
 444             $buildtype = $value;
 445         }
 446         elsif ($option eq "t") {
 447             $testtype = $value;
 448         }
 449         elsif ($option eq "o") {
 450             $os = $value;
 451         }
 452         elsif ($option eq "K") {
 453             $kernel = $value;
 454         }
 455         elsif ($option eq "A") {
 456             $arch = $value;
 457         }
 458         elsif ($option eq "M") {
 459             $memory = $value;
 460         }
 461         elsif ($option eq "z") {
 462             $timezone = $value;
 463         }
 464         elsif ($option eq "J") {
 465             my (@s, $j);
 466
 467             if (! $value) {
 468                 $jsoptions = 'none';
 469             }
 470             else {
 471                 $value =~ s/(-\w) (\w)/$1$2/g;
 472                 @s = sort split / /, $value;
 473                 $j = join(" ", @s);
 474                 $j =~ s/(-\w)(\w)/$1 $2/g;
 475                 $jsoptions = $j;
 476             }
 477         }
 478         elsif ($option eq "r") {
 479             $patterns = $value;
 480         }
 481         elsif ($option eq "l") {
 482             $rawlogfile = $value;
 483         }
 484         elsif ($option eq "f") {
 485             $failurelogfile = $value;
 486         }
 487         elsif ($option eq "O") {
 488             $outputprefix = $value;
 489         }
 490         elsif ($option eq "D") {
 491             $debug = 1;
 492         }
 493
 494     }
 495
 496     if ($debug) {
 497         print "branch=$branch, buildtype=$buildtype, testtype=$testtype, os=$os, kernel=$kernel, arch=$arch, memory=$memory, timezone=$timezone, jsoptions=$jsoptions, patterns=$patterns, rawlogfile=$rawlogfile failurelogfile=$failurelogfile, outputprefix=$outputprefix\n";
 498     }
 499     Getopt::Mixed::cleanup();
 500
 501     if ( !defined($branch) ) {
 502         usage "missing branch";
 503     }
 504
 505     if (!defined($buildtype)) {
 506         usage "missing buildtype";
 507     }
 508
 509     if (!defined($testtype)) {
 510         usage "missing testtype";
 511     }
 512
 513     if (!defined($os)) {
 514         usage "missing os";
 515     }
 516
 517     if (!defined($memory)) {
 518         $memory = 'all';
 519     }
 520
 521     if (!defined($timezone)) {
 522         usage "missing timezone";
 523     }
 524
 525     if (!defined($jsoptions)) {
 526         $jsoptions = 'none';
 527     }
 528
 529     if (!defined($patterns)) {
 530         usage "missing patterns";
 531     }
 532
 533     if (!defined($rawlogfile) && !defined($failurelogfile)) {
 534         usage "missing logfile";
 535     }
 536
 537     if (!defined($outputprefix)) {
 538         usage "missing outputprefix";
 539     }
 540
 541     if ($branch eq "all") {
 542         $knownfailurebranchpattern = "[^,]*";
 543         $failurebranchpattern      = "[^,]*";
 544     }
 545     else {
 546         $knownfailurebranchpattern = "($branch|.*)";
 547         $knownfailurebranchpattern =~ s/\./\\./g;
 548
 549         $failurebranchpattern = "$branch";
 550         $failurebranchpattern =~ s/\./\\./g;
 551     }
 552
 553     if ($repo eq "all" || $repo eq ".*") {
 554         $knownfailurerepopattern = "[^,]*";
 555         $failurerepopattern      = "[^,]*";
 556     }
 557     else {
 558         $knownfailurerepopattern = "($repo|\\.\\*)";
 559         $failurerepopattern      = "$repo";
 560     }
 561
 562     if ($buildtype eq "opt") {
 563         $knownfailurebuildtypepattern = "(opt|\\.\\*)";
 564         $failurebuildtypepattern      = "opt";
 565     }
 566     elsif ($buildtype eq "debug") {
 567         $knownfailurebuildtypepattern = "(debug|\\.\\*)";
 568         $failurebuildtypepattern      = "debug";
 569     }
 570     elsif ($buildtype eq "all") {
 571         $knownfailurebuildtypepattern = "[^,]*";
 572         $failurebuildtypepattern      = "[^,]*";
 573     }
 574
 575     if ($testtype eq "shell") {
 576         $knownfailuretesttypepattern = "(shell|\\.\\*)";
 577         $failuretesttypepattern      = "shell";
 578     }
 579     elsif ($testtype eq "browser") {
 580         $knownfailuretesttypepattern = "(browser|\\.\\*)";
 581         $failuretesttypepattern      = "browser";
 582     }
 583     elsif ($testtype eq "all") {
 584         $knownfailuretesttypepattern = "[^,]*";
 585         $failuretesttypepattern      = "[^,]*";
 586     }
 587
 588     if ($os eq "nt") {
 589         $knownfailureospattern     = "(nt|\\.\\*)";
 590         $failureospattern          = "nt";
 591     }
 592     elsif ($os eq "darwin") {
 593         $knownfailureospattern     = "(darwin|\\.\\*)";
 594         $failureospattern          = "darwin";
 595     }
 596     elsif ($os eq "linux") {
 597         $knownfailureospattern     = "(linux|\\.\\*)";
 598         $failureospattern          = "linux";
 599     }
 600     elsif ($os eq "all") {
 601         $knownfailureospattern     = "[^,]*";
 602         $failureospattern          = "[^,]*";
 603     }
 604
 605     if ($kernel ne  "all") {
 606         $knownfailurekernelpattern = "(" . $kernel . "|\\.\\*)";
 607         $failurekernelpattern      = "$kernel";
 608     }
 609     else {
 610         $knownfailurekernelpattern = "[^,]*";
 611         $failurekernelpattern      = "[^,]*";
 612     }
 613
 614     if ($arch ne "all") {
 615         $knownfailurearchpattern = "(" . $arch . "|\\.\\*)";
 616         $failurearchpattern      = "$arch";
 617     }
 618     else {
 619         $knownfailurearchpattern = "[^,]*";
 620         $failurearchpattern      = "[^,]*";
 621     }
 622
 623     if ($memory ne  "all") {
 624         $knownfailurememorypattern = "(" . $memory . "|\\.\\*)";
 625         $failurememorypattern      = "$memory";
 626     }
 627     else {
 628         $knownfailurememorypattern = "[^,]*";
 629         $failurememorypattern      = "[^,]*";
 630     }
 631
 632     if ($timezone eq "all") {
 633         $knownfailuretimezonepattern = "[^,]*";
 634         $failuretimezonepattern      = "[^,]*";
 635     }
 636     else {
 637         $knownfailuretimezonepattern = "(" . escape_string($timezone) . "|\\.\\*)";
 638         $failuretimezonepattern      = escape_string("$timezone");
 639     }
 640
 641     if ($jsoptions eq "all") {
 642         $knownfailurejsoptionspattern = "[^,]*";
 643         $failurejsoptionspattern      = "[^,]*";
 644     }
 645     else {
 646         $knownfailurejsoptionspattern = "(" . escape_string($jsoptions) . "|\\.\\*)";
 647         $failurejsoptionspattern      = escape_string("$jsoptions");
 648     }
 649
 650 }
 651
 652 sub escape_string {
 653     my $s = shift;
 654
 655     # replace unescaped regular expression characters in the
 656     # string so they are not interpreted as regexp chars
 657     # when matching descriptions. leave the escaped regexp chars
 658     # `regexp` alone so they can be unescaped later and used in
 659     # pattern matching.
 660
 661     # see perldoc perlre
 662
 663     $s =~ s/\\/\\\\/g;
 664
 665     # escape non word chars that aren't surrounded by ``
 666     $s =~ s/(?<!`)([$regchars])(?!`)/\\$1/g;
 667     $s =~ s/(?<!`)([$regchars])(?=`)/\\$1/g;
 668     $s =~ s/(?<=`)([$regchars])(?!`)/\\$1/g;
 669
 670     # unquote the regchars
 671     $s =~ s/\`([^\`])\`/$1/g;
 672
 673     debug "escape_string  : $s";
 674
 675     return "$s";
 676
 677 }
 678
 679 sub escape_pattern {
 680
 681     my $line = shift;
 682
 683     chomp;
 684
 685     my ($leading, $trailing) = $line =~ /(.*TEST_DESCRIPTION=)(.*)/;
 686
 687     #    debug "escape_pattern: before: $leading$trailing";
 688
 689     $trailing = escape_string($trailing);
 690
 691     debug "escape_pattern  : $leading$trailing";
 692
 693     return "$leading$trailing";
 694
 695 }
 696
 697 sub unescape_pattern {
 698     my $line = shift;
 699
 700     chomp;
 701
 702     my ($leading, $trailing) = $line =~ /(.*TEST_DESCRIPTION=)(.*)/;
 703
 704     # quote the unescaped non word chars
 705     $trailing =~ s/(?<!\\)([$regchars])/`$1`/g;
 706
 707     # unescape the escaped non word chars
 708     $trailing =~ s/\\([$regchars])/$1/g;
 709
 710     $trailing =~ s/\\\\/\\/g;
 711
 712     debug "unescape_pattern: after: $leading$trailing";
 713
 714     return "$leading$trailing";
 715 }
 716
 717 ####
 718
 719
 720 1;