[ tor-browser ].git.dasho

make_tests.pl (14174B)
      1 #!/usr/bin/perl
      2 #
      3 #  make_tests.pl - generate WPT test cases from the testable statements wiki
      4 #
      5 #  This script assumes that a wiki has testable statement entries
      6 #  in the format described by the specification at
      7 #  https://spec-ops.github.io/atta-api/index.html
      8 #
      9 #  usage: make_tests.pl -f file | -w wiki_title | -s spec -d dir
     10 
     11 use strict;
     12 
     13 use IO::String ;
     14 use JSON ;
     15 use MediaWiki::API ;
     16 use Getopt::Long;
     17 
     18 my %specs = (
     19    "aria11" => {
     20      title => "ARIA_1.1_Testable_Statements",
     21      specURL => "https://www.w3.org/TR/wai-aria11/",
     22      dir => "aria11"
     23    },
     24    "svg" => {
     25      title => "SVG_Accessibility/Testing/Test_Assertions_with_Tables_for_ATTA",
     26      specURL => "https://www.w3.org/TR/svg-aam-1.0/",
     27      dir => "svg",
     28      fragment => '<svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">%code%</svg>'
     29    }
     30 );
     31 
     32 my @apiNames = qw(UIA MSAA ATK IAccessible2 AXAPI);
     33 my $apiNamesRegex = "(" . join("|", @apiNames) . ")";
     34 
     35 # the suffix to attach to the automatically generated test case names
     36 my $theSuffix = "-manual.html";
     37 
     38 # dir is determined based upon the short name of the spec and is defined
     39 # by the input or on the command line
     40 
     41 my $file = undef ;
     42 my $spec = undef ;
     43 my $wiki_title = undef ;
     44 my $dir = undef;
     45 my $theSpecFragment = "%code%";
     46 my $preserveWiki = "";
     47 my $fake = 0;
     48 
     49 my $result = GetOptions(
     50    "f|file=s"   => \$file,
     51    "p=s" => \$preserveWiki,
     52    "w|wiki=s"   => \$wiki_title,
     53    "s|spec=s"   => \$spec,
     54    "f|fake"    => \$fake,
     55    "d|dir=s"   => \$dir) || usage();
     56 
     57 my $wiki_config = {
     58  "api_url" => "https://www.w3.org/wiki/api.php"
     59 };
     60 
     61 my $io ;
     62 our $theSpecURL = "";
     63 
     64 if ($spec) {
     65  print "Processing spec $spec\n";
     66  $wiki_title = $specs{$spec}->{title};
     67  $theSpecURL = $specs{$spec}->{specURL};
     68  if (!$dir) {
     69    $dir = "../" . $specs{$spec}->{dir};
     70  }
     71  $theSpecFragment = $specs{$spec}->{fragment};
     72 }
     73 
     74 if (!$dir) {
     75  $dir = "../raw";
     76 }
     77 
     78 if (!-d $dir) {
     79  print STDERR "No such directory: $dir\n";
     80  exit 1;
     81 }
     82 
     83 if ($file) {
     84  open($io, "<", $file) || die("Failed to open $file: " . $@);
     85 } elsif ($wiki_title) {
     86  my $MW = MediaWiki::API->new( $wiki_config );
     87 
     88  $MW->{config}->{on_error} = \&on_error;
     89 
     90  sub on_error {
     91    print "Error code: " . $MW->{error}->{code} . "\n";
     92    print $MW->{error}->{stacktrace}."\n";
     93    die;
     94  }
     95  my $page = $MW->get_page( { title => $wiki_title } );
     96  my $theContent = $page->{'*'};
     97  print "Loaded " . length($theContent) . " from $wiki_title\n";
     98  if ($preserveWiki) {
     99    if (open(OUTPUT, ">$preserveWiki")) {
    100      print OUTPUT $theContent;
    101      close OUTPUT;
    102      print "Wiki preserved in $preserveWiki\n";
    103      exit 0;
    104    } else {
    105      print "Failed to create $preserveWiki. Terminating.\n";
    106      exit 1;
    107    }
    108  }
    109  $io = IO::String->new($theContent);
    110 } else {
    111  usage() ;
    112 }
    113 
    114 
    115 
    116 # Now let's walk through the content and build a test page for every item
    117 #
    118 
    119 # iterate over the content
    120 
    121 # my $io ;
    122 # open($io, "<", "raw") ;
    123 
    124 # data structure:
    125 #
    126 # steps is a list of steps to be performed.
    127 # Each step is an object that has a type property and other properties based upon that type.
    128 #
    129 # Types include:
    130 #
    131 # 'test' - has a property for each ATAPI for which there are tests
    132 # 'attribute' - has a property for the target id, attribute name, and value
    133 # 'event' - has a property for the target id and event name
    134 my $state = 0;   # between items
    135 my $theStep = undef;
    136 my $current = "";
    137 my $theCode = "";
    138 my $theAttributes = {};
    139 my @steps ;
    140 my $theAsserts = {} ;
    141 my $theAssertCount = 0;
    142 my $theAPI = "";
    143 my $typeRows = 0;
    144 my $theType = "";
    145 my $theName = "";
    146 my $theRef = "";
    147 my $lineCounter = 0;
    148 my $skipping = 0;
    149 
    150 our $testNames = {} ;
    151 
    152 while (<$io>) {
    153  if (m/<!-- END OF TESTS -->/) {
    154    last;
    155  }
    156  $lineCounter++;
    157  # look for state
    158  if (m/^SpecURL: (.*)$/) {
    159    $theSpecURL = $1;
    160    $theSpecURL =~ s/^ *//;
    161    $theSpecURL =~ s/ *$//;
    162  }
    163  if ($state == 5 && m/^; \/\/ (.*)/) {
    164    # we found another test inside a block
    165    # we were in an item; dump it
    166    build_test($current, $theAttributes, $theCode, \@steps, $theSpecFragment) ;
    167    # print "Finished $current and new subblock $1\n";
    168    $state = 1;
    169    $theAttributes = {} ;
    170    $theAPI = "";
    171    @steps = ();
    172    $theCode = "";
    173    $theAsserts = undef;
    174    $theName = "";
    175  } elsif (m/^=== +(.*[^ ]) +===/) {
    176    if ($state != 0) {
    177      if ($skipping) {
    178        print STDERR "Flag on assertion $current; skipping\n";
    179      } else {
    180        # we were in an item; dump it
    181        build_test($current, $theAttributes, $theCode, \@steps, $theSpecFragment) ;
    182        # print "Finished $current\n";
    183      }
    184    }
    185    $state = 1;
    186    $current = $1;
    187    $theAttributes = {} ;
    188    @steps = ();
    189    $theCode = "";
    190    $theAsserts = undef;
    191    $theAPI = "";
    192    $theName = "";
    193    if ($current =~ m/\(/) {
    194      # there is a paren in the name -skip it
    195      $skipping = 1;
    196    } else {
    197      $skipping = 0;
    198    }
    199  }
    200 
    201  if ($state == 1) {
    202    if (m/<pre>/) {
    203      # we are now in the code block
    204      $state = 2;
    205      next;
    206    } elsif (m/==== +(.*) +====/) {
    207      # we are in some other block
    208      $theName = lc($1);
    209      $theAttributes->{$theName} = "";
    210      next;
    211    }
    212    if (m/^Reference: +(.*)$/) {
    213      $theAttributes->{reference} = $theSpecURL . "#" . $1;
    214    } elsif ($theName ne "") {
    215      # accumulate whatever was in the block under the data for it
    216      chomp();
    217      $theAttributes->{$theName} .= $_;
    218    } elsif (m/TODO/) {
    219      $state = 0;
    220    }
    221  }
    222 
    223  if ($state == 2) {
    224    if (m/<\/pre>/) {
    225      # we are done with the code block
    226      $state = 3;
    227    } else  {
    228      if (m/^\s/ && !m/if given/) {
    229        # trim any trailing whitespace
    230        $theCode =~ s/ +$//;
    231        $theCode =~ s/\t/ /g;
    232        $theCode .= $_;
    233        # In MediaWiki, to display & symbol escapes as literal text, one
    234        # must use "&amp;&" for the "&" character. We need to undo that.
    235        $theCode =~ s/&amp;(\S)/&$1/g;
    236      }
    237    }
    238  } elsif ($state == 3) {
    239    # look for a table
    240    if (m/^\{\|/) {
    241      # table started
    242      $state = 4;
    243    }
    244  } elsif ($state == 4) {
    245    if (m/^\|-/) {
    246      if ($theAPI
    247        && exists($theAsserts->{$theAPI}->[$theAssertCount])
    248        && scalar(@{$theAsserts->{$theAPI}->[$theAssertCount]})) {
    249        $theAssertCount++;
    250      }
    251      # start of a table row
    252      if ($theType ne "" && $typeRows) {
    253        # print qq($theType typeRows was $typeRows\n);
    254        # we are still processing items for a type
    255        $typeRows--;
    256        # populate the first cell
    257        $theAsserts->{$theAPI}->[$theAssertCount] = [ $theType ] ;
    258      } else {
    259        $theType = "";
    260      }
    261    } elsif (m/^\|\}/) {
    262      # ran out of table
    263      $state = 5;
    264    # adding processing for additional block types
    265    # a colspan followed by a keyword triggers a start
    266    # so |colspan=5|element triggers a new collection
    267    # |colspan=5|attribute triggers the setting of an attribute
    268    } elsif (m/^\|colspan="*([0-9])"*\|([^ ]+) (.*)$/) {
    269      my $type = $2;
    270      my $params = $3;
    271 
    272      my $obj = {} ;
    273      if ($type eq "attribute") {
    274        if ($params =~ m/([^:]+):([^ ]+) +(.*)$/) {
    275          $obj = {
    276            type => $type,
    277            element => $1,
    278            attribute => $2,
    279            value => $3
    280          };
    281          $theStep = undef;
    282          push(@steps, $obj);
    283        } else {
    284          print STDERR "Malformed attribute instruction at line $lineCounter: " . $_ . "\n";
    285        }
    286      } elsif ($type eq "event") {
    287        if ($params =~ m/([^:]+):([^ ]+).*$/) {
    288          $obj = {
    289            type => $type,
    290            element => $1,
    291            value => $2
    292          };
    293          $theStep = undef;
    294          push(@steps, $obj);
    295        } else {
    296          print STDERR "Malformed event instruction at line $lineCounter: " . $_ . "\n";
    297        }
    298      } elsif ($type eq "element") {
    299        $obj = {
    300          type => "test",
    301          element => $3
    302        };
    303        push(@steps, $obj);
    304        $theStep = scalar(@steps) - 1;
    305        $theAsserts = $steps[$theStep];
    306      } else {
    307        print STDERR "Unknown operation type: $type at line " . $lineCounter . "; skipping.\n";
    308      }
    309    } elsif (m/($apiNamesRegex)$/) {
    310      my $theString = $1;
    311      $theString =~ s/ +$//;
    312      $theString =~ s/^ +//;
    313      if ($theString eq "IA2") {
    314        $theString = "IAccessible2" ;
    315      }
    316      my $rows = 1;
    317      if (m/^\|rowspan="*([0-9])"*\|(.*)$/) {
    318        $rows = $1
    319      }
    320      if (grep { $_ eq $theString } @apiNames) {
    321        # we found an API name - were we already processing assertions?
    322        if (!$theAsserts) {
    323          # nope - now what?
    324          $theAsserts = {
    325            type => "test",
    326            element => "test"
    327          };
    328          push(@steps, $theAsserts);
    329        }
    330        $theAssertCount = 0;
    331        # this is a new API section
    332        $theAPI = $theString ;
    333        $theAsserts->{$theAPI} = [ [] ] ;
    334        $theType = "";
    335      } else {
    336        # this is a multi-row type
    337        $theType = $theString;
    338        $typeRows = $rows;
    339        # print qq(Found multi-row $theString for $theAPI with $typeRows rows\n);
    340        $typeRows--;
    341        # populate the first cell
    342        if ($theAPI
    343          && exists($theAsserts->{$theAPI}->[$theAssertCount])
    344          && scalar(@{$theAsserts->{$theAPI}->[$theAssertCount]})) {
    345          $theAssertCount++;
    346        }
    347        $theAsserts->{$theAPI}->[$theAssertCount] = [ $theType ] ;
    348      }
    349    } elsif (m/^\|(.*)$/) {
    350      my $item = $1;
    351      $item =~ s/^ *//;
    352      $item =~ s/ *$//;
    353      $item =~ s/^['"]//;
    354      $item =~ s/['"]$//;
    355      # add into the data structure for the API
    356      if (!exists $theAsserts->{$theAPI}->[$theAssertCount]) {
    357        $theAsserts->{$theAPI}->[$theAssertCount] = [ $item ] ;
    358      } else {
    359        push(@{$theAsserts->{$theAPI}->[$theAssertCount]}, $item);
    360      }
    361    }
    362  }
    363 };
    364 
    365 if ($state != 0) {
    366  build_test($current, $theAttributes, $theCode, \@steps, $theSpecFragment) ;
    367  print "Finished $current\n";
    368 }
    369 
    370 exit 0;
    371 
    372 # build_test
    373 #
    374 # create a test file
    375 #
    376 # attempts to create unique test names
    377 
    378 sub build_test() {
    379  my $title = shift ;
    380  my $attrs = shift ;
    381  my $code = shift ;
    382  my $steps = shift;
    383  my $frag = shift ;
    384 
    385  if ($title eq "") {
    386    print STDERR "No name provided!";
    387    return;
    388  }
    389 
    390  if ($frag ne "") {
    391    $frag =~ s/%code%/$code/;
    392    $code = $frag;
    393  }
    394 
    395  $code =~ s/ +$//m;
    396  $code =~ s/\t/ /g;
    397 
    398  my $title_reference = $title;
    399 
    400  if ($code eq "") {
    401    print STDERR "No code for $title; skipping.\n";
    402    return;
    403  }
    404  if ( $steps eq {}) {
    405    print STDERR "No assertions for $title; skipping.\n";
    406    return;
    407  }
    408 
    409  my $testDef =
    410  { "title" => $title,
    411    "steps" => []
    412  };
    413  my $stepCount = 0;
    414  foreach my $asserts (@$steps) {
    415    $stepCount++;
    416    my $step =
    417      {
    418        "type" => $asserts->{"type"},
    419        "title"=> "step " . $stepCount,
    420      };
    421 
    422    if ($asserts->{type} eq "test") {
    423      # everything in the block is about testing an element
    424      $step->{"element"} = ( $asserts->{"element"} || "test" );
    425 
    426      my $tests = {};
    427      if ($fake) {
    428        $tests->{"WAIFAKE"} = [ [ "property", "role", "is", "ROLE_TABLE_CELL" ], [ "property", "interfaces", "contains", "TableCell" ] ];
    429      }
    430      foreach my $name (@apiNames) {
    431        if (exists $asserts->{$name} && scalar(@{$asserts->{$name}})) {
    432          $tests->{$name} = $asserts->{$name};
    433        }
    434      };
    435 
    436      $step->{test} = $tests;
    437 
    438    } elsif ($asserts->{type} eq "attribute") {
    439      $step->{type} = "attribute";
    440      $step->{element} = $asserts->{"element"};
    441      $step->{attribute} = $asserts->{"attribute"};
    442      $step->{value} = $asserts->{value};
    443    } elsif ($asserts->{type} eq "event") {
    444      $step->{type} = "event";
    445      $step->{element} = $asserts->{"element"};
    446      $step->{event} = $asserts->{value};
    447    } else {
    448      print STDERR "Invalid step type: " . $asserts->{type} . "\n";
    449      next;
    450    }
    451    push(@{$testDef->{steps}}, $step);
    452  }
    453 
    454 
    455  # populate the rest of the test definition
    456 
    457  if (scalar(keys(%$attrs))) {
    458    while (my $key = each(%$attrs)) {
    459      # print "Copying $key \n";
    460      $testDef->{$key} = $attrs->{$key};
    461    }
    462  }
    463 
    464  if (exists $attrs->{reference}) {
    465    $title_reference = "<a href='" . $attrs->{reference} . "'>" . $title_reference . "</a>" ;
    466  }
    467 
    468  my $testDef_json = to_json($testDef, { canonical => 1, pretty => 1, utf8 => 1});
    469 
    470  my $fileName = $title;
    471  $fileName =~ s/\s*$//;
    472  $fileName =~ s/\///g;
    473  $fileName =~ s/\s+/_/g;
    474  $fileName =~ s/[,=:]/_/g;
    475  $fileName =~ s/['"]//g;
    476 
    477  my $count = 2;
    478  if ($testNames->{$fileName}) {
    479    while (exists $testNames->{$fileName . "_$count"}) {
    480      $count++;
    481    }
    482    $fileName .= "_$count";
    483  }
    484 
    485  $fileName = lc($fileName);
    486 
    487  $testNames->{$fileName} = 1;
    488 
    489  $fileName .= $theSuffix;
    490 
    491  my $template = qq(<!doctype html>
    492 <html>
    493  <head>
    494    <title>$title</title>
    495    <meta content="text/html; charset=utf-8" http-equiv="Content-Type"/>
    496    <link rel="stylesheet" href="/wai-aria/scripts/manual.css">
    497    <script src="/resources/testharness.js"></script>
    498    <script src="/resources/testharnessreport.js"></script>
    499    <script src="/wai-aria/scripts/ATTAcomm.js"></script>
    500    <script>
    501    setup({explicit_timeout: true, explicit_done: true });
    502 
    503    var theTest = new ATTAcomm(
    504    $testDef_json
    505    ) ;
    506    </script>
    507  </head>
    508  <body>
    509  <p>This test examines the ARIA properties for $title_reference.</p>
    510  $code
    511  <div id="manualMode"></div>
    512  <div id="log"></div>
    513  <div id="ATTAmessages"></div>
    514  </body>
    515 </html>);
    516 
    517  my $file ;
    518 
    519  if (open($file, ">", "$dir/$fileName")) {
    520    print $file $template;
    521    print $file "\n";
    522    close $file;
    523  } else {
    524    print STDERR qq(Failed to create file "$dir/$fileName" $!\n);
    525  }
    526 
    527  return;
    528 }
    529 
    530 sub usage() {
    531  print STDERR q(usage: make_tests.pl -f file | -w wiki_title | -s spec [-n -v -d dir ]
    532 
    533  -s specname   - the name of a spec known to the system
    534  -w wiki_title - the TITLE of a wiki page with testable statements
    535  -f file       - the file from which to read
    536 
    537  -n            - do nothing
    538  -v            - be verbose
    539  -d dir        - put generated tests in directory dir
    540  );
    541  exit 1;
    542 }
    543 
    544 # vim: ts=2 sw=2 ai:
	tor-browser The Tor Browser
	git clone https://git.dasho.dev/tor-browser.git
	Log \| Files \| Refs \| README \| LICENSE