diff options
author | Daniel Baumann <daniel.baumann@progress-linux.org> | 2024-04-07 09:22:09 +0000 |
---|---|---|
committer | Daniel Baumann <daniel.baumann@progress-linux.org> | 2024-04-07 09:22:09 +0000 |
commit | 43a97878ce14b72f0981164f87f2e35e14151312 (patch) | |
tree | 620249daf56c0258faa40cbdcf9cfba06de2a846 /testing/web-platform/tests/wai-aria/tools | |
parent | Initial commit. (diff) | |
download | firefox-43a97878ce14b72f0981164f87f2e35e14151312.tar.xz firefox-43a97878ce14b72f0981164f87f2e35e14151312.zip |
Adding upstream version 110.0.1.upstream/110.0.1upstream
Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>
Diffstat (limited to 'testing/web-platform/tests/wai-aria/tools')
-rw-r--r-- | testing/web-platform/tests/wai-aria/tools/convert_wiki.pl | 648 | ||||
-rw-r--r-- | testing/web-platform/tests/wai-aria/tools/make_tests.pl | 544 |
2 files changed, 1192 insertions, 0 deletions
diff --git a/testing/web-platform/tests/wai-aria/tools/convert_wiki.pl b/testing/web-platform/tests/wai-aria/tools/convert_wiki.pl new file mode 100644 index 0000000000..d3415f2653 --- /dev/null +++ b/testing/web-platform/tests/wai-aria/tools/convert_wiki.pl @@ -0,0 +1,648 @@ +#!/usr/bin/perl +# +# convert_wiki.pl - Transform an old-style wiki into the new format +# +# This script assumes that a wiki has testable statement entries +# with varying lemgth lines. Those lines will be converted into +# the format described by the specification at +# https://spec-ops.github.io/atta-api/index.html +# +# usage: convert_wiki.pl -f file | -w wiki_title -o outFile + +use strict; + +use IO::String ; +use JSON ; +use MediaWiki::API ; +use Getopt::Long; + +my @apiNames = qw(UIA MSAA ATK IAccessible2 AXAPI); + +# dir is determined based upon the short name of the spec and is defined +# by the input or on the command line + +my $file = undef ; +my $spec = undef ; +my $wiki_title = undef ; +my $dir = undef; +my $outFile = undef; + +my $result = GetOptions( + "f|file=s" => \$file, + "w|wiki=s" => \$wiki_title, + "s|spec=s" => \$spec, + "o|output=s" => \$outFile); + +my $wiki_config = { + "api_url" => "https://www.w3.org/wiki/api.php" +}; + +my %specs = ( + "aria11" => { + title => "ARIA_1.1_Testable_Statements", + specURL => "https://www.w3.org/TR/wai-aria11" + }, + "svg" => { + title => "SVG_Accessibility/Testing/Test_Assertions_with_Tables_for_ATTA", + specURL => "https://www.w3.org/TR/svg-aam-1.0/" + } +); + +my $io ; +our $theSpecURL = ""; + +if ($spec) { + $wiki_title = $specs{$spec}->{title}; + $theSpecURL = $specs{$spec}->{specURL}; +} + +if ($wiki_title) { + my $MW = MediaWiki::API->new( $wiki_config ); + my $page = $MW->get_page( { title => $wiki_title } ); + my $theContent = $page->{'*'}; + $io = IO::String->new($theContent); +} elsif ($file) { + open($io, "<", $file) || die("Failed to open $file: " . $@); +} else { + usage() ; +} + +my $outH ; +if (defined $outFile) { + open($outH, ">", $outFile) || die("Failed to create file $outFile: $@"); +} else { + $outH = new IO::Handle; + $outH->fdopen(fileno(STDOUT), "w"); +} + + +# Now let's walk through the content and spit it back out +# transformed +# + +# iterate over the content + +# my $io ; +# open($io, "<", "raw") ; + +my $state = 0; # between items +my $theCode = ""; +my $theAttributes = {}; +my $theAsserts = {} ; +my $theAssertCount = 0; +my $theAPI = ""; +my $typeRows = 0; +my $theType = ""; +my $theName = ""; +my $theRef = ""; + +my $before = "" ; +my $after = "" ; + +my @errors = () ; +my $linecount = 0; + +while (<$io>) { + $linecount++; + # look for state + if ($state == 0) { + if (scalar(keys(%$theAsserts))) { + # we were in an item; dump it + print $outH dump_table($theAsserts) ; + $theAsserts = {}; + } + print $outH $_; + } + if (m/^\{\|/) { + # table started + $state = 4; + $theAPI = ""; + } + if ($state == 4) { + if (m/^\|-/) { + if ($theAPI + && exists($theAsserts->{$theAPI}->[$theAssertCount]) + && scalar(@{$theAsserts->{$theAPI}->[$theAssertCount]})) { + $theAssertCount++; + } + # start of a table row + if ($theType ne "" && $typeRows) { + # we are still processing items for a type + $typeRows--; + # populate the first cell + $theAsserts->{$theAPI}->[$theAssertCount] = [ $theType ] ; + } else { + $theType = ""; + } + } elsif (m/^\|\}/) { + # ran out of table + $state = 0; + } elsif (m/^\|rowspan="*([0-9])"*\|(.*)$/) { + # someone put a rowspan in here.. is ht an API? + my $rows = $1; + my $theString = $2; + $theString =~ s/ +$//; + $theString =~ s/^ +//; + $theString = "IAccessible2" if ($theString eq "IA2") ; + if (grep { $_ eq $theString } @apiNames) { + $theAssertCount = 0; + # this is a new API section + $theAPI = $theString ; + $theAsserts->{$theAPI} = [ [] ] ; + $theType = ""; + } else { + # nope, this is a multi-row type + $theType = $theString; + $typeRows = $rows; + $typeRows--; + # populate the first cell + if ($theAPI + && exists($theAsserts->{$theAPI}->[$theAssertCount]) + && scalar(@{$theAsserts->{$theAPI}->[$theAssertCount]})) { + $theAssertCount++; + } + $theAsserts->{$theAPI}->[$theAssertCount] = [ $theType ] ; + } + } elsif (m/^\|note/) { + # there is a note in the table... throw it out + # and the next line too + my $l = <$io>; + } elsif (m/^\|(MSAA|UIA|IA2|IAccessible2|ATK|AXAPI) *$/) { + # they FORGOT a rowspan on an API. That means there is only 1 + # row + my $theString = $1; + $theString =~ s/ +$//; + $theString =~ s/^ +//; + $theString = "IAccessible2" if ($theString eq "IA2") ; + if (grep { $_ eq $theString } @apiNames) { + $theAssertCount = 0; + # this is a new API section + $theAPI = $theString ; + $theAsserts->{$theAPI} = [ [] ] ; + $theType = ""; + } else { + push(@errors, "Bad API Name at $linecount: $theString"); + } + } elsif (m/^\|(.*)$/) { + my $item = $1; + $item =~ s/^ *//; + $item =~ s/ *$//; + $item =~ s/^['"]//; + $item =~ s/['"]$//; + # add into the data structure for the API + if (!exists $theAsserts->{$theAPI}->[$theAssertCount]) { + $theAsserts->{$theAPI}->[$theAssertCount] = [ $item ] ; + } else { + push(@{$theAsserts->{$theAPI}->[$theAssertCount]}, $item); + } + } + next; + } +}; + +if ($state == 0) { + if (scalar(keys(%$theAsserts))) { + # we were in an item; dump it + print $outH dump_table($theAsserts) ; + } +} + +if (@errors) { + print "There were the following errors:\n"; + foreach my $err (@errors) { + print $err . "\n"; + } +} + +exit 0; + + +sub dump_table() { + my $asserts = shift; + + if (!scalar(keys(%$asserts)) ) { + # no actual assertions + return ""; + } + + my $output = "" ; + + my @keywords = qw(property result event); + + foreach my $API (sort(keys(%$asserts))) { + # looking at each API in turn + my $ref = $asserts->{$API}; + my $rowcount = scalar(@$ref) ; + # $output .= "|-\n|rowspan=$count|$API\n" ; + # now we are in the assertions; special case each API + my @conditions = @$ref; + for (my $i = 0; $i < scalar(@conditions); $i++) { + my (@new, @additional) ; + if ($i) { + $output .= "|-\n"; + } + if ($API eq "ATK") { + my $start = 0; + my $assert = "is"; + if ($conditions[$i]->[0] =~ m/^NOT/) { + $start = 1; + $assert = "isNot"; + } + + if ($conditions[$i]->[$start] =~ m/^ROLE_/) { + $new[0] = "property"; + $new[1] = "role"; + $new[2] = $assert; + $new[3] = $conditions[$i]->[$start]; + } elsif ($conditions[$i]->[$start] =~ m/^xml-roles/) { + $new[0] = "property"; + $new[1] = "role"; + $new[2] = $assert; + $new[3] = $conditions[$i]->[$start+1]; + } elsif ($conditions[$i]->[$start] =~ m/^description/) { + my $id = $conditions[$i]->[$start+1]; + $new[0] = "property"; + $new[1] = "description"; + $new[2] = $assert; + $new[3] = $id; + push(@{$additional[0]}, ("relation", "RELATION_DESCRIBED_BY", $assert, $id)); + push(@{$additional[1]}, ("relation", "RELATION_DESCRIPTION_FOR", $assert, "test")); + } elsif ($conditions[$i]->[$start] =~ m/not in accessibility tree/i) { + @new = qw(property accessible exists false); + } elsif ($conditions[$i]->[$start] =~ m/^RELATION/) { + $new[0] = "relation"; + $new[1] = $conditions[$i]->[$start]; + $new[2] = $assert; + $new[3] = $conditions[$i]->[$start+1]; + } elsif ($conditions[$i]->[$start] =~ m/(.*) interface/i) { + $new[0] = "property"; + $new[1] = "interfaces"; + $new[3] = $1; + if ($conditions[$i]->[$start+1] ne '<shown>' + && $conditions[$i]->[$start+1] !~ m/true/i ) { + $assert = "doesNotContain"; + } else { + $assert = "contains"; + } + $new[2] = $assert; + } elsif ($conditions[$i]->[$start] eq "object" || $conditions[$i]->[$start] eq "attribute" ) { + $new[0] = "property"; + $new[1] = "objectAttributes"; + my $val = $conditions[$i]->[2]; + $val =~ s/"//g; + $new[3] = $conditions[$i]->[1] . ":" . $val; + if ($conditions[$i]->[1] eq "not exposed" + || $conditions[$i]->[2] eq "false") { + $new[2] = "doesNotContain"; + } else { + $new[2] = "contains"; + } + } elsif ($conditions[$i]->[$start] =~ m/^STATE_/) { + $new[0] = "property"; + $new[1] = "states"; + $new[3] = $conditions[$i]->[$start]; + if ($assert eq "true") { + $new[2] = "contains"; + } else { + $new[2] = "doesNotContain"; + } + } elsif ($conditions[$i]->[$start] =~ m/^object attribute (.*)/) { + my $name = $1; + $new[0] = "property"; + $new[0] = "objectAttributes"; + my $val = $conditions[$i]->[1]; + $val =~ s/"//g; + if ($val eq "not exposed" || $val eq "not mapped") { + $new[3] = $name; + $new[2] = "doesNotContain"; + } else { + $new[3] = $name . ":" . $val; + $new[2] = "contains"; + } + } elsif ($conditions[$i]->[$start] =~ m/^name/) { + my $name = $conditions[$i]->[1]; + my $cond = "is" ; + if ($name eq "<empty>" ) { + $cond = "empty"; + $name = "true" + } elsif ($name eq "<not empty>") { + $cond = "empty"; + $name = "false"; + } + $new[0] = "property"; + $new[1] = "name"; + $new[2] = $cond; + $new[3] = $name; + } else { + @new = @{$conditions[$i]}; + if ($conditions[$i]->[2] eq '<shown>') { + $new[2] = "contains"; + } + } + $conditions[$i] = \@new; + } elsif ($API eq "UIA") { + my $start = 0; + my $assert = "is"; + if ($conditions[$i]->[$start] =~ m/\./) { + my $val = $conditions[$i]->[$start+1]; + $val =~ s/"//g; + $val =~ s/'//g; + $new[0] = "result"; + $new[1] = $conditions[$i]->[$start]; + $new[2] = $assert; + $new[3] = $conditions[$i]->[$start+1]; + } elsif ($conditions[$i]->[$start] =~ m/not in accessibility tree/i) { + @new = qw(property accessible exists false); + } elsif ($conditions[$i]->[$start] =~ m/^(AriaProperties|Toggle|ExpandCollapse)/) { + my $name = $conditions[$i]->[1]; + $new[0] = "property"; + $new[1] = $1; + my $val = $conditions[$i]->[2]; + $val =~ s/"//g; + if ($val eq "not exposed" || $val eq "not mapped") { + $new[3] = $name; + $new[2] = "doesNotContain"; + } else { + $new[3] = $name . ":" . $val; + $new[2] = "contains"; + } + } elsif ($conditions[$i]->[$start] =~ m/^LabeledBy/i) { + $new[0] = "property"; + $new[1] = $conditions[$i]->[$start]; + $new[2] = $assert; + $new[3] = $conditions[$i]->[$start+1]; + } elsif ($conditions[$i]->[$start] =~ m/^Name/) { + my $name = $conditions[$i]->[1]; + my $cond = "is" ; + if ($name eq "<empty>" ) { + $cond = "empty"; + $name = "true" + } elsif ($name eq "<not empty>") { + $cond = "empty"; + $name = "false"; + } + $new[0] = "property"; + $new[1] = "Name"; + $new[2] = $cond; + $new[3] = $name; + } elsif ($conditions[$i]->[$start] =~ m/^TBD/) { + $new[0] = "TBD"; + $new[1] = $new[2] = $new[3] = ""; + } else { + if ($conditions[$i]->[1] ne '<shown>' + && $conditions[$i]->[1] !~ m/true/i ) { + $assert = "isNot"; + } else { + $assert = "is"; + } + $new[0] = "property"; + $new[1] = $conditions[$i]->[$start]; + $new[2] = $assert; + $new[3] = $conditions[$i]->[$start+1]; + } + } elsif ($API eq "MSAA") { + my $start = 0; + my $assert = "is"; + if ($conditions[$i]->[0] =~ m/^NOT/) { + $start = 1; + $assert = "isNot"; + } + + if ($conditions[$i]->[$start] =~ m/^role/) { + $new[0] = "property"; + $new[1] = "role"; + $new[2] = $assert; + $new[3] = $conditions[$i]->[$start+1]; + } elsif ($conditions[$i]->[$start] =~ m/^xml-roles/) { + $new[0] = "property"; + $new[1] = "role"; + $new[2] = $assert; + $new[3] = $conditions[$i]->[$start+1]; + } elsif ($conditions[$i]->[$start] =~ m/not in accessibility tree/i) { + @new = qw(property accessible exists false); + } elsif ($conditions[$i]->[$start] =~ m/^(accName|accDescription)/) { + my $name = $conditions[$i]->[$start+1]; + my $cond = "is" ; + if ($name eq "<empty>" ) { + $cond = "empty"; + $name = "true" + } elsif ($name eq "<not empty>") { + $cond = "empty"; + $name = "false"; + } + $new[0] = "property"; + $new[1] = $conditions[$i]->[$start]; + $new[2] = $cond; + $new[3] = $name; + } elsif ($conditions[$i]->[$start] =~ m/^ROLE_/) { + $new[0] = "property"; + $new[1] = "role"; + $new[2] = $assert; + $new[3] = $conditions[$i]->[$start]; + } elsif ($conditions[$i]->[$start] =~ m/^(STATE_.*) *([^ ]*)/) { + $new[0] = "property"; + $new[1] = "states"; + $new[3] = $1; + if ($2 && $2 eq "cleared") { + print "MATCHED $1, $2\n"; + $new[2] = "doesNotContain"; + } else { + $new[2] = "contains"; + } + } elsif ($conditions[$i]->[$start] =~ m/^TBD/) { + $new[0] = "TBD"; + $new[1] = $new[2] = $new[3] = ""; + } + } elsif ($API eq "IAccessible2") { + my $start = 0; + my $assert = "is"; + if ($conditions[$i]->[0] =~ m/^NOT/) { + $start = 1; + $assert = "isNot"; + } + if ($conditions[$i]->[$start] =~ m/^IA2_ROLE_/) { + $new[0] = "property"; + $new[1] = "role"; + $new[2] = $assert; + $new[3] = $conditions[$i]->[$start]; + } elsif ($conditions[$i]->[$start] =~ m/not in accessibility tree/i) { + @new = qw(property accessible exists false); + } elsif ($conditions[$i]->[$start] =~ m/^IA2_RELATION_/) { + $new[0] = "relation"; + $new[1] = $conditions[$i]->[$start]; + $new[2] = $assert; + $new[3] = $conditions[$i]->[$start+1]; + } elsif ($conditions[$i]->[$start] =~ m/^IA2_STATE_/) { + $new[0] = "property"; + $new[1] = "states"; + $new[3] = $conditions[$i]->[$start]; + if ($assert eq "true") { + $new[2] = "contains"; + } else { + $new[2] = "doesNotContain"; + } + } elsif ($conditions[$i]->[$start] =~ m/^IA2_/) { + $new[0] = "property"; + $new[1] = "states"; + $new[3] = $conditions[$i]->[$start]; + if ($assert eq "true") { + $new[2] = "contains"; + } else { + $new[2] = "doesNotContain"; + } + } elsif ($conditions[$i]->[$start] =~ m/(IAccessibleTable2)/i) { + $new[0] = "property"; + $new[1] = "interfaces"; + $new[3] = $1; + if ($conditions[$i]->[$start+1] ne '<shown>' + && $conditions[$i]->[$start+1] !~ m/true/i ) { + $assert = "doesNotContain"; + } else { + $assert = "contains"; + } + $new[2] = $assert; + } elsif ($conditions[$i]->[$start] =~ m/(.*) interface/i) { + $new[0] = "property"; + $new[1] = "interfaces"; + $new[3] = $1; + if ($conditions[$i]->[$start+1] ne '<shown>' + && $conditions[$i]->[$start+1] !~ m/true/i ) { + $assert = "doesNotContain"; + } else { + $assert = "contains"; + } + $new[2] = $assert; + } elsif ($conditions[$i]->[$start] =~ m/(.*)\(\)/) { + $new[0] = "result"; + $new[1] = $conditions[$i]->[$start]; + my $val = $conditions[$i]->[2]; + $val =~ s/"//g; + $new[3] = $conditions[$i]->[1] . ":" . $val; + if ($conditions[$i]->[1] eq "not exposed" + || $conditions[$i]->[2] eq "false") { + $new[2] = "doesNotContain"; + } else { + $new[2] = "contains"; + } + } elsif ($conditions[$i]->[$start] =~ m/(.*localizedExtendedRole)/) { + $new[0] = "result"; + $new[1] = $conditions[$i]->[$start]; + my $val = $conditions[$i]->[2]; + $val =~ s/"//g; + $new[3] = $conditions[$i]->[1] . ":" . $val; + if ($conditions[$i]->[1] eq "not exposed" + || $conditions[$i]->[2] eq "false") { + $new[2] = "doesNotContain"; + } else { + $new[2] = "contains"; + } + } elsif ($conditions[$i]->[$start] eq "object" || $conditions[$i]->[$start] eq "attribute" ) { + $new[0] = "property"; + $new[1] = "objectAttributes"; + my $val = $conditions[$i]->[2]; + $val =~ s/"//g; + $new[3] = $conditions[$i]->[1] . ":" . $val; + if ($conditions[$i]->[1] eq "not exposed" + || $conditions[$i]->[2] eq "false") { + $new[2] = "doesNotContain"; + } else { + $new[2] = "contains"; + } + } elsif ($conditions[$i]->[$start] =~ m/^object attribute (.*)/) { + my $name = $1; + $new[0] = "property"; + $new[1] = "objectAttributes"; + my $val = $conditions[$i]->[1]; + $val =~ s/"//g; + if ($val eq "not exposed" || $val eq "not mapped") { + $new[3] = $name; + $new[2] = "doesNotContain"; + } else { + $new[3] = $name . ":" . $val; + $new[2] = "contains"; + } + } else { + @new = @{$conditions[$i]}; + if ($conditions[$i]->[2] eq '<shown>') { + $new[2] = "contains"; + } + } + $conditions[$i] = \@new; + } elsif ($API eq "AXAPI") { + my $start = 0; + my $assert = "is"; + if ($conditions[$i]->[0] =~ m/^NOT/) { + $start = 1; + $assert = "isNot"; + } + if ($conditions[$i]->[$start] =~ m/^AXElementBusy/) { + if ($conditions[$i]->[$start+1] =~ m/yes/i) { + $new[3] = "true"; + } else { + $new[3] = "false"; + } + $new[0] = "property"; + $new[1] = $conditions[$i]->[$start]; + $new[2] = $assert; + } elsif ($conditions[$i]->[$start] =~ m/not in accessibility tree/i) { + @new = qw(property accessible exists false); + } elsif ($conditions[$i]->[$start] =~ m/^AX/) { + $new[0] = "property"; + $new[1] = $conditions[$i]->[$start]; + $new[2] = $assert; + $new[3] = $conditions[$i]->[$start+1]; + } elsif ($conditions[$i]->[$start] =~ m/^TBD/) { + $new[0] = "TBD"; + $new[1] = $new[2] = $new[3] = ""; + } else { + if ($conditions[$i]->[1] ne '<shown>' + && $conditions[$i]->[1] !~ m/true/i ) { + $assert = "isNot"; + } else { + $assert = "is"; + } + $new[0] = "result"; + $new[1] = $conditions[$i]->[0]; + $new[2] = $assert; + $new[3] = "true"; + } + } + if ($i == 0) { + if (scalar(@additional)) { + $rowcount += scalar(@additional); + } + $output .= "|-\n|rowspan=$rowcount|$API\n"; + } + foreach my $row (@new) { + $output .= "|$row\n"; + } + if (scalar(@additional)) { + foreach my $arow (@additional) { + $output .= "|-\n" ; + foreach my $aItem (@$arow) { + $output .= "|$aItem\n"; + } + } + } + } + } + $output .= "|}\n"; + + return $output; +} + +sub usage() { + print STDERR q(usage: make_tests.pl -f file | -w wiki_title | -s spec [-n -v -d dir ] + + -s specname - the name of a spec known to the system + -w wiki_title - the TITLE of a wiki page with testable statements + -f file - the file from which to read + -o outFile - the file to fill with the converted wiki; defaults to STDOUT + + -n - do nothing + -v - be verbose + ); + exit 1; +} + +# vim: ts=2 sw=2 ai: diff --git a/testing/web-platform/tests/wai-aria/tools/make_tests.pl b/testing/web-platform/tests/wai-aria/tools/make_tests.pl new file mode 100644 index 0000000000..01cb5b0b85 --- /dev/null +++ b/testing/web-platform/tests/wai-aria/tools/make_tests.pl @@ -0,0 +1,544 @@ +#!/usr/bin/perl +# +# make_tests.pl - generate WPT test cases from the testable statements wiki +# +# This script assumes that a wiki has testable statement entries +# in the format described by the specification at +# https://spec-ops.github.io/atta-api/index.html +# +# usage: make_tests.pl -f file | -w wiki_title | -s spec -d dir + +use strict; + +use IO::String ; +use JSON ; +use MediaWiki::API ; +use Getopt::Long; + +my %specs = ( + "aria11" => { + title => "ARIA_1.1_Testable_Statements", + specURL => "https://www.w3.org/TR/wai-aria11/", + dir => "aria11" + }, + "svg" => { + title => "SVG_Accessibility/Testing/Test_Assertions_with_Tables_for_ATTA", + specURL => "https://www.w3.org/TR/svg-aam-1.0/", + dir => "svg", + fragment => '<svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">%code%</svg>' + } +); + +my @apiNames = qw(UIA MSAA ATK IAccessible2 AXAPI); +my $apiNamesRegex = "(" . join("|", @apiNames) . ")"; + +# the suffix to attach to the automatically generated test case names +my $theSuffix = "-manual.html"; + +# dir is determined based upon the short name of the spec and is defined +# by the input or on the command line + +my $file = undef ; +my $spec = undef ; +my $wiki_title = undef ; +my $dir = undef; +my $theSpecFragment = "%code%"; +my $preserveWiki = ""; +my $fake = 0; + +my $result = GetOptions( + "f|file=s" => \$file, + "p=s" => \$preserveWiki, + "w|wiki=s" => \$wiki_title, + "s|spec=s" => \$spec, + "f|fake" => \$fake, + "d|dir=s" => \$dir) || usage(); + +my $wiki_config = { + "api_url" => "https://www.w3.org/wiki/api.php" +}; + +my $io ; +our $theSpecURL = ""; + +if ($spec) { + print "Processing spec $spec\n"; + $wiki_title = $specs{$spec}->{title}; + $theSpecURL = $specs{$spec}->{specURL}; + if (!$dir) { + $dir = "../" . $specs{$spec}->{dir}; + } + $theSpecFragment = $specs{$spec}->{fragment}; +} + +if (!$dir) { + $dir = "../raw"; +} + +if (!-d $dir) { + print STDERR "No such directory: $dir\n"; + exit 1; +} + +if ($file) { + open($io, "<", $file) || die("Failed to open $file: " . $@); +} elsif ($wiki_title) { + my $MW = MediaWiki::API->new( $wiki_config ); + + $MW->{config}->{on_error} = \&on_error; + + sub on_error { + print "Error code: " . $MW->{error}->{code} . "\n"; + print $MW->{error}->{stacktrace}."\n"; + die; + } + my $page = $MW->get_page( { title => $wiki_title } ); + my $theContent = $page->{'*'}; + print "Loaded " . length($theContent) . " from $wiki_title\n"; + if ($preserveWiki) { + if (open(OUTPUT, ">$preserveWiki")) { + print OUTPUT $theContent; + close OUTPUT; + print "Wiki preserved in $preserveWiki\n"; + exit 0; + } else { + print "Failed to create $preserveWiki. Terminating.\n"; + exit 1; + } + } + $io = IO::String->new($theContent); +} else { + usage() ; +} + + + +# Now let's walk through the content and build a test page for every item +# + +# iterate over the content + +# my $io ; +# open($io, "<", "raw") ; + +# data structure: +# +# steps is a list of steps to be performed. +# Each step is an object that has a type property and other properties based upon that type. +# +# Types include: +# +# 'test' - has a property for each ATAPI for which there are tests +# 'attribute' - has a property for the target id, attribute name, and value +# 'event' - has a property for the target id and event name +my $state = 0; # between items +my $theStep = undef; +my $current = ""; +my $theCode = ""; +my $theAttributes = {}; +my @steps ; +my $theAsserts = {} ; +my $theAssertCount = 0; +my $theAPI = ""; +my $typeRows = 0; +my $theType = ""; +my $theName = ""; +my $theRef = ""; +my $lineCounter = 0; +my $skipping = 0; + +our $testNames = {} ; + +while (<$io>) { + if (m/<!-- END OF TESTS -->/) { + last; + } + $lineCounter++; + # look for state + if (m/^SpecURL: (.*)$/) { + $theSpecURL = $1; + $theSpecURL =~ s/^ *//; + $theSpecURL =~ s/ *$//; + } + if ($state == 5 && m/^; \/\/ (.*)/) { + # we found another test inside a block + # we were in an item; dump it + build_test($current, $theAttributes, $theCode, \@steps, $theSpecFragment) ; + # print "Finished $current and new subblock $1\n"; + $state = 1; + $theAttributes = {} ; + $theAPI = ""; + @steps = (); + $theCode = ""; + $theAsserts = undef; + $theName = ""; + } elsif (m/^=== +(.*[^ ]) +===/) { + if ($state != 0) { + if ($skipping) { + print STDERR "Flag on assertion $current; skipping\n"; + } else { + # we were in an item; dump it + build_test($current, $theAttributes, $theCode, \@steps, $theSpecFragment) ; + # print "Finished $current\n"; + } + } + $state = 1; + $current = $1; + $theAttributes = {} ; + @steps = (); + $theCode = ""; + $theAsserts = undef; + $theAPI = ""; + $theName = ""; + if ($current =~ m/\(/) { + # there is a paren in the name -skip it + $skipping = 1; + } else { + $skipping = 0; + } + } + + if ($state == 1) { + if (m/<pre>/) { + # we are now in the code block + $state = 2; + next; + } elsif (m/==== +(.*) +====/) { + # we are in some other block + $theName = lc($1); + $theAttributes->{$theName} = ""; + next; + } + if (m/^Reference: +(.*)$/) { + $theAttributes->{reference} = $theSpecURL . "#" . $1; + } elsif ($theName ne "") { + # accumulate whatever was in the block under the data for it + chomp(); + $theAttributes->{$theName} .= $_; + } elsif (m/TODO/) { + $state = 0; + } + } + + if ($state == 2) { + if (m/<\/pre>/) { + # we are done with the code block + $state = 3; + } else { + if (m/^\s/ && !m/if given/) { + # trim any trailing whitespace + $theCode =~ s/ +$//; + $theCode =~ s/\t/ /g; + $theCode .= $_; + # In MediaWiki, to display & symbol escapes as literal text, one + # must use "&&" for the "&" character. We need to undo that. + $theCode =~ s/&(\S)/&$1/g; + } + } + } elsif ($state == 3) { + # look for a table + if (m/^\{\|/) { + # table started + $state = 4; + } + } elsif ($state == 4) { + if (m/^\|-/) { + if ($theAPI + && exists($theAsserts->{$theAPI}->[$theAssertCount]) + && scalar(@{$theAsserts->{$theAPI}->[$theAssertCount]})) { + $theAssertCount++; + } + # start of a table row + if ($theType ne "" && $typeRows) { + # print qq($theType typeRows was $typeRows\n); + # we are still processing items for a type + $typeRows--; + # populate the first cell + $theAsserts->{$theAPI}->[$theAssertCount] = [ $theType ] ; + } else { + $theType = ""; + } + } elsif (m/^\|\}/) { + # ran out of table + $state = 5; + # adding processing for additional block types + # a colspan followed by a keyword triggers a start + # so |colspan=5|element triggers a new collection + # |colspan=5|attribute triggers the setting of an attribute + } elsif (m/^\|colspan="*([0-9])"*\|([^ ]+) (.*)$/) { + my $type = $2; + my $params = $3; + + my $obj = {} ; + if ($type eq "attribute") { + if ($params =~ m/([^:]+):([^ ]+) +(.*)$/) { + $obj = { + type => $type, + element => $1, + attribute => $2, + value => $3 + }; + $theStep = undef; + push(@steps, $obj); + } else { + print STDERR "Malformed attribute instruction at line $lineCounter: " . $_ . "\n"; + } + } elsif ($type eq "event") { + if ($params =~ m/([^:]+):([^ ]+).*$/) { + $obj = { + type => $type, + element => $1, + value => $2 + }; + $theStep = undef; + push(@steps, $obj); + } else { + print STDERR "Malformed event instruction at line $lineCounter: " . $_ . "\n"; + } + } elsif ($type eq "element") { + $obj = { + type => "test", + element => $3 + }; + push(@steps, $obj); + $theStep = scalar(@steps) - 1; + $theAsserts = $steps[$theStep]; + } else { + print STDERR "Unknown operation type: $type at line " . $lineCounter . "; skipping.\n"; + } + } elsif (m/($apiNamesRegex)$/) { + my $theString = $1; + $theString =~ s/ +$//; + $theString =~ s/^ +//; + if ($theString eq "IA2") { + $theString = "IAccessible2" ; + } + my $rows = 1; + if (m/^\|rowspan="*([0-9])"*\|(.*)$/) { + $rows = $1 + } + if (grep { $_ eq $theString } @apiNames) { + # we found an API name - were we already processing assertions? + if (!$theAsserts) { + # nope - now what? + $theAsserts = { + type => "test", + element => "test" + }; + push(@steps, $theAsserts); + } + $theAssertCount = 0; + # this is a new API section + $theAPI = $theString ; + $theAsserts->{$theAPI} = [ [] ] ; + $theType = ""; + } else { + # this is a multi-row type + $theType = $theString; + $typeRows = $rows; + # print qq(Found multi-row $theString for $theAPI with $typeRows rows\n); + $typeRows--; + # populate the first cell + if ($theAPI + && exists($theAsserts->{$theAPI}->[$theAssertCount]) + && scalar(@{$theAsserts->{$theAPI}->[$theAssertCount]})) { + $theAssertCount++; + } + $theAsserts->{$theAPI}->[$theAssertCount] = [ $theType ] ; + } + } elsif (m/^\|(.*)$/) { + my $item = $1; + $item =~ s/^ *//; + $item =~ s/ *$//; + $item =~ s/^['"]//; + $item =~ s/['"]$//; + # add into the data structure for the API + if (!exists $theAsserts->{$theAPI}->[$theAssertCount]) { + $theAsserts->{$theAPI}->[$theAssertCount] = [ $item ] ; + } else { + push(@{$theAsserts->{$theAPI}->[$theAssertCount]}, $item); + } + } + } +}; + +if ($state != 0) { + build_test($current, $theAttributes, $theCode, \@steps, $theSpecFragment) ; + print "Finished $current\n"; +} + +exit 0; + +# build_test +# +# create a test file +# +# attempts to create unique test names + +sub build_test() { + my $title = shift ; + my $attrs = shift ; + my $code = shift ; + my $steps = shift; + my $frag = shift ; + + if ($title eq "") { + print STDERR "No name provided!"; + return; + } + + if ($frag ne "") { + $frag =~ s/%code%/$code/; + $code = $frag; + } + + $code =~ s/ +$//m; + $code =~ s/\t/ /g; + + my $title_reference = $title; + + if ($code eq "") { + print STDERR "No code for $title; skipping.\n"; + return; + } + if ( $steps eq {}) { + print STDERR "No assertions for $title; skipping.\n"; + return; + } + + my $testDef = + { "title" => $title, + "steps" => [] + }; + my $stepCount = 0; + foreach my $asserts (@$steps) { + $stepCount++; + my $step = + { + "type" => $asserts->{"type"}, + "title"=> "step " . $stepCount, + }; + + if ($asserts->{type} eq "test") { + # everything in the block is about testing an element + $step->{"element"} = ( $asserts->{"element"} || "test" ); + + my $tests = {}; + if ($fake) { + $tests->{"WAIFAKE"} = [ [ "property", "role", "is", "ROLE_TABLE_CELL" ], [ "property", "interfaces", "contains", "TableCell" ] ]; + } + foreach my $name (@apiNames) { + if (exists $asserts->{$name} && scalar(@{$asserts->{$name}})) { + $tests->{$name} = $asserts->{$name}; + } + }; + + $step->{test} = $tests; + + } elsif ($asserts->{type} eq "attribute") { + $step->{type} = "attribute"; + $step->{element} = $asserts->{"element"}; + $step->{attribute} = $asserts->{"attribute"}; + $step->{value} = $asserts->{value}; + } elsif ($asserts->{type} eq "event") { + $step->{type} = "event"; + $step->{element} = $asserts->{"element"}; + $step->{event} = $asserts->{value}; + } else { + print STDERR "Invalid step type: " . $asserts->{type} . "\n"; + next; + } + push(@{$testDef->{steps}}, $step); + } + + + # populate the rest of the test definition + + if (scalar(keys(%$attrs))) { + while (my $key = each(%$attrs)) { + # print "Copying $key \n"; + $testDef->{$key} = $attrs->{$key}; + } + } + + if (exists $attrs->{reference}) { + $title_reference = "<a href='" . $attrs->{reference} . "'>" . $title_reference . "</a>" ; + } + + my $testDef_json = to_json($testDef, { canonical => 1, pretty => 1, utf8 => 1}); + + my $fileName = $title; + $fileName =~ s/\s*$//; + $fileName =~ s/\///g; + $fileName =~ s/\s+/_/g; + $fileName =~ s/[,=:]/_/g; + $fileName =~ s/['"]//g; + + my $count = 2; + if ($testNames->{$fileName}) { + while (exists $testNames->{$fileName . "_$count"}) { + $count++; + } + $fileName .= "_$count"; + } + + $fileName = lc($fileName); + + $testNames->{$fileName} = 1; + + $fileName .= $theSuffix; + + my $template = qq(<!doctype html> +<html> + <head> + <title>$title</title> + <meta content="text/html; charset=utf-8" http-equiv="Content-Type"/> + <link rel="stylesheet" href="/wai-aria/scripts/manual.css"> + <script src="/resources/testharness.js"></script> + <script src="/resources/testharnessreport.js"></script> + <script src="/wai-aria/scripts/ATTAcomm.js"></script> + <script> + setup({explicit_timeout: true, explicit_done: true }); + + var theTest = new ATTAcomm( + $testDef_json + ) ; + </script> + </head> + <body> + <p>This test examines the ARIA properties for $title_reference.</p> + $code + <div id="manualMode"></div> + <div id="log"></div> + <div id="ATTAmessages"></div> + </body> +</html>); + + my $file ; + + if (open($file, ">", "$dir/$fileName")) { + print $file $template; + print $file "\n"; + close $file; + } else { + print STDERR qq(Failed to create file "$dir/$fileName" $!\n); + } + + return; +} + +sub usage() { + print STDERR q(usage: make_tests.pl -f file | -w wiki_title | -s spec [-n -v -d dir ] + + -s specname - the name of a spec known to the system + -w wiki_title - the TITLE of a wiki page with testable statements + -f file - the file from which to read + + -n - do nothing + -v - be verbose + -d dir - put generated tests in directory dir + ); + exit 1; +} + +# vim: ts=2 sw=2 ai: |