/[suikacvs]/markup/html/whatpm/Whatpm/WebIDL.pm
Suika

Contents of /markup/html/whatpm/Whatpm/WebIDL.pm

Parent Directory Parent Directory | Revision Log Revision Log

Revision 1.18 - (show annotations) (download)
Tue Sep 16 13:59:55 2008 UTC (17 years, 11 months ago) by wakaba
Branch: MAIN
Changes since 1.17: +70 -57 lines 
++ whatpm/t/webidl/ChangeLog	16 Sep 2008 13:59:48 -0000
	webidl-valuetype.dat, webidl-typedef.dat: Test results are updated
	for new error type names.

2008-09-16  Wakaba  <wakaba@suika.fam.cx>

	* webidl-defs.dat, webidl-interface.dat, webidl-exception.dat,
++ whatpm/Whatpm/ChangeLog	16 Sep 2008 13:58:58 -0000
	* WebIDL.pm: Checker's error types are redefined.

2008-09-16  Wakaba  <wakaba@suika.fam.cx>
1 package Whatpm::WebIDL;
2 use strict;
3
4 package Whatpm::WebIDL::Parser;
5
6 my $integer = qr/-?0([Xx][0-9A-Fa-f]+|[0-7]*)|[1-9][0-9]*/;
7 ## ISSUE: Spec's pattern is wrong as a Perl5 regular expression.
8 my $float = qr/-?([0-9]+\.[0-9]*|[0-9]*\.[0-9]+)([Ee][+-]?[0-9]+)?|[0-9]+[Ee][+-]?[0-9]+/;
9 my $identifier = qr/[A-Z_a-z][0-9A-Z_a-z]*/;
10 my $whitespace = qr<[\t\n\r ]+|[\t\n\r ]*((//.*|/\*.*?\*/)[\t\n\r ]*)+>;
11
12 my $default_levels = {
13 must => 'm',
14 should => 's',
15 warn => 'w',
16 fact => 'w',
17 undefined => 'w',
18 info => 'i',
19 uncertain => 'u',
20 };
21
22 sub new ($) {
23 my $self = bless {
24 level => $default_levels,
25 }, $_[0];
26 return $self;
27 } # new
28
29 sub parse_char_string ($$;$) {
30 my $self = shift;
31 my $s = ref $_[0] ? $_[0] : \($_[0]);
32
33 my $defs = Whatpm::WebIDL::Definitions->new;
34 $defs->set_user_data (manakai_source_line => 1);
35 $defs->set_user_data (manakai_source_column => 1);
36
37 pos ($$s) = 0;
38 my $line = 1;
39 my $column = 0;
40
41 my $get_next_token = sub {
42 if (length $$s <= pos $$s) {
43 return {type => 'eof'};
44 }
45
46 while ($$s =~ /\G($whitespace)/gc) {
47 my $v = $1;
48 while ($v =~ s/^[^\x0D\x0A]*(?>\x0D\x0A?|\x0A)//) {
49 $line++;
50 $column = 0;
51 }
52 $column += length $v;
53 }
54
55 if (length $$s <= pos $$s) {
56 return {type => 'eof'};
57 }
58
59 ## ISSUE: "must"s in "A. IDL grammer" are not "MUST"s.
60
61 if ($$s =~ /\G($identifier)/gc) {
62 my $v = $1;
63 $column += length $v;
64 if ({
65 module => 1, interface => 1, exception => 1, typedef => 1,
66 valuetype => 1, DOMString => 1, sequence => 1, unsigned => 1,
67 short => 1, const => 1, TRUE => 1, FALSE => 1, readonly => 1,
68 attribute => 1, getraises => 1, setraises => 1, raises => 1, in => 1,
69 any => 1, boolean => 1, octet => 1, float => 1, Object => 1,
70 short => 1, long => 1, void => 1,
71 }->{$v}) {
72 return {type => $v};
73 } else {
74 return {type => 'identifier', value => $v};
75 }
76 } elsif ($$s =~ /\G($float)/gc) { ## ISSUE: negative number
77 $column += length $1;
78 return {type => 'float', value => $1};
79 } elsif ($$s =~ /\G($integer)/gc) { ## ISSUE: negative nmber
80 $column += length $1;
81 return {type => 'integer', value => $1};
82 } elsif ($$s =~ /\G::/gcs) {
83 $column += 2;
84 return {type => '::'};
85 } elsif ($$s =~ /\G(.)/gcs) { ## NOTE: Should never be a newline char.
86 $column++;
87 return {type => $1};
88 } else {
89 die "get_next_token: non-possible case: " . substr ($$s, pos $$s, 20);
90 }
91 }; # $get_next_token
92
93 my $state = 'before definitions';
94 my $token = $get_next_token->();
95 my $nest_level = 0;
96 my $next_state;
97 my $xattrs;
98 my $prev_xattrs = [];
99 my $last_xattr;
100 my $read_only;
101 my $current_type;
102 my @current = ($defs);
103
104 my $_onerror = $_[1] || sub {
105 my %opt = @_;
106 my $r = 'Line ' . $opt{line} . ' column ' . $opt{column} . ': ';
107
108 if ($opt{token}) {
109 $r .= 'Token ' . (defined $opt{token}->{value}
110 ? $opt{token}->{value} : $opt{token}->{type}) . ': ';
111 }
112
113 $r .= $opt{type} . ';' . $opt{level};
114
115 warn $r . "\n";
116 }; # $_onerror
117 my $onerror = sub {
118 $_onerror->(line => $line, column => $column, token => $token, @_);
119 }; # $onerror
120
121 my $get_scoped_name = sub {
122 ## NOTE: Convert a |ScopedName| into a "scoped name".
123
124 my $name = [];
125
126 ## NOTE: "DOMString" is not a scoped name, while "::DOMString"
127 ## and "x::DOMString" are.
128
129 if ($token->{type} eq 'identifier') {
130 my $identifier = $token->{value};
131 $identifier =~ s/^_//;
132 push @$name, $identifier;
133 $token = $get_next_token->();
134 while ($token->{type} eq '::') {
135 $token = $get_next_token->();
136 if ($token->{type} eq 'identifier') {
137 my $identifier = $token->{value};
138 $identifier =~ s/^_//;
139 push @$name, $identifier;
140 $token = $get_next_token->();
141 } elsif ($token->{type} eq 'DOMString') {
142 push @$name, 'DOMString', '', '';
143 $token = $get_next_token->();
144 last;
145 }
146 }
147 } elsif ($token->{type} eq '::') {
148 push @$name, '';
149 while ($token->{type} eq '::') {
150 $token = $get_next_token->();
151 if ($token->{type} eq 'identifier') {
152 my $identifier = $token->{value};
153 $identifier =~ s/^_//;
154 push @$name, $identifier;
155 $token = $get_next_token->();
156 } elsif ($token->{type} eq 'DOMString') {
157 push @$name, 'DOMString', '', '';
158 $token = $get_next_token->();
159 last;
160 } else {
161 last;
162 }
163 }
164
165 if (@$name == 1) {
166 return undef;
167 }
168 } else {
169 # reconsume
170 return undef;
171 }
172 return join '::', @$name;
173 }; # $get_scoped_name
174
175 my $get_type;
176 $get_type = sub {
177 my $r;
178 if ({
179 void => 1, any => 1, boolean => 1, octet => 1, float => 1,
180 DOMString => 1, Object => 1, short => 1,
181 }->{$token->{type}}) {
182 $r = '::'.$token->{type}.'::';
183 $token = $get_next_token->();
184 } elsif ($token->{type} eq 'unsigned') {
185 $token = $get_next_token->();
186 if ($token->{type} eq 'short') {
187 $r = '::unsigned '.$token->{type}.'::';
188 $token = $get_next_token->();
189 } elsif ($token->{type} eq 'long') {
190 $token = $get_next_token->();
191 if ($token->{type} eq 'long') {
192 $r = '::unsigned long long::';
193 $token = $get_next_token->();
194 } else {
195 $r = '::unsigned long::';
196 # reconsume
197 }
198 } else {
199 $onerror->(type => 'after unsigned',
200 level => $self->{level}->{must});
201 return undef;
202 }
203 } elsif ($token->{type} eq 'long') {
204 $token = $get_next_token->();
205 if ($token->{type} eq 'long') {
206 $r = '::long long::';
207 $token = $get_next_token->();
208 } else {
209 $r = '::long::';
210 # reconsume
211 }
212 } elsif ($token->{type} eq '::' or $token->{type} eq 'identifier') {
213 $r = $get_scoped_name->();
214 if (defined $r) {
215 # next token
216 } else { # "::" not followed by identifier or "DOMString"
217 $onerror->(type => 'scoped name:dcolon',
218 level => $self->{level}->{must});
219 return undef;
220 }
221 } elsif ($token->{type} eq 'sequence') {
222 $token = $get_next_token->();
223 if ($token->{type} eq '<') {
224 $token = $get_next_token->();
225 if ({
226 void => 1, any => 1, boolean => 1, octet => 1, float => 1,
227 DOMString => 1, Object => 1, short => 1, long => 1, unsigned => 1,
228 sequence => 1, '::' => 1, identifier => 1,
229 }->{$token->{type}}) {
230 my $type = $get_type->();
231 if (defined $type) {
232 if ($token->{type} eq '>') {
233 $r = '::::sequence::::' . $type;
234 $token = $get_next_token->();
235 } else {
236 $onerror->(type => 'no sequence gt',
237 level => $self->{level}->{must});
238 return undef;
239 }
240 } else {
241 # error reported
242 return undef;
243 }
244 } else {
245 $onerror->(type => 'no sequence type',
246 level => $self->{level}->{must});
247 return undef;
248 }
249 } else {
250 $onerror->(type => 'no sequence lt',
251 level => $self->{level}->{must});
252 return undef;
253 }
254 } else {
255 die "get_type: bad token: $token->{type}";
256 }
257
258 return $r;
259 }; # $get_type
260
261 while (1) {
262 if ($state eq 'before definitions') {
263 $xattrs = [];
264 if ($token->{type} eq '[') {
265 $token = $get_next_token->();
266 $state = 'before xattr';
267 $next_state = 'before def';
268 } elsif ({module => 1, interface => 1, exception => 1,
269 typedef => 1, valuetype => 1, const => 1}->{$token->{type}}) {
270 # reconsume
271 $state = 'before def';
272 } elsif ($token->{type} eq '}' and @current > 1) {
273 $token = $get_next_token->();
274 $state = 'before block semicolon';
275 } elsif ($token->{type} eq 'eof') {
276 last;
277 } else {
278 $onerror->(type => 'before webidl defs',
279 level => $self->{level}->{must});
280 # reconsume
281 $state = 'ignore';
282 $nest_level = 0;
283 $next_state = 'before definitions';
284 }
285 } elsif ($state eq 'before xattr') {
286 if ($token->{type} eq 'identifier') {
287 my $id = $token->{value};
288 $id =~ s/^_//;
289 push @current, Whatpm::WebIDL::ExtendedAttribute->new ($id);
290 $current[-1]->set_user_data (manakai_source_line => $line);
291 $current[-1]->set_user_data (manakai_source_column => $column);
292 push @$xattrs, $current[-1];
293 $token = $get_next_token->();
294 $state = 'after xattr';
295 } else {
296 $onerror->(type => 'before xattr',
297 level => $self->{level}->{must});
298 # reconsume
299 $state = 'ignore';
300 $nest_level = 0;
301 $next_state = 'before definitions'; ## TODO:
302 }
303 } elsif ($state eq 'after xattr') {
304 if ($token->{type} eq '=') {
305 $token = $get_next_token->();
306 $state = 'before xattrarg';
307 } elsif ($token->{type} eq '(') {
308 $current[-1]->has_argument_list (1);
309 $token = $get_next_token->();
310 if ($token->{type} eq ')') {
311 $token = $get_next_token->();
312 push @$prev_xattrs, $xattrs;
313 $state = 'after xattrarg';
314 } else {
315 push @$prev_xattrs, $xattrs;
316 # reconsume
317 $state = 'before argument';
318 }
319 } else {
320 push @$prev_xattrs, $xattrs;
321 # reconsume
322 $state = 'after xattrarg';
323 }
324 } elsif ($state eq 'before xattrarg') {
325 if ($token->{type} eq 'identifier') {
326 my $identifier = $token->{value};
327 $identifier =~ s/^_//;
328 $current[-1]->value ($identifier);
329 $token = $get_next_token->();
330 if ($token->{type} eq '(') {
331 $current[-1]->has_argument_list (1);
332 $token = $get_next_token->();
333 if ($token->{type} eq ')') {
334 push @$prev_xattrs, $xattrs;
335 $token = $get_next_token->();
336 $state = 'after xattrarg';
337 } else {
338 push @$prev_xattrs, $xattrs;
339 # reconsume
340 $state = 'before argument';
341 }
342 } else {
343 push @$prev_xattrs, $xattrs;
344 # reconsume
345 $state = 'after xattrarg';
346 }
347 } else {
348 $onerror->(type => 'before xattrarg',
349 level => $self->{level}->{must});
350 # reconsume
351 $state = 'ignore';
352 $nest_level = 0;
353 $next_state = 'before definitions';
354 }
355 } elsif ($state eq 'after xattrarg') {
356 pop @current; # xattr
357 $xattrs = pop @$prev_xattrs;
358 if ($token->{type} eq ',') {
359 $token = $get_next_token->();
360 $state = 'before xattr';
361 } elsif ($token->{type} eq ']') {
362 $token = $get_next_token->();
363 if ($current[-1]->isa ('Whatpm::WebIDL::Definitions') or
364 $current[-1]->isa ('Whatpm::WebIDL::Module')) {
365 $state = 'before def';
366 } elsif ($current[-1]->isa ('Whatpm::WebIDL::Interface')) {
367 $state = 'before interface member';
368 } elsif ($current[-1]->isa ('Whatpm::WebIDL::Exception')) {
369 $state = 'before exception member';
370 } elsif ($current[-1]->isa ('Whatpm::WebIDL::Operation') or
371 $current[-1]->isa ('Whatpm::WebIDL::ExtendedAttribute')) {
372 $state = 'before argument in';
373 } else {
374 die "$0: Unknown xattr context: " . ref $current[-1];
375 }
376 } else {
377 $onerror->(type => 'after xattr',
378 level => $self->{level}->{must});
379 # reconsume
380 $state = 'ignore';
381 $nest_level = 0;
382 $next_state = 'before definitions'; ## TODO:
383 }
384 } elsif ($state eq 'before def') {
385 if ($token->{type} eq 'module') {
386 $token = $get_next_token->();
387 if ($token->{type} eq 'identifier') {
388 my $identifier = $token->{value};
389 $identifier =~ s/^_//;
390 push @current, Whatpm::WebIDL::Module->new ($identifier);
391 $current[-1]->set_user_data (manakai_source_line => $line);
392 $current[-1]->set_user_data (manakai_source_column => $column);
393 $current[-1]->set_extended_attribute_node ($_) for @$xattrs;
394 $token = $get_next_token->();
395 $state = 'before module block';
396 next;
397 } else {
398 $onerror->(type => 'no webidl identifier',
399 text => 'module',
400 level => $self->{level}->{must});
401 #
402 }
403 } elsif ($token->{type} eq 'interface') {
404 $token = $get_next_token->();
405 if ($token->{type} eq 'identifier') {
406 my $identifier = $token->{value};
407 $identifier =~ s/^_//;
408 push @current, Whatpm::WebIDL::Interface->new ($identifier);
409 $current[-1]->set_user_data (manakai_source_line => $line);
410 $current[-1]->set_user_data (manakai_source_column => $column);
411 $current[-1]->set_extended_attribute_node ($_) for @$xattrs;
412 $token = $get_next_token->();
413 $state = 'before interface inheritance';
414 next;
415 } else {
416 $onerror->(type => 'no webidl identifier',
417 text => 'interface',
418 level => $self->{level}->{must});
419 #
420 }
421 } elsif ($token->{type} eq 'exception') {
422 $token = $get_next_token->();
423 if ($token->{type} eq 'identifier') {
424 my $identifier = $token->{value};
425 $identifier =~ s/^_//;
426 push @current, Whatpm::WebIDL::Exception->new ($identifier);
427 $current[-1]->set_user_data (manakai_source_line => $line);
428 $current[-1]->set_user_data (manakai_source_column => $column);
429 $current[-1]->set_extended_attribute_node ($_) for @$xattrs;
430 $token = $get_next_token->();
431 $state = 'before exception block';
432 next;
433 } else {
434 $onerror->(type => 'no webidl identifier',
435 text => 'exception',
436 level => $self->{level}->{must});
437 #
438 }
439 } elsif ($token->{type} eq 'typedef') {
440 $token = $get_next_token->();
441 $state = 'before typedef type';
442 next;
443 } elsif ($token->{type} eq 'valuetype') {
444 $token = $get_next_token->();
445 if ($token->{type} eq 'identifier') {
446 my $identifier = $token->{value};
447 $identifier =~ s/^_//;
448 push @current, Whatpm::WebIDL::Valuetype->new ($identifier);
449 $current[-1]->set_user_data (manakai_source_line => $line);
450 $current[-1]->set_user_data (manakai_source_column => $column);
451 $current[-1]->set_extended_attribute_node ($_) for @$xattrs;
452 $token = $get_next_token->();
453 $state = 'before boxed type';
454 next;
455 } elsif ($token->{type} eq 'DOMString') {
456 push @current, Whatpm::WebIDL::Valuetype->new ('::DOMString::');
457 $current[-1]->set_user_data (manakai_source_line => $line);
458 $current[-1]->set_user_data (manakai_source_column => $column);
459 $current[-1]->set_extended_attribute_node ($_) for @$xattrs;
460 $token = $get_next_token->();
461 if ($token->{type} eq 'sequence') {
462 $token = $get_next_token->();
463 if ($token->{type} eq '<') {
464 $token = $get_next_token->();
465 if ($token->{type} eq 'unsigned') {
466 $token = $get_next_token->();
467 if ($token->{type} eq 'short') {
468 $token = $get_next_token->();
469 if ($token->{type} eq '>') {
470 $current[-1]->type ('::::sequence::::::unsigned short::');
471 $token = $get_next_token->();
472 $state = 'before semicolon';
473 $next_state = 'before definitions';
474 next;
475 } else {
476 #
477 }
478 } else {
479 #
480 }
481 } else {
482 #
483 }
484 } else {
485 #
486 }
487 } else {
488 #
489 }
490 $onerror->(type => 'valuetype DOMString',
491 level => $self->{level}->{must});
492 pop @current; # valuetype
493 #
494 } else {
495 $onerror->(type => 'no webidl identifier',
496 text => 'valuetype',
497 level => $self->{level}->{must});
498 #
499 }
500 } elsif ($token->{type} eq 'const') {
501 $token = $get_next_token->();
502 $state = 'before const type';
503 $next_state = 'before definitions';
504 next;
505 } else {
506 $onerror->(type => 'before webidl def',
507 level => $self->{level}->{must});
508 # reconsume
509 #
510 }
511 $state = 'ignore';
512 $nest_level = 0;
513 $next_state = 'before definitions';
514 } elsif ($state eq 'before module block') {
515 if ($token->{type} eq '{') {
516 $token = $get_next_token->();
517 $state = 'before definitions';
518 } else {
519 $onerror->(type => 'before webidl block',
520 text => 'module',
521 level => $self->{level}->{must});
522 pop @current; # module
523 # reconsume
524 $state = 'ignore';
525 $nest_level = 0;
526 $next_state = 'before definitions';
527 }
528 } elsif ($state eq 'before interface inheritance') {
529 if ($token->{type} eq ':') {
530 $token = $get_next_token->();
531 $state = 'before parent interface name';
532 } elsif ($token->{type} eq ';') {
533 $current[-1]->is_forward_declaration (1);
534 # reconsume
535 $state = 'before semicolon';
536 $next_state = 'before interface member';
537 } else {
538 # reconsume
539 $state = 'before interface block';
540 }
541 } elsif ($state eq 'before parent interface name') {
542 my $name = $get_scoped_name->();
543 if (defined $name) {
544 $current[-1]->append_inheritance ($name);
545
546 if ($token->{type} eq ',') {
547 $token = $get_next_token->();
548 # stay in the state
549 } else {
550 # reconsume
551 $state = 'before interface block';
552 }
553 } else {
554 $onerror->(type => 'scoped name', level => $self->{level}->{must});
555 pop @current; # interface
556 # reconsume
557 $state = 'ignore';
558 $nest_level = 0;
559 }
560 } elsif ($state eq 'before exception name') {
561 my $name = $get_scoped_name->();
562 if (defined $name) {
563 my $method = $next_state eq '*raises' ? 'append_raises' :
564 $next_state eq '*getraises' ? 'append_getraises' :
565 'append_setraises';
566 $current[-1]->$method ($name);
567
568 if ($token->{type} eq ',') {
569 $token = $get_next_token->();
570 # stay in the state
571 } elsif ($token->{type} eq ')') {
572 $token = $get_next_token->();
573 if ($next_state eq '*getraises' and $token->{type} eq 'setraises') {
574 $token = $get_next_token->();
575 $state = 'after raises';
576 $next_state = '*setraises';
577 } else {
578 # reprocess
579 $state = 'before semicolon';
580 $next_state = 'before interface member';
581 }
582 } else {
583 $onerror->(type => 'after exception name',
584 level => $self->{level}->{must});
585 # reconsume
586 $state = 'ignore';
587 $nest_level = 0;
588 }
589 } else {
590 $onerror->(type => 'scoped name', level => $self->{level}->{must});
591 # reconsume
592 $state = 'ignore';
593 $nest_level = 0;
594 }
595 } elsif ($state eq 'before interface block') {
596 if ($token->{type} eq '{') {
597 $token = $get_next_token->();
598 $state = 'before members';
599 $next_state = 'before interface member';
600 } else {
601 $onerror->(type => 'before webidl block',
602 text => 'interface',
603 level => $self->{level}->{must});
604 pop @current; # interface
605 # reconsume
606 $state = 'ignore';
607 $nest_level = 0;
608 }
609 } elsif ($state eq 'before exception block') {
610 if ($token->{type} eq '{') {
611 $token = $get_next_token->();
612 $state = 'before members';
613 $next_state = 'before exception member';
614 } else {
615 $onerror->(type => 'before webidl block',
616 text => 'exception',
617 level => $self->{level}->{must});
618 pop @current; # exception
619 # reconsume
620 $state = 'ignore';
621 $nest_level = 0;
622 }
623 } elsif ($state eq 'before members') {
624 $xattrs = [];
625 if ($token->{type} eq '[') {
626 $token = $get_next_token->();
627 $state = 'before xattr';
628 #$next_state = $next_state; # 'before interface member' or ...
629 } elsif ($token->{type} eq '}') {
630 $token = $get_next_token->();
631 $state = 'before block semicolon';
632 } else {
633 # reconsume
634 $state = $next_state; # ... 'before exception member'
635 }
636 } elsif ($state eq 'before interface member') {
637 if ($token->{type} eq 'const') {
638 $token = $get_next_token->();
639 $state = 'before const type';
640 $next_state = 'before definitions';
641 } elsif ($token->{type} eq 'readonly') {
642 $read_only = 1;
643 $token = $get_next_token->();
644 if ($token->{type} eq 'attribute') {
645 $token = $get_next_token->();
646 $state = 'after attribute';
647 } else {
648 # reconsume
649 $state = 'ignore';
650 $nest_level = 0;
651 $next_state = 'before interface member';
652 }
653 } elsif ($token->{type} eq 'attribute') {
654 $read_only = 0;
655 $token = $get_next_token->();
656 $state = 'after attribute';
657 } elsif ({
658 void => 1, any => 1, boolean => 1, octet => 1, float => 1,
659 DOMString => 1, Object => 1, unsigned => 1, short => 1, long => 1,
660 '::' => 1, identifier => 1,
661 }->{$token->{type}}) {
662 # reconsume
663 $state = 'before operation type';
664 } elsif ($token->{type} eq '}') {
665 $token = $get_next_token->();
666 $state = 'before semicolon';
667 $next_state = 'before definitions';
668 } elsif ($token->{type} eq 'eof') {
669 last;
670 } else {
671 $onerror->(type => 'before interface member',
672 level => $self->{level}->{must});
673 # reconsume
674 $state = 'ignore';
675 $nest_level = 0;
676 }
677 } elsif ($state eq 'before exception member') {
678 if ({
679 void => 1, any => 1, boolean => 1, octet => 1, float => 1,
680 DOMString => 1, Object => 1, unsigned => 1, short => 1, long => 1,
681 '::' => 1, identifier => 1,
682 }->{$token->{type}}) {
683 # reconsume
684 $state = 'before exception member type';
685 } elsif ($token->{type} eq '}') {
686 $token = $get_next_token->();
687 $state = 'before semicolon';
688 $next_state = 'before definitions';
689 } elsif ($token->{type} eq 'eof') {
690 last;
691 } else {
692 $onerror->(type => 'before exception member',
693 level => $self->{level}->{must});
694 # reconsume
695 $state = 'ignore';
696 $nest_level = 0;
697 }
698 } elsif ($state eq 'before typedef type') {
699 if ({
700 void => 1, any => 1, boolean => 1, octet => 1, float => 1,
701 DOMString => 1, Object => 1, short => 1, long => 1, unsigned => 1,
702 sequence => 1, '::' => 1, identifier => 1,
703 }->{$token->{type}}) {
704 $current_type = $get_type->();
705 if (defined $current_type) {
706 # next token
707 $state = 'before typedef rest';
708 } else {
709 # reconsume
710 $state = 'ignore';
711 $nest_level = 0;
712 $next_state = 'before definitions';
713 }
714 } else {
715 $onerror->(type => 'before webidl type',
716 text => 'typedef',
717 level => $self->{level}->{must});
718 # reconsume
719 $state = 'ignore';
720 $nest_level = 0;
721 $next_state = 'before definitions';
722 }
723 } elsif ($state eq 'before boxed type') {
724 if ({
725 boolean => 1, octet => 1, float => 1,
726 short => 1, long => 1, unsigned => 1,
727 sequence => 1, '::' => 1, identifier => 1,
728 }->{$token->{type}}) {
729 $current_type = $get_type->();
730 if (defined $current_type) {
731 $current[-1]->type ($current_type);
732 # next token
733 $state = 'before semicolon';
734 $next_state = 'before definitions';
735 } else {
736 pop @current; # valuetype
737 # reconsume
738 $state = 'ignore';
739 $nest_level = 0;
740 $next_state = 'before definitions';
741 }
742 } else {
743 $onerror->(type => 'before webidl type',
744 text => 'valuetype',
745 level => $self->{level}->{must});
746 pop @current; # valuetype
747 # reconsume
748 $state = 'ignore';
749 $nest_level = 0;
750 $next_state = 'before definitions';
751 }
752 } elsif ($state eq 'before const type') {
753 if ({
754 any => 1, boolean => 1, octet => 1, float => 1,
755 DOMString => 1, Object => 1, short => 1, long => 1, unsigned => 1,
756 '::' => 1, identifier => 1,
757 }->{$token->{type}}) {
758 $current_type = $get_type->();
759 if (defined $current_type) {
760 # next token
761 $state = 'before const identifier';
762 } else {
763 # reconsume
764 $state = 'ignore';
765 $nest_level = 0;
766 #$next_state = $next_state;
767 }
768 } else {
769 $onerror->(type => 'before webidl type',
770 text => 'const',
771 level => $self->{level}->{must});
772 # reconsume
773 $state = 'ignore';
774 $nest_level = 0;
775 #$next_state = $next_state;
776 }
777 } elsif ($state eq 'before typedef rest') {
778 if ($token->{type} eq 'identifier') {
779 ## TODO: unescape
780 push @current, Whatpm::WebIDL::Typedef->new ($token->{value});
781 $current[-1]->set_user_data (manakai_source_line => $line);
782 $current[-1]->set_user_data (manakai_source_column => $column);
783 $current[-1]->type ($current_type);
784 $current[-1]->set_extended_attribute_node ($_) for @$xattrs;
785 $token = $get_next_token->();
786 $state = 'before semicolon';
787 $next_state = 'before definitions';
788 } elsif ($token->{type} eq 'DOMString') {
789 push @current, Whatpm::WebIDL::Typedef->new ('::DOMString::');
790 $current[-1]->type ($current_type);
791 $current[-1]->set_user_data (manakai_source_line => $line);
792 $current[-1]->set_user_data (manakai_source_column => $column);
793 $current[-1]->set_extended_attribute_node ($_) for @$xattrs;
794 $token = $get_next_token->();
795 $state = 'before semicolon';
796 $next_state = 'before defnitions';
797 } else {
798 $onerror->(type => 'no webidl identifier',
799 text => 'typedef',
800 level => $self->{level}->{must});
801 # reconsume
802 $state = 'ignore';
803 $nest_level = 0;
804 $next_state = 'before definitions';
805 }
806 } elsif ($state eq 'before const identifier') {
807 if ($token->{type} eq 'identifier') {
808 my $identifier = $token->{value};
809 $identifier =~ s/^_//;
810 push @current, Whatpm::WebIDL::Const->new ($identifier);
811 $current[-1]->set_user_data (manakai_source_line => $line);
812 $current[-1]->set_user_data (manakai_source_column => $column);
813 $current[-1]->type ($current_type);
814 $current[-1]->set_extended_attribute_node ($_) for @$xattrs;
815 $token = $get_next_token->();
816 if ($token->{type} eq '=') {
817 $token = $get_next_token->();
818 $state = 'before const expr';
819 next;
820 } else {
821 $onerror->(type => 'no const eq', level => $self->{level}->{must});
822 #
823 }
824 } else {
825 $onerror->(type => 'no webidl identifier',
826 text => 'const',
827 level => $self->{level}->{must});
828 #
829 }
830 # reconsume
831 $state = 'ignore';
832 $nest_level = 0;
833 #$next_state = $next_state;
834 } elsif ($state eq 'before const expr') {
835 if ($token->{type} eq 'TRUE' or $token->{type} eq 'FALSE') {
836 $current[-1]->value ([$token->{type}]);
837 #
838 } elsif ($token->{type} eq 'integer') {
839 if ($token->{value} =~ /^0[Xx]/) {
840 $current[-1]->value ([$token->{type}, hex substr $token->{value},2]);
841 } elsif ($token->{value} =~ /^-0[Xx]/) {
842 $current[-1]->value ([$token->{type},-hex substr $token->{value},3]);
843 } elsif ($token->{value} =~ /^0/) {
844 $current[-1]->value ([$token->{type}, oct $token->{value}]);
845 } elsif ($token->{value} =~ /^-0/) {
846 $current[-1]->value ([$token->{type},-oct substr $token->{value},1]);
847 } else {
848 $current[-1]->value ([$token->{type}, 0+$token->{value}]);
849 }
850 #
851 } elsif ($token->{type} eq 'float') {
852 $current[-1]->value ([$token->{type}, 0+$token->{value}]);
853 #
854 } else {
855 # reconsume
856 $state = 'ignore';
857 $nest_level = 0;
858 #$next_state = $next_state;
859 next;
860 }
861
862 $token = $get_next_token->();
863 $state = 'before semicolon';
864 #$next_state = $next_state;
865 } elsif ($state eq 'after attribute') {
866 if ({
867 any => 1, boolean => 1, octet => 1, float => 1,
868 DOMString => 1, Object => 1, short => 1, long => 1, unsigned => 1,
869 '::' => 1, identifier => 1,
870 }->{$token->{type}}) {
871 $current_type = $get_type->();
872 if (defined $current_type) {
873 # next token
874 $state = 'before attribute identifier';
875 } else {
876 # reconsume
877 $state = 'ignore';
878 $nest_level = 0;
879 $next_state = 'before interface member';
880 }
881 } else {
882 $onerror->(type => 'before webidl type',
883 text => 'attribute',
884 level => $self->{level}->{must});
885 # reconsume
886 $state = 'ignore';
887 $nest_level = 0;
888 $next_state = 'before interface member';
889 }
890 } elsif ($state eq 'before exception member type') {
891 #if ({
892 # any => 1, boolean => 1, octet => 1, float => 1,
893 # DOMString => 1, Object => 1, short => 1, long => 1, unsigned => 1,
894 # '::' => 1, identifier => 1,
895 #}->{$token->{type}}) {
896 $current_type = $get_type->();
897 if (defined $current_type) {
898 # next token
899 $state = 'before exception member identifier';
900 } else {
901 # reconsume
902 $state = 'ignore';
903 $nest_level = 0;
904 $next_state = 'before exception member';
905 }
906 #} else {
907 # $onerror->(type => 'before webidl type:exception member',
908 # level => $self->{level}->{must});
909 # # reconsume
910 # $state = 'ignore';
911 # $nest_level = 0;
912 # $next_state = 'before exception member';
913 #}
914 } elsif ($state eq 'before operation type') {
915 #if ({
916 # any => 1, boolean => 1, octet => 1, float => 1,
917 # DOMString => 1, Object => 1, short => 1, long => 1, unsigned => 1,
918 # '::' => 1, identifier => 1,
919 # void => 1,
920 #}->{$token->{type}}) {
921 $current_type = $get_type->();
922 if (defined $current_type) {
923 # next token
924 $state = 'before operation identifier';
925 } else {
926 # reconsume
927 $state = 'ignore';
928 $nest_level = 0;
929 $next_state = 'before interface member';
930 }
931 #} else {
932 # $onerror->(type => 'before webidl type',
933 # text => 'operation',
934 # level => $self->{level}->{must});
935 # # reconsume
936 # $state = 'ignore';
937 # $nest_level = 0;
938 # $next_state = 'before interface member';
939 #}
940 } elsif ($state eq 'before argument type') {
941 if ({
942 any => 1, boolean => 1, octet => 1, float => 1,
943 DOMString => 1, Object => 1, short => 1, long => 1, unsigned => 1,
944 '::' => 1, identifier => 1,
945 }->{$token->{type}}) {
946 $current_type = $get_type->();
947 if (defined $current_type) {
948 # next token
949 $state = 'before argument identifier';
950 } else {
951 # reconsume
952 $state = 'ignore';
953 $nest_level = 0;
954 }
955 } else {
956 $onerror->(type => 'before webidl type:argument',
957 level => $self->{level}->{must});
958 # reconsume
959 $state = 'ignore';
960 $nest_level = 0;
961 }
962 } elsif ($state eq 'before attribute identifier') {
963 if ($token->{type} eq 'identifier') {
964 my $identifier = $token->{value};
965 $identifier =~ s/^_//;
966 push @current, Whatpm::WebIDL::Attribute->new ($identifier);
967 $current[-1]->set_user_data (manakai_source_line => $line);
968 $current[-1]->set_user_data (manakai_source_column => $column);
969 $current[-1]->readonly ($read_only);
970 $current[-1]->type ($current_type);
971 $current[-1]->set_extended_attribute_node ($_) for @$xattrs;
972 $token = $get_next_token->();
973 if ($token->{type} eq 'getraises') {
974 $token = $get_next_token->();
975 $state = 'after raises';
976 $next_state = '*getraises';
977 next;
978 } elsif ($token->{type} eq 'setraises') {
979 $token = $get_next_token->();
980 $state = 'after raises';
981 $next_state = '*setraises';
982 next;
983 } else {
984 # reconsume
985 $state = 'before semicolon';
986 $next_state = 'before interface member';
987 next;
988 }
989 } else {
990 $onerror->(type => 'no webidl identifier',
991 text => 'attribute',
992 level => $self->{level}->{must});
993 #
994 }
995 # reconsume
996 $state = 'ignore';
997 $nest_level = 0;
998 $next_state = 'before interface member';
999 } elsif ($state eq 'before exception member identifier') {
1000 if ($token->{type} eq 'identifier') {
1001 my $identifier = $token->{value};
1002 $identifier =~ s/^_//;
1003 push @current, Whatpm::WebIDL::ExceptionMember->new ($identifier);
1004 $current[-1]->set_user_data (manakai_source_line => $line);
1005 $current[-1]->set_user_data (manakai_source_column => $column);
1006 $current[-1]->type ($current_type);
1007 $current[-1]->set_extended_attribute_node ($_) for @$xattrs;
1008 $token = $get_next_token->();
1009 $state = 'before semicolon';
1010 $next_state = 'before exception member';
1011 } else {
1012 $onerror->(type => 'no webidl identifier:exception member',
1013 level => $self->{level}->{must});
1014 # reconsume
1015 $state = 'ignore';
1016 $nest_level = 0;
1017 }
1018 } elsif ($state eq 'before operation identifier') {
1019 if ($token->{type} eq 'identifier') {
1020 ## TODO: unescape
1021 push @current, Whatpm::WebIDL::Operation->new ($token->{value});
1022 $current[-1]->set_user_data (manakai_source_line => $line);
1023 $current[-1]->set_user_data (manakai_source_column => $column);
1024 $current[-1]->type ($current_type);
1025 $current[-1]->set_extended_attribute_node ($_) for @$xattrs;
1026 $token = $get_next_token->();
1027 if ($token->{type} eq '(') {
1028 $token = $get_next_token->();
1029 if ($token->{type} eq ')') {
1030 $token = $get_next_token->();
1031 $state = 'before raises';
1032 $next_state = '*raises';
1033 next;
1034 } else {
1035 # reconsume
1036 $state = 'before argument';
1037 next;
1038 }
1039 } else {
1040 $onerror->(type => 'no arguments lparen',
1041 level => $self->{level}->{must});
1042 #
1043 }
1044 } else {
1045 $onerror->(type => 'no webidl identifier:operation',
1046 level => $self->{level}->{must});
1047 #
1048 }
1049 # reconsume
1050 $state = 'ignore';
1051 $nest_level = 0;
1052 $next_state = 'before interface member';
1053 } elsif ($state eq 'before argument identifier') {
1054 if ($token->{type} eq 'identifier') {
1055 my $id = $token->{value};
1056 $id =~ s/^_//;
1057 my $arg = Whatpm::WebIDL::Argument->new ($id);
1058 $arg->set_user_data (manakai_source_line => $line);
1059 $arg->set_user_data (manakai_source_column => $column);
1060 $arg->type ($current_type);
1061 $arg->set_extended_attribute_node ($_) for @$xattrs;
1062 $current[-1]->append_child ($arg);
1063 $token = $get_next_token->();
1064 if ($token->{type} eq ')') {
1065 $token = $get_next_token->();
1066 if ($current[-1]->isa ('Whatpm::WebIDL::Operation')) {
1067 $state = 'before raises';
1068 } else {
1069 $state = 'after xattrarg';
1070 }
1071 next;
1072 } elsif ($token->{type} eq ',') {
1073 $token = $get_next_token->();
1074 $state = 'before argument';
1075 next;
1076 } else {
1077 $onerror->(type => 'after argument',
1078 level => $self->{level}->{must});
1079 #
1080 }
1081 } else {
1082 $onerror->(type => 'no webidl identifier:argument',
1083 level => $self->{level}->{must});
1084 #
1085 }
1086 # reconsume
1087 $state = 'ignore';
1088 $nest_level = 0;
1089 } elsif ($state eq 'before argument') {
1090 $xattrs = [];
1091 if ($token->{type} eq '[') {
1092 $token = $get_next_token->();
1093 $state = 'before xattr';
1094 $next_state = 'before argument in';
1095 } else {
1096 # reconsume
1097 $state = 'before argument in';
1098 }
1099 } elsif ($state eq 'before argument in') {
1100 if ($token->{type} eq 'in') {
1101 $token = $get_next_token->();
1102 $state = 'before argument type';
1103 } else {
1104 $onerror->(type => 'no argument in',
1105 level => $self->{level}->{must});
1106 $state = 'ignore';
1107 $nest_level = 0;
1108 }
1109 } elsif ($state eq 'before raises') {
1110 if ($token->{type} eq 'raises') {
1111 $token = $get_next_token->();
1112 $state = 'after raises';
1113 $next_state = '*raises';
1114 } else {
1115 # reconsume
1116 $state = 'before semicolon';
1117 $next_state = 'before interface member';
1118 }
1119 } elsif ($state eq 'after raises') {
1120 if ($token->{type} eq '(') {
1121 $token = $get_next_token->();
1122 $state = 'before exception name';
1123 } else {
1124 $onerror->(type => 'no raises lparen',
1125 level => $self->{level}->{must});
1126 $state = 'ignore';
1127 $nest_level = 0;
1128 }
1129 } elsif ($state eq 'before semicolon') {
1130 if ($token->{type} eq ';') {
1131 $current[-2]->append_child ($current[-1]);
1132 pop @current;
1133 $token = $get_next_token->();
1134 if ($current[-1]->isa ('Whatpm::WebIDL::Definitions') or
1135 $current[-1]->isa ('Whatpm::WebIDL::Module')) {
1136 $state = 'before definitions';
1137 } elsif ($current[-1]->isa ('Whatpm::WebIDL::Interface')) {
1138 $state = 'before members';
1139 $next_state = 'before interface member';
1140 } else {
1141 $state = 'before members';
1142 $next_state = 'before exception member';
1143 }
1144 } else {
1145 $onerror->(type => 'no webidl semicolon',
1146 level => $self->{level}->{must});
1147 # reconsume
1148 $state = 'ignore';
1149 $nest_level = 0;
1150 }
1151 } elsif ($state eq 'before block semicolon') {
1152 if ($token->{type} eq ';') {
1153 $current[-2]->append_child ($current[-1]);
1154 pop @current;
1155 $token = $get_next_token->();
1156 if ($current[-1]->isa ('Whatpm::WebIDL::Definitions') or
1157 $current[-1]->isa ('Whatpm::WebIDL::Module')) {
1158 $state = 'before definitions';
1159 } elsif ($current[-1]->isa ('Whatpm::WebIDL::Interface')) {
1160 $state = 'before members';
1161 $next_state = 'before interface member';
1162 } else {
1163 $state = 'before members';
1164 $next_state = 'before exception member';
1165 }
1166 } else {
1167 $onerror->(type => 'no webidl semicolon',
1168 level => $self->{level}->{must});
1169 pop @current; # avoid appended by 'ignore'
1170 # reconsume
1171 $state = 'ignore';
1172 $nest_level = 0;
1173 }
1174 } elsif ($state eq 'ignore') {
1175 if ($nest_level == 0 and $token->{type} eq ';') {
1176 while (@current > 1) {
1177 if ($current[-1]->isa ('Whatpm::WebIDL::Interface') or
1178 $current[-1]->isa ('Whatpm::WebIDL::Exception') or
1179 $current[-1]->isa ('Whatpm::WebIDL::Module')) {
1180 last;
1181 }
1182 pop @current;
1183 }
1184
1185 $token = $get_next_token->();
1186 if ($current[-1]->isa ('Whatpm::WebIDL::Definitions') or
1187 $current[-1]->isa ('Whatpm::WebIDL::Module')) {
1188 $state = 'before definitions';
1189 } elsif ($current[-1]->isa ('Whatpm::WebIDL::Interface')) {
1190 $state = 'before members';
1191 $next_state = 'before interface member';
1192 } else {
1193 $state = 'before members';
1194 $next_state = 'before exception member';
1195 }
1196 } elsif ($token->{type} eq '{') {
1197 $nest_level++;
1198 $token = $get_next_token->();
1199 # stay in the state
1200 } elsif ($nest_level and $token->{type} eq '}') {
1201 $nest_level--;
1202 $token = $get_next_token->();
1203 # stay in the state
1204 } elsif ($token->{type} eq 'eof') {
1205 while (@current > 1) {
1206 if ($current[-1]->isa ('Whatpm::WebIDL::Interface') or
1207 $current[-1]->isa ('Whatpm::WebIDL::Exception') or
1208 $current[-1]->isa ('Whatpm::WebIDL::Module')) {
1209 last;
1210 }
1211 pop @current;
1212 }
1213
1214 last;
1215 } else {
1216 # ignore the token
1217 $token = $get_next_token->();
1218 # stay in the state
1219 }
1220 } else {
1221 die "parse_char_string: unkown state: $state";
1222 }
1223 }
1224
1225 if (@current > 1) {
1226 $onerror->(type => 'premature end of webidl',
1227 level => $self->{level}->{must});
1228 while (@current > 1) {
1229 $current[-2]->append_child ($current[-1]);
1230 pop @current;
1231 }
1232 }
1233
1234 $get_type = undef; # unlink loop
1235
1236 return $defs;
1237 } # parse_char_string
1238
1239 package Whatpm::WebIDL::Node;
1240
1241 require Scalar::Util;
1242
1243 sub new ($) {
1244 return bless {child_nodes => []}, $_[0];
1245 } # new
1246
1247 sub append_child ($$) {
1248 my $self = shift;
1249 my $child = shift;
1250
1251 ## TODO: child type
1252 ## TODO: parent check
1253
1254 push @{$self->{child_nodes}}, $child;
1255
1256 $child->{parent_node} = $self;
1257 Scalar::Util::weaken ($child->{parent_node});
1258
1259 return $child;
1260 } # append_child
1261
1262 sub child_nodes ($) {
1263 return [@{$_[0]->{child_nodes}}]; # dead list
1264 } # child_nodes
1265
1266 sub idl_text ($) {
1267 return '[[ERROR: ' . (ref $_[0]) . '->idl_text]]';
1268 } # idl_text
1269
1270 sub node_name ($) {
1271 return $_[0]->{node_name}; # may be undef
1272 } # node_name
1273
1274 sub parent_node ($) {
1275 return $_[0]->{parent_node};
1276 } # parent_node
1277
1278 sub get_user_data ($$) {
1279 return $_[0]->{user_data}->{$_[1]};
1280 } # get_user_data
1281
1282 sub set_user_data ($$$) {
1283 if (defined $_[2]) {
1284 $_[0]->{user_data}->{$_[1]} = ''.$_[2];
1285 } else {
1286 delete $_[0]->{user_data}->{$_[1]};
1287 }
1288 } # set_user_data
1289
1290 package Whatpm::WebIDL::Definitions;
1291 push our @ISA, 'Whatpm::WebIDL::Node';
1292
1293 sub idl_text ($) {
1294 return join "\x0A", map {$_->idl_text} @{$_[0]->{child_nodes}};
1295 } # idl_text
1296
1297 my $xattr_defs = {
1298 Constructor => {
1299 #allow_id => 0,
1300 allow_arglist => 1,
1301 allowed_type => {Interface => 1},
1302 allow_multiple => 1,
1303 check => sub {
1304 my ($self, $onerror, $levels, $items, $item, $xattr, $xattr_name,
1305 $resolve, $constructors) = @_;
1306
1307 ## NOTE: Arguments
1308 unshift @$items,
1309 map { {node => $_, scope => $item->{scope}} }
1310 @{$xattr->{child_nodes}};
1311 },
1312 },
1313 ExceptionConsts => {
1314 allow_id => 1,
1315 #allow_arglist => 0,
1316 allowed_type => {Module => 1},
1317 #allow_multiple => 0,
1318 check => sub {
1319 my ($self, $onerror, $levels, $items, $item, $xattr, $xattr_name,
1320 $resolve, $constructors) = @_;
1321
1322 my $id = $xattr->value;
1323 if (defined $id) {
1324 my $has_x;
1325 for my $x (@{$item->{node}->child_nodes}) {
1326 next unless $x->isa ('Whatpm::WebIDL::Exception');
1327 if ($x->node_name eq $id) {
1328 $has_x = 1;
1329 last;
1330 }
1331 }
1332 unless ($has_x) {
1333 $onerror->(type => 'exception not defined',
1334 text => $id,
1335 node => $xattr,
1336 level => $levels->{must});
1337 }
1338 } else {
1339 $onerror->(type => 'xattr id missing',
1340 text => $xattr_name,
1341 node => $xattr,
1342 level => $levels->{must});
1343 }
1344 },
1345 },
1346 IndexGetter => {
1347 #allow_id => 0,
1348 #allow_arglist => 0,
1349 allowed_type => {Operation => 1},
1350 #allow_multiple => 0,
1351 check => sub {
1352 my ($self, $onerror, $levels, $items, $item, $xattr, $xattr_name,
1353 $resolve, $constructors) = @_;
1354
1355 if (@{$item->{node}->{child_nodes}} != 1 or
1356 $item->{node}->{child_nodes}->[0]->type_text ne 'unsigned long') {
1357 $onerror->(type => 'wrong signature accessor',
1358 text => $xattr_name,
1359 node => $xattr,
1360 level => $levels->{fact});
1361 }
1362 if ($item->{defined_accessors}->{$xattr_name} and
1363 $item->{defined_accessors}->{$xattr_name} ne $item->{node}) {
1364 $onerror->(type => 'duplicate accessor',
1365 text => $xattr_name,
1366 node => $xattr,
1367 level => $levels->{undefined});
1368 }
1369 $item->{defined_accessors}->{$xattr_name} = $item->{node};
1370 },
1371 },
1372 IndexSetter => {
1373 #allow_id => 0,
1374 #allow_arglist => 0,
1375 allowed_type => {Operation => 1},
1376 #allow_multiple => 0,
1377 check => sub {
1378 my ($self, $onerror, $levels, $items, $item, $xattr, $xattr_name,
1379 $resolve, $constructors) = @_;
1380
1381 if (@{$item->{node}->{child_nodes}} != 2 or
1382 $item->{node}->{child_nodes}->[0]->type_text ne 'unsigned long') {
1383 $onerror->(type => 'wrong signature accessor',
1384 text => $xattr_name,
1385 node => $xattr,
1386 level => $levels->{fact});
1387 }
1388 if ($item->{defined_accessors}->{$xattr_name} and
1389 $item->{defined_accessors}->{$xattr_name} ne $item->{node}) {
1390 $onerror->(type => 'duplicate accessor',
1391 text => $xattr_name,
1392 node => $xattr,
1393 level => $levels->{undefined});
1394 }
1395 $item->{defined_accessors}->{$xattr_name} = $item->{node};
1396 },
1397 },
1398 NameGetter => {
1399 #allow_id => 0,
1400 #allow_arglist => 0,
1401 allowed_type => {Operation => 1},
1402 #allow_multiple => 0,
1403 check => sub {
1404 my ($self, $onerror, $levels, $items, $item, $xattr, $xattr_name,
1405 $resolve, $constructors) = @_;
1406
1407 if (@{$item->{node}->{child_nodes}} != 1 or
1408 $item->{node}->{child_nodes}->[0]->type_text ne 'DOMString') {
1409 $onerror->(type => 'wrong signature accessor',
1410 text => $xattr_name,
1411 node => $xattr,
1412 level => $levels->{fact});
1413 }
1414 if ($item->{defined_accessors}->{$xattr_name} and
1415 $item->{defined_accessors}->{$xattr_name} ne $item->{node}) {
1416 $onerror->(type => 'duplicate accessor',
1417 text => $xattr_name,
1418 node => $xattr,
1419 level => $levels->{undefined});
1420 }
1421 $item->{defined_accessors}->{$xattr_name} = $item->{node};
1422 },
1423 },
1424 NameSetter => {
1425 #allow_id => 0,
1426 #allow_arglist => 0,
1427 allowed_type => {Operation => 1},
1428 #allow_multiple => 0,
1429 check => sub {
1430 my ($self, $onerror, $levels, $items, $item, $xattr, $xattr_name,
1431 $resolve, $constructors) = @_;
1432
1433 if (@{$item->{node}->{child_nodes}} != 2 or
1434 $item->{node}->{child_nodes}->[0]->type ne '::DOMString::') {
1435 $onerror->(type => 'wrong signature accessor',
1436 text => $xattr_name,
1437 node => $xattr,
1438 level => $levels->{fact});
1439 }
1440 if ($item->{defined_accessors}->{$xattr_name} and
1441 $item->{defined_accessors}->{$xattr_name} ne $item->{node}) {
1442 $onerror->(type => 'duplicate accessor',
1443 text => $xattr_name,
1444 node => $xattr,
1445 level => $levels->{undefined});
1446 }
1447 $item->{defined_accessors}->{$xattr_name} = $item->{node};
1448 },
1449 },
1450 Null => {
1451 allow_id => 1,
1452 #allow_arglist => 0,
1453 allowed_type => {Argument => 1, Attribute => 1},
1454 ## ISSUE: Is this allwoed for extended attribute's arguments?
1455 #allow_multiple => 0,
1456 check => sub {
1457 my ($self, $onerror, $levels, $items, $item, $xattr, $xattr_name,
1458 $resolve, $constructors) = @_;
1459
1460 ## ISSUE: [Null=Empty] readonly attribute is not disallowed
1461
1462 if ($item->{node}->type ne '::DOMString::') {
1463 $onerror->(type => 'xattr for wrong type',
1464 text => $xattr_name,
1465 node => $xattr,
1466 level => $levels->{fact});
1467 }
1468
1469 my $id = $xattr->value;
1470 if (defined $id) {
1471 if ($id eq 'Null' or $id eq 'Empty') {
1472 #
1473 } else {
1474 $onerror->(type => 'xattr id value not allowed',
1475 text => $xattr_name,
1476 value => $id,
1477 node => $xattr,
1478 level => $levels->{must});
1479 }
1480 } else {
1481 $onerror->(type => 'xattr id missing',
1482 text => $xattr_name,
1483 node => $xattr,
1484 level => $levels->{must});
1485 }
1486 },
1487 },
1488 PutForwards => {
1489 allow_id => 1,
1490 #allow_arglist => 0,
1491 allowed_type => {Attribute => 1},
1492 #allow_multiple => 0,
1493 check => sub {
1494 my ($self, $onerror, $levels, $items, $item, $xattr, $xattr_name,
1495 $resolve, $constructors) = @_;
1496
1497 ## NOTE: Direct or indirect cirlic reference is not an error.
1498
1499 unless ($item->{node}->readonly) {
1500 $onerror->(type => 'attr not readonly',
1501 text => $xattr_name,
1502 node => $xattr,
1503 level => $levels->{fact});
1504 }
1505
1506 my $type_item = $resolve->($item->{node}->type, $item->{scope});
1507 if ($type_item and
1508 $type_item->{node}->isa ('Whatpm::WebIDL::Interface')) {
1509 my $id = $xattr->value;
1510 if (defined $id) {
1511 ## ISSUE: "attribute that exists on the interface and which
1512 ## has the same type as this attribute.": "same type"?
1513 ## ISSUE: must be read-write attribute?
1514
1515 my $check = sub ($) {
1516 my $type_item = shift;
1517
1518 A: {
1519 for my $attr (@{$type_item->{node}->{child_nodes}}) {
1520 next unless $attr->isa ('Whatpm::WebIDL::Attribute');
1521 if ($attr->node_name eq $id) {
1522 last A;
1523 }
1524 }
1525
1526 $onerror->(type => 'referenced attr not defined',
1527 text => $xattr_name,
1528 value => $id,
1529 node => $xattr,
1530 level => $levels->{must});
1531 } # A
1532 }; # $check
1533
1534 if ($type_item->{node}->is_forward_declaration) {
1535 ## NOTE: Checked later.
1536 push @$items, {code => sub {
1537 $check->($resolve->($item->{node}->type, $item->{scope}));
1538 }};
1539 } else {
1540 $check->($type_item);
1541 }
1542 } else {
1543 $onerror->(type => 'xattr id missing',
1544 text => $xattr_name,
1545 node => $xattr,
1546 level => $levels->{must});
1547 }
1548 } else {
1549 ## NOTE: Builtin types, or undefined interface
1550 $onerror->(type => 'attr type not interface',
1551 text => $xattr_name,
1552 node => $xattr,
1553 level => $levels->{fact});
1554 }
1555 },
1556 },
1557 Stringifies => {
1558 allow_id => 1,
1559 #allow_arglist => 0,
1560 allowed_type => {Interface => 1},
1561 #allow_multiple => 0,
1562 check => sub {
1563 my ($self, $onerror, $levels, $items, $item, $xattr, $xattr_name,
1564 $resolve, $constructors) = @_;
1565
1566 my $id = $xattr->value;
1567 if (defined $id) {
1568 A: {
1569 for my $attr (@{$item->{node}->{child_nodes}}) {
1570 next unless $attr->isa ('Whatpm::WebIDL::Attribute');
1571 if ($attr->node_name eq $id) {
1572 last A;
1573 }
1574 }
1575
1576 $onerror->(type => 'referenced attr not defined',
1577 text => $xattr_name,
1578 value => $id,
1579 node => $xattr,
1580 level => $levels->{must});
1581 } # A
1582 }
1583 },
1584 },
1585 Variadic => {
1586 #allow_id => 0,
1587 #allow_arglist => 0,
1588 allowed_type => {Argument => 1},
1589 #allow_multiple => 0,
1590 check => sub {
1591 my ($self, $onerror, $levels, $items, $item, $xattr, $xattr_name,
1592 $resolve, $constructors) = @_;
1593
1594 ## ISSUE: is this allowed on extended attribute arguuments?
1595
1596 ## NOTE: If this is not the final argument, then an error will
1597 ## be raised later.
1598 $item->{has_arg_xattr}->{variadic} = 1;
1599 },
1600 },
1601
1602 ## ECMAScript specific extended attributes
1603 NamedConstructor => {
1604 allow_id => 1,
1605 allow_arglist => 1,
1606 allowed_type => {Interface => 1, Exception => 1},
1607 allow_multiple => 1,
1608 check => sub {
1609 my ($self, $onerror, $levels, $items, $item, $xattr, $xattr_name,
1610 $resolve, $constructors) = @_;
1611
1612 ## NOTE: [NamedConstructor=a,NamedConstructor=a] is not disallowed.
1613
1614 my $id = $xattr->value;
1615 if (defined $id) {
1616 if ($constructors->{$id} and
1617 $constructors->{$id}->{node} ne $item->{node}) {
1618 $onerror->(type => 'duplicate constructor name',
1619 value => $id,
1620 node => $xattr,
1621 level => $levels->{must});
1622 } else {
1623 $constructors->{$id} = {node => $item->{node},
1624 is_named_constructor => $xattr};
1625 }
1626 } else {
1627 $onerror->(type => 'xattr id missing',
1628 text => $xattr_name,
1629 node => $xattr,
1630 level => $levels->{must});
1631 }
1632 },
1633 },
1634 NativeObject => {
1635 allow_id => 1,
1636 #allow_arglist => 0,
1637 allowed_type => {Interface => 1},
1638 #allow_multiple => 0,
1639 check => sub {
1640 my ($self, $onerror, $levels, $items, $item, $xattr, $xattr_name,
1641 $resolve, $constructors) = @_;
1642
1643 my $id = $xattr->value;
1644 if (defined $id and $id ne 'FunctionOnly') {
1645 $onerror->(type => 'xattr id value not allowed',
1646 text => $xattr_name,
1647 value => $id,
1648 node => $xattr,
1649 level => $levels->{must});
1650 }
1651
1652 ## TODO: We should warn if the condition in the section 4.5 is not met.
1653 },
1654 },
1655 NoInterfaceObject => {
1656 #allow_id => 0,
1657 #allow_arglist => 0,
1658 allowed_type => {Interface => 1, Exception => 1},
1659 #allow_multiple => 0,
1660 check => sub {
1661 my ($self, $onerror, $levels, $items, $item, $xattr, $xattr_name,
1662 $resolve, $constructors) = @_;
1663
1664 ## ISSUE: [Constructor, NoInterfaceObject]
1665 },
1666 },
1667 Undefined => {
1668 allow_id => 1,
1669 #allow_arglist => 0,
1670 allowed_type => {Argument => 1, Attribute => 1},
1671 ## ISSUE: Is this allwoed for extended attribute's arguments?
1672 #allow_multiple => 0,
1673 #check : is set later
1674 },
1675 }; # $xattr_defs
1676 $xattr_defs->{Undefined}->{check} = $xattr_defs->{Null}->{check};
1677
1678 sub check ($$;$) {
1679 my ($self, $onerror, $levels) = @_;
1680
1681 $levels ||= $default_levels;
1682
1683 my $check_const_value = sub ($) {
1684 my $item = shift;
1685
1686 my $type = $item->{node}->type;
1687 my $value = $item->{node}->value;
1688
1689 ## NOTE: Although it is not explicitly spelled out in the spec,
1690 ## it can be assumed, imho, that "any" type accepts all of these
1691 ## constant values.
1692 ## ISSUE: Should I ask the editor to clarify the spec about this?
1693
1694 if ($value->[0] eq 'TRUE' or $value->[0] eq 'FALSE') {
1695 if ($type eq '::boolean::') {
1696 #
1697 } elsif ($type eq '::any::') {
1698 #
1699 } else {
1700 $onerror->(type => 'const type mismatch',
1701 node => $item->{node},
1702 text => $item->{node}->type_text,
1703 value => $value->[0],
1704 level => $levels->{must});
1705 }
1706 } elsif ($value->[0] eq 'integer') {
1707 if ($type eq '::octet::') {
1708 if ($value->[1] < 0 or 255 < $value->[1]) {
1709 $onerror->(type => 'const value out of range',
1710 text => $item->{node}->type_text,
1711 value => $value->[1],
1712 node => $item->{node},
1713 level => $levels->{must});
1714 }
1715 } elsif ($type eq '::short::') {
1716 if ($value->[1] < -32768 or 32767 < $value->[1]) {
1717 $onerror->(type => 'const value out of range',
1718 text => $item->{node}->type_text,
1719 value => $value->[1],
1720 node => $item->{node},
1721 level => $levels->{must});
1722 }
1723 } elsif ($type eq '::unsigned short::') {
1724 if ($value->[1] < 0 or 65535 < $value->[1]) {
1725 $onerror->(type => 'const value out of range',
1726 text => $item->{node}->type_text,
1727 value => $value->[1],
1728 node => $item->{node},
1729 level => $levels->{must});
1730 }
1731 } elsif ($type eq '::long::') {
1732 if ($value->[1] < -2147483648 or 2147483647 < $value->[1]) {
1733 $onerror->(type => 'const value out of range',
1734 text => $item->{node}->type_text,
1735 value => $value->[1],
1736 node => $item->{node},
1737 level => $levels->{must});
1738 }
1739 } elsif ($type eq '::unsigned long::') {
1740 if ($value->[1] < 0 or 4294967295 < $value->[1]) {
1741 $onerror->(type => 'const value out of range',
1742 text => $item->{node}->type_text,
1743 value => $value->[1],
1744 node => $item->{node},
1745 level => $levels->{must});
1746 }
1747 } elsif ($type eq '::long long::') {
1748 if ($value->[1] < -9223372036854775808 or
1749 9223372036854775807 < $value->[1]) {
1750 $onerror->(type => 'const value out of range',
1751 text => $item->{node}->type_text,
1752 value => $value->[1],
1753 node => $item->{node},
1754 level => $levels->{must});
1755 }
1756 } elsif ($type eq '::unsigned long long::') {
1757 if ($value->[1] < 0 or 18446744073709551615 < $value->[1]) {
1758 $onerror->(type => 'const value out of range',
1759 text => $item->{node}->type_text,
1760 value => $value->[1],
1761 node => $item->{node},
1762 level => $levels->{must});
1763 }
1764 } elsif ($type eq '::any::') {
1765 if ($value->[1] < -9223372036854775808 or
1766 18446744073709551615 < $value->[1]) {
1767 $onerror->(type => 'const value out of range',
1768 text => $item->{node}->type_text,
1769 value => $value->[1],
1770 node => $item->{node},
1771 level => $levels->{must});
1772 }
1773 } else {
1774 $onerror->(type => 'const type mismatch',
1775 text => $item->{node}->type_text,
1776 value => $value->[1],
1777 node => $item->{node},
1778 level => $levels->{must});
1779 }
1780 } elsif ($value->[0] eq 'float') {
1781 if ($type eq '::float::' or $type eq '::any::') {
1782 #
1783 } else {
1784 $onerror->(type => 'const type mismatch',
1785 text => $item->{node}->type_text,
1786 value => $value->[1],
1787 node => $item->{node},
1788 level => $levels->{must});
1789 }
1790 }
1791 ## NOTE: Otherwise, an error of the implementation or the application.
1792 }; # $check_const_value
1793
1794 my $defined_qnames = {};
1795 my $resolve = sub ($$) {
1796 my $i_sn = shift;
1797 my $scope = shift;
1798
1799 if ($i_sn =~ /\A::(?>[^:]+)::\z/ or
1800 $i_sn =~ /^::::sequence::::/) {
1801 return undef;
1802 } elsif ($i_sn =~ /::DOMString\z/ or
1803 $i_sn =~ /::DOMString::::\z/) {
1804 return undef;
1805 } elsif ($i_sn =~ /^::/) {
1806 if ($defined_qnames->{$i_sn}) {
1807 return $defined_qnames->{$i_sn};
1808 } else {
1809 return undef;
1810 }
1811 } else {
1812 if ($defined_qnames->{$scope . $i_sn}) {
1813 return $defined_qnames->{$scope . $i_sn};
1814 } elsif ($defined_qnames->{'::' . $i_sn}) {
1815 return $defined_qnames->{'::' . $i_sn};
1816 } else {
1817 return undef;
1818 }
1819 }
1820 }; # $resolve
1821
1822 my $items = [map { {node => $_, scope => '::'} } @{$self->{child_nodes}}];
1823
1824 my $constructors = {};
1825 ## NOTE: Items are: identifier => {node => $interface_or_exception,
1826 ## is_named_constructor => $named_constructor_xattr/undef}.
1827
1828 while (@$items) {
1829 my $item = shift @$items;
1830 if (not $item->{node}) {
1831 $item->{code}->();
1832 next;
1833 } elsif ($item->{node}->isa ('Whatpm::WebIDL::Definition') and
1834 not $item->{defined_members}) {
1835 ## NOTE: Const in Interface does not have this.
1836 if ($item->{node}->isa ('Whatpm::WebIDL::Module')) {
1837 unshift @$items,
1838 map {
1839 {node => $_, parent => $item->{node},
1840 scope => $item->{scope} . $item->{node}->node_name . '::'}
1841 }
1842 @{$item->{node}->{child_nodes}};
1843 } else {
1844 unless ($item->{parent}) {
1845 $onerror->(type => 'non-module definition',
1846 node => $item->{node},
1847 level => $levels->{should});
1848 }
1849 }
1850
1851 if ($item->{node}->isa ('Whatpm::WebIDL::Interface')) {
1852 for my $i_sn (@{$item->{node}->{inheritances}}) {
1853 my $def = $resolve->($i_sn, $item->{scope});
1854
1855 unless ($def and $def->{node}->isa ('Whatpm::WebIDL::Interface')) {
1856 $i_sn =~ s/::DOMString::::\z/::DOMString/;
1857 $onerror->(type => 'interface not defined',
1858 node => $item->{node},
1859 text => $i_sn,
1860 level => $levels->{must});
1861 }
1862 }
1863
1864 my $defined_members = {};
1865 my $defined_accessors = {};
1866 unshift @$items,
1867 map { {node => $_, defined_members => $defined_members,
1868 defined_accessors => $defined_accessors,
1869 scope => $item->{scope}} }
1870 @{$item->{node}->{child_nodes}};
1871 } elsif ($item->{node}->isa ('Whatpm::WebIDL::Exception')) {
1872 my $defined_members = {};
1873 unshift @$items,
1874 map { {node => $_, defined_members => $defined_members,
1875 scope => $item->{scope}} }
1876 @{$item->{node}->{child_nodes}};
1877 } elsif ($item->{node}->isa ('Whatpm::WebIDL::Const')) {
1878 $check_const_value->($item);
1879 } elsif ($item->{node}->isa ('Whatpm::WebIDL::Typedef')) {
1880 my $name = $item->{node}->node_name;
1881 my $type = $item->{node}->type;
1882 if ($name eq '::DOMString::' or
1883 $type eq '::DOMString::' or
1884 $type =~ /::DOMString::::\z/) {
1885 $onerror->(type => 'typedef ignored',
1886 node => $item->{node},
1887 level => $levels->{info});
1888 }
1889 ## ISSUE: Refernece to a non-defined interface is not non-conforming.
1890
1891 ## ISSUE: What does "ignored" mean?
1892 ## "typedef dom::DOMString a; typedef long a;" is conforming?
1893 ## "typedef dom::DOMString b; interface c { attribute b d; };" is?
1894
1895 ## ISSUE: Is "sequence<undefinedtype>" conforming?
1896
1897 if ($type =~ /\A::([^:]+)::\z/) {
1898 $item->{allow_null} = {
1899 boolean => 1, octet => 1, short => 1, 'unsigned short' => 1,
1900 long => 1, 'unsigned long' => 1, 'long long' => 1,
1901 'unsigned long long' => 1, float => 1,
1902 }->{$1};
1903 } elsif ($type =~ /^::::sequence::::/) {
1904 $item->{allow_null} = 1;
1905 } else {
1906 my $def = $resolve->($type, $item->{scope});
1907 $item->{allow_null} = $def->{allow_null};
1908 }
1909 } elsif ($item->{node}->isa ('Whatpm::WebIDL::Valuetype')) {
1910 my $name = $item->{node}->node_name;
1911 if ($name eq '::DOMString::') {
1912 $onerror->(type => 'valuetype ignored',
1913 node => $item->{node},
1914 level => $levels->{info});
1915 } else {
1916 my $type = $item->{node}->type;
1917 if ($type =~ /\A::[^:]+::\z/) {
1918 #
1919 } elsif ($type =~ /^::::sequence::::/) {
1920 ## ISSUE: Is "sequence<unknowntype>" conforming?
1921 } else {
1922 my $def = $resolve->($type, $item->{scope});
1923 if ($def and
1924 $def->{allow_null}) {
1925 #
1926 } else {
1927 ## ISSUE: It is not explicitly specified that ScopedName
1928 ## must refer a defined type.
1929 $onerror->(type => 'not boxable type',
1930 text => $item->{node}->type_text,
1931 node => $item->{node},
1932 level => $levels->{must});
1933 }
1934 }
1935 }
1936 }
1937
1938 my $qname = $item->{node}->qualified_name;
1939 if ($defined_qnames->{$qname}) {
1940 ## NOTE: "The identifier of a definition MUST be locally unique":
1941 ## Redundant with another requirement below.
1942
1943 ## ISSUE: |interface x; interface x {};| is non-conforming
1944 ## according to the current spec text.
1945
1946 ## ISSUE: |interface x;| with no |interface x {};| is conforming
1947 ## according to the current spec text.
1948
1949 ## ISSUE: |interface x; exception x {}|
1950
1951 $onerror->(type => 'duplicate qname',
1952 node => $item->{node},
1953 level => $levels->{must},
1954 text => $qname);
1955
1956 if ($item->{node}->isa ('Whatpm::WebIDL::Interface') and
1957 $defined_qnames->{$qname}->{node}->isa
1958 ('Whatpm::WebIDL::Interface') and
1959 $defined_qnames->{$qname}->{node}->is_forward_declaration) {
1960 $defined_qnames->{$qname} = $item;
1961 }
1962 } else {
1963 $defined_qnames->{$qname} = $item;
1964 ## NOTE: This flag must be turned on AFTER inheritance check is
1965 ## performed (c.f. |interface x : x {};|).
1966 }
1967 } elsif ($item->{node}->isa ('Whatpm::WebIDL::InterfaceMember')) {
1968 if ($item->{node}->isa ('Whatpm::WebIDL::Operation')) {
1969 ## NOTE: Arguments
1970 my $has_arg_xattr = {};
1971 unshift @$items,
1972 map { {node => $_, scope => $item->{scope},
1973 has_arg_xattr => $has_arg_xattr} }
1974 @{$item->{node}->{child_nodes}};
1975 } else {
1976 my $name = $item->{node}->node_name;
1977 if ($item->{defined_members}->{$name}) {
1978 $onerror->(type => 'duplicate member',
1979 node => $item->{node},
1980 text => $name,
1981 level => $levels->{must});
1982 ## ISSUE: Whether the example below is conforming or not
1983 ## is ambigious:
1984 ## |interface a { attribute any b; any b (); };|
1985 } else {
1986 $item->{defined_members}->{$name} = 1;
1987 }
1988 }
1989
1990 if ($item->{node}->isa ('Whatpm::WebIDL::Attribute') or
1991 $item->{node}->isa ('Whatpm::WebIDL::Operation')) {
1992 my $type = $item->{node}->type;
1993 if ($type =~ /\A::[^:]+::\z/) { # note that sequence<> not allowed
1994 #
1995 } else { # scoped name
1996 my $def = $resolve->($type, $item->{scope});
1997
1998 unless ($def and
1999 ($def->{node}->isa ('Whatpm::WebIDL::Interface') or
2000 $def->{node}->isa ('Whatpm::WebIDL::Typedef') or
2001 $def->{node}->isa ('Whatpm::WebIDL::Valuetype'))) {
2002 $onerror->(type => 'type not defined',
2003 node => $item->{node},
2004 text => $item->{node}->type_text,
2005 level => $levels->{must});
2006 }
2007 }
2008
2009 for (@{$item->{node}->{raises} or []}, # for operations
2010 @{$item->{node}->{getraises} or []}, # for attributes
2011 @{$item->{node}->{setraises} or []}) { # for attributes
2012 my $def = $resolve->($_, $item->{scope});
2013
2014 unless ($def and
2015 $def->{node}->isa ('Whatpm::WebIDL::Exception')) {
2016 $onerror->(type => 'exception not defined',
2017 text => $_,
2018 node => $item->{node},
2019 level => $levels->{must});
2020 }
2021 }
2022
2023 ## ISSUE: readonly setraises is not disallowed
2024 ## ISSUE: raises (x,x) and raises (x,::x) and etc. are not disallowed
2025 } elsif ($item->{node}->isa ('Whatpm::WebIDL::Const')) {
2026 $check_const_value->($item);
2027 }
2028 } elsif ($item->{node}->isa ('Whatpm::WebIDL::Argument') or
2029 $item->{node}->isa ('Whatpm::WebIDL::ExceptionMember')) {
2030 if ($item->{has_arg_xattr}->{variadic} and
2031 $item->{node}->isa ('Whatpm::WebIDL::Argument')) {
2032 $onerror->(type => 'argument after variadic',
2033 node => $item->{node},
2034 level => $levels->{fact});
2035 }
2036
2037 ## ISSUE: No uniqueness constraints for arguments in an operation,
2038 ## so we don't check it for arguments.
2039
2040 ## ISSUE: For extended attributes, semantics of the argument
2041 ## (e.g. the identifier is given by the |identifier| in the |Argument|)
2042 ## is not explicitly defined. In addition, no uniqueness constraint
2043 ## is defined, so we don't check it for arguments.
2044
2045 my $name = $item->{node}->node_name;
2046 if ($item->{defined_members}->{$name}) {
2047 $onerror->(type => 'duplicate member',
2048 text => $name,
2049 node => $item->{node},
2050 level => $levels->{must});
2051 } else {
2052 $item->{defined_members}->{$name} = 1;
2053 }
2054
2055 my $type = $item->{node}->type;
2056 if ($type =~ /\A::[^:]+::\z/) { # note that sequence<> not allowed
2057 #
2058 } else { # scoped name
2059 my $def = $resolve->($type, $item->{scope});
2060
2061 unless ($def and
2062 ($def->{node}->isa ('Whatpm::WebIDL::Interface') or
2063 $def->{node}->isa ('Whatpm::WebIDL::Typedef') or
2064 $def->{node}->isa ('Whatpm::WebIDL::Valuetype'))) {
2065 $onerror->(type => 'type not defined',
2066 text => $item->{node}->type_text,
2067 node => $item->{node},
2068 level => $levels->{must});
2069 }
2070 }
2071 }
2072
2073 my $xattrs = $item->{node}->{xattrs} || [];
2074 my $has_xattr;
2075 X: for my $xattr (@$xattrs) {
2076 my $xattr_name = $xattr->node_name;
2077 my $xattr_def = $xattr_defs->{$xattr_name};
2078
2079 unless ($xattr_def) {
2080 $onerror->(type => 'unknown xattr',
2081 text => $xattr_name,
2082 node => $xattr,
2083 level => $levels->{uncertain});
2084 next X;
2085 }
2086
2087 A: {
2088 for my $cls (keys %{$xattr_def->{allowed_type} or {}}) {
2089 if ($item->{node}->isa ('Whatpm::WebIDL::' . $cls)) {
2090 if ($cls eq 'Interface' and
2091 $item->{node}->is_forward_declaration) {
2092 #
2093 } else {
2094 last A;
2095 }
2096 }
2097 }
2098
2099 $onerror->(type => 'xattr not applicable',
2100 text => $xattr_name,
2101 node => $xattr,
2102 level => $levels->{fact});
2103 next X;
2104 } # A
2105
2106 if ($has_xattr->{$xattr_name} and not $xattr_def->{allow_multiple}) {
2107 ## ISSUE: Whether multiple extended attributes with the same
2108 ## name are allowed is not explicitly specified in the spec.
2109 ## It is, however, specified that some extended attributes may
2110 ## be specified more than once.
2111 $onerror->(type => 'duplicate xattr',
2112 text => $xattr_name,
2113 node => $xattr,
2114 level => $levels->{warn});
2115 }
2116 $has_xattr->{$xattr_name} = 1;
2117
2118 if (not $xattr_def->{allow_id} and defined $xattr->value) {
2119 $onerror->(type => 'xattr id not allowed',
2120 text => $xattr_name,
2121 node => $xattr,
2122 level => $levels->{must});
2123 }
2124 if (not $xattr_def->{allow_arglist} and $xattr->has_argument_list) {
2125 $onerror->(type => 'xattr arglist not allowed',
2126 text => $xattr_name,
2127 node => $xattr,
2128 level => $levels->{must});
2129 }
2130
2131 $xattr_def->{check}->($self, $onerror, $levels, $items, $item,
2132 $xattr, $xattr_name, $resolve, $constructors);
2133 }
2134
2135 if (not $has_xattr->{NoInterfaceObject} and
2136 (($item->{node}->isa ('Whatpm::WebIDL::Interface') and
2137 not $item->{node}->is_forward_declaration) or
2138 $item->{node}->isa ('Whatpm::WebIDL::Exception'))) {
2139 my $id = $item->{node}->node_name;
2140 if ($constructors->{$id} and
2141 $constructors->{$id}->{is_named_constructor}) {
2142 $onerror->(type => 'duplicate constructor name',
2143 value => $id,
2144 node => $constructors->{$id}->{is_named_constructor},
2145 level => $levels->{must});
2146 } else {
2147 ## NOTE: Duplication is not checked in this case, since any
2148 ## duplication of interface/exception identifiers are detected
2149 ## by the parser.
2150 $constructors->{$id} = {node => $item->{node}};
2151 }
2152 }
2153 }
2154 } # check
2155
2156 package Whatpm::WebIDL::Definition;
2157 push our @ISA, 'Whatpm::WebIDL::Node';
2158
2159 sub new ($$) {
2160 return bless {child_nodes => [], node_name => ''.$_[1]}, $_[0];
2161 } # new
2162
2163 sub set_extended_attribute_node ($$) {
2164 my $self = shift;
2165 ## TODO: check
2166 push @{$self->{xattrs} ||= []}, shift;
2167 } # set_extended_attribute_node
2168
2169 sub _xattrs_text ($) {
2170 my $self = shift;
2171
2172 unless ($self->{xattrs} and
2173 @{$self->{xattrs}}) {
2174 return '';
2175 }
2176
2177 my $r = '[';
2178 $r .= join ', ', map {$_->idl_text} @{$self->{xattrs}};
2179 $r .= ']';
2180 return $r;
2181 } # _xattrs_text
2182
2183 sub qualified_name ($) {
2184 my $self = shift;
2185
2186 my $parent = $self->{parent_node};
2187 if ($parent and $parent->isa ('Whatpm::WebIDL::Definition')) {
2188 return $parent->qualified_name . '::' . $self->{node_name};
2189 } else {
2190 return '::' . $self->{node_name};
2191 }
2192 } # qualified_name
2193
2194 sub type ($;$) {
2195 if (@_ > 1) {
2196 if (defined $_[1]) {
2197 $_[0]->{type} = $_[1];
2198 } else {
2199 $_[0]->{type} = '::any::';
2200 }
2201 }
2202 return $_[0]->{type};
2203 } # type
2204
2205 my $serialize_type;
2206 $serialize_type = sub ($) {
2207 my $type = shift;
2208 if ($type =~ s/^::::sequence:::://) {
2209 return 'sequence<' . $serialize_type->($type) . '>';
2210 } elsif ($type =~ /\A::([^:]+)::\z/) {
2211 return $1;
2212 } else {
2213 $type =~ s/::DOMString::::\z/::DOMString/;
2214 return $type; ## TODO: escape identifiers...
2215 }
2216 }; # $serialize_type
2217
2218 sub type_text ($) {
2219 my $type = $_[0]->{type};
2220 return undef unless defined $type;
2221
2222 return $serialize_type->($type);
2223 } # type_text
2224
2225 package Whatpm::WebIDL::Module;
2226 push our @ISA, 'Whatpm::WebIDL::Definition';
2227
2228 sub idl_text ($) {
2229 my $self = shift;
2230 my $r = $self->_xattrs_text;
2231 $r .= ' ' if length $r;
2232 $r .= 'module ' . $self->node_name . " {\x0A\x0A"; ## TODO: escape
2233 for (@{$self->{child_nodes}}) {
2234 $r .= $_->idl_text;
2235 }
2236 $r .= "\x0A};\x0A";
2237 return $r;
2238 } # idl_text
2239
2240 package Whatpm::WebIDL::Interface;
2241 push our @ISA, 'Whatpm::WebIDL::Definition';
2242
2243 sub new ($$) {
2244 my $self = shift->SUPER::new (@_);
2245 $self->{inheritances} = [];
2246 return $self;
2247 } # new
2248
2249 sub append_inheritance ($$) {
2250 my $self = shift;
2251 my $scoped_name = shift;
2252 push @{$self->{inheritances}}, $scoped_name;
2253 } # append_inheritance
2254
2255 sub idl_text ($) {
2256 my $self = shift;
2257 my $r = $self->_xattrs_text;
2258 $r .= ' ' if length $r;
2259 $r .= 'interface ' . $self->node_name;
2260
2261 if ($self->{is_forward_declaration}) {
2262 $r .= ";\x0A";
2263 return $r;
2264 }
2265
2266 if (@{$self->{inheritances}}) {
2267 $r .= ' : '; ## TODO: ...
2268 $r .= join ', ', map {$serialize_type->($_)} @{$self->{inheritances}};
2269 }
2270 $r .= " {\x0A"; ## TODO: escape
2271 for (@{$self->{child_nodes}}) {
2272 $r .= ' ' . $_->idl_text;
2273 }
2274 $r .= "};\x0A";
2275 return $r;
2276 } # idl_text
2277
2278 sub is_forward_declaration ($;$) {
2279 if (@_ > 1) {
2280 if ($_[1]) {
2281 $_[0]->{is_forward_declaration} = 1;
2282 } else {
2283 delete $_[0]->{is_forward_declaration};
2284 }
2285 }
2286
2287 return $_[0]->{is_forward_declaration};
2288 } # is_forward_declaration
2289
2290 package Whatpm::WebIDL::Exception;
2291 push our @ISA, 'Whatpm::WebIDL::Definition';
2292
2293 sub idl_text ($) {
2294 my $self = shift;
2295 my $r = $self->_xattrs_text;
2296 $r .= ' ' if length $r;
2297 $r .= 'exception ' . $self->node_name . " {\x0A"; ## TODO: escape
2298 for (@{$self->{child_nodes}}) {
2299 $r .= ' ' . $_->idl_text;
2300 }
2301 $r .= "};\x0A";
2302 return $r;
2303 } # idl_text
2304
2305 package Whatpm::WebIDL::Typedef;
2306 push our @ISA, 'Whatpm::WebIDL::Definition';
2307
2308 sub new ($$) {
2309 my $self = shift->SUPER::new (@_);
2310 $self->{type} = '::any::';
2311 return $self;
2312 } # new
2313
2314 sub idl_text ($) {
2315 my $self = shift;
2316 my $r = $self->_xattrs_text;
2317 $r .= ' ' if length $r;
2318 my $node_name = $self->node_name;
2319 $node_name = 'DOMString' if $node_name eq '::DOMString::';
2320 ## TODO: escape
2321 $r .= 'typedef ' . $self->type_text . ' ' . $node_name . ";\x0A";
2322 return $r;
2323 } # idl_text
2324
2325 package Whatpm::WebIDL::Valuetype;
2326 push our @ISA, 'Whatpm::WebIDL::Definition';
2327
2328 sub new ($$) {
2329 my $self = shift->SUPER::new (@_);
2330 $self->{type} = '::boolean::';
2331 return $self;
2332 } # new
2333
2334 sub idl_text ($) {
2335 my $self = shift;
2336 my $r = $self->_xattrs_text;
2337 $r .= ' ' if length $r;
2338 my $name = $self->node_name;
2339 $name = 'DOMString' if $name eq '::DOMString::';
2340 ## TODO: escape
2341 $r .= 'valuetype ' . $name . ' ' . $self->type_text . ";\x0A";
2342 return $r;
2343 } # idl_text
2344
2345 package Whatpm::WebIDL::InterfaceMember;
2346 push our @ISA, 'Whatpm::WebIDL::Node';
2347
2348 sub new ($$) {
2349 return bless {node_name => ''.$_[1]}, $_[0];
2350 } # new
2351
2352 sub child_nodes ($) { return [] }
2353
2354 *_xattrs_text = \&Whatpm::WebIDL::Definition::_xattrs_text;
2355
2356 *set_extended_attribute_node = \&Whatpm::WebIDL::Definition::set_extended_attribute_node;
2357
2358 *type = \&Whatpm::WebIDL::Definition::type;
2359
2360 *type_text = \&Whatpm::WebIDL::Definition::type_text;
2361
2362 package Whatpm::WebIDL::Const;
2363 push our @ISA, 'Whatpm::WebIDL::Definition', 'Whatpm::WebIDL::InterfaceMember';
2364
2365 sub new ($$) {
2366 my $self = shift->SUPER::new (@_); # Definition->new should be called
2367 $self->{type} = '::boolean::';
2368 $self->{value} = ['FALSE'];
2369 return $self;
2370 } # new
2371
2372 sub value ($;$) {
2373 if (@_ > 1) {
2374 if (defined $_[1]) {
2375 $_[0]->{value} = $_[1];
2376 } else {
2377 $_[0]->{value} = ['FALSE'];
2378 }
2379 }
2380
2381 return $_[0]->{value};
2382 } # value
2383
2384 sub value_text ($) {
2385 my $value = $_[0]->{value};
2386
2387 if ($value->[0] eq 'TRUE' or $value->[0] eq 'FALSE') {
2388 return $value->[0];
2389 } elsif ($value->[0] eq 'integer' or $value->[0] eq 'float') {
2390 ## TODO: format
2391 return $value->[1];
2392 } else {
2393 return undef;
2394 }
2395 } # value_text
2396
2397 sub idl_text ($) {
2398 my $self = shift;
2399 my $r = $self->_xattrs_text;
2400 $r .= ' ' if length $r;
2401 $r .= 'const ' . $self->type_text . ' ' . $self->node_name . ' = ' . $self->value_text . ";\x0A"; ## TODO: escape
2402 return $r;
2403 } # idl_text
2404
2405 package Whatpm::WebIDL::Attribute;
2406 push our @ISA, 'Whatpm::WebIDL::InterfaceMember';
2407
2408 sub new ($$) {
2409 my $self = shift->SUPER::new (@_);
2410 $self->{type} = '::any::';
2411 $self->{getraises} = [];
2412 $self->{setraises} = [];
2413 return $self;
2414 } # new
2415
2416 sub append_getraises ($$) {
2417 ## TODO: error check, etc.
2418 push @{$_[0]->{getraises}}, $_[1];
2419 } # append_getraises
2420
2421 sub append_setraises ($$) {
2422 ## TODO: error check, etc.
2423 push @{$_[0]->{setraises}}, $_[1];
2424 } # append_setraises
2425
2426 sub readonly ($;$) {
2427 if (@_ > 1) {
2428 $_[0]->{readonly} = $_[1];
2429 }
2430
2431 return $_[0]->{readonly};
2432 } # readonly
2433
2434 sub idl_text ($) {
2435 my $self = shift;
2436 my $r = $self->_xattrs_text;
2437 $r .= ' ' if length $r;
2438 $r .= ($self->readonly ? 'readonly ' : '') . 'attribute ' . $self->type_text . ' ' . $self->node_name;
2439 ## TODO: escape
2440 if (@{$self->{getraises}}) {
2441 $r .= ' getraises (';
2442 ## todo: ...
2443 $r .= join ', ', map {$serialize_type->($_)} @{$self->{getraises}};
2444 $r .= ')';
2445 }
2446 if (@{$self->{setraises}}) {
2447 $r .= ' setraises (';
2448 ## todo: ...
2449 $r .= join ', ', map {$serialize_type->($_)} @{$self->{setraises}};
2450 $r .= ')';
2451 }
2452 $r .= ";\x0A";
2453 return $r;
2454 } # idl_text
2455
2456 package Whatpm::WebIDL::Operation;
2457 push our @ISA, 'Whatpm::WebIDL::InterfaceMember';
2458
2459 sub new ($$) {
2460 my $self = shift->SUPER::new (@_);
2461 $self->{type} = '::any::';
2462 $self->{child_nodes} = [];
2463 $self->{raises} = [];
2464 return $self;
2465 } # new
2466
2467 sub append_raises ($$) {
2468 ## TODO: error check, etc.
2469 push @{$_[0]->{raises}}, $_[1];
2470 } # append_raises
2471
2472 sub idl_text ($) {
2473 my $self = shift;
2474 my $r = $self->_xattrs_text;
2475 $r .= ' ' if length $r;
2476 $r .= $self->type_text . ' ' . $self->node_name . ' ('; ## TODO: escape
2477 $r .= join ', ', map {$_->idl_text} @{$self->{child_nodes}};
2478 $r .= ')';
2479 if (@{$self->{raises}}) {
2480 $r .= ' raises (';
2481 ## todo: ...
2482 $r .= join ', ', map {$serialize_type->($_)} @{$self->{raises}};
2483 $r .= ')';
2484 }
2485 $r .= ";\x0A";
2486 return $r;
2487 } # idl_text
2488
2489 package Whatpm::WebIDL::Argument;
2490 push our @ISA, 'Whatpm::WebIDL::Node';
2491
2492 sub new ($$) {
2493 return bless {node_name => ''.$_[1], type => '::any::'}, $_[0];
2494 } # new
2495
2496 sub idl_text ($) {
2497 my $self = shift;
2498 my $r = $self->_xattrs_text;
2499 $r .= ' ' if length $r;
2500 $r .= 'in ' . $self->type_text . ' ' . $self->node_name; ## TODO: escape
2501 return $r;
2502 } # idl_text
2503
2504 *_xattrs_text = \&Whatpm::WebIDL::Definition::_xattrs_text;
2505
2506 *set_extended_attribute_node = \&Whatpm::WebIDL::Definition::set_extended_attribute_node;
2507
2508 *type = \&Whatpm::WebIDL::Definition::type;
2509
2510 *type_text = \&Whatpm::WebIDL::Definition::type_text;
2511
2512 package Whatpm::WebIDL::ExceptionMember;
2513 push our @ISA, 'Whatpm::WebIDL::Node';
2514
2515 sub new ($$) {
2516 return bless {node_name => ''.$_[1], type => '::any::'}, $_[0];
2517 } # new
2518
2519 sub idl_text ($) {
2520 my $self = shift;
2521 my $r = $self->_xattrs_text;
2522 $r .= ' ' if length $r;
2523 $r .= $self->type_text . ' ' . $self->node_name . ";\x0A"; ## TODO: escape
2524 return $r;
2525 } # idl_text
2526
2527 *_xattrs_text = \&Whatpm::WebIDL::Definition::_xattrs_text;
2528
2529 *set_extended_attribute_node = \&Whatpm::WebIDL::Definition::set_extended_attribute_node;
2530
2531 *type = \&Whatpm::WebIDL::Definition::type;
2532
2533 *type_text = \&Whatpm::WebIDL::Definition::type_text;
2534
2535 package Whatpm::WebIDL::ExtendedAttribute;
2536 push our @ISA, 'Whatpm::WebIDL::Node';
2537
2538 sub new ($$) {
2539 return bless {child_nodes => [], node_name => ''.$_[1]};
2540 } # new
2541
2542 sub has_argument_list ($;$) {
2543 if (@_ > 1) {
2544 if ($_[1]) {
2545 $_[0]->{has_argument_list} = 1;
2546 } else {
2547 delete $_[0]->{has_argument_list};
2548 }
2549 }
2550
2551 return ($_[0]->{has_argument_list} or scalar @{$_[0]->{child_nodes}});
2552 } # has_argument_list
2553
2554 sub idl_text ($) {
2555 my $self = shift;
2556 my $r = $self->node_name; ## TODO:] esceape
2557 if (defined $self->{value}) {
2558 $r .= '=' . $self->{value}; ## TODO: escape
2559 }
2560 if ($self->has_argument_list) {
2561 $r .= ' (';
2562 $r .= join ', ', map {$_->idl_text} @{$self->{child_nodes}};
2563 $r .= ')';
2564 }
2565 return $r;
2566 } # idl_text
2567
2568 sub value ($;$) {
2569 if (@_ > 1) {
2570 if (defined $_[1]) {
2571 $_[0]->{value} = ''.$_[1];
2572 } else {
2573 delete $_[0]->{value};
2574 }
2575 }
2576
2577 return $_[0]->{value};
2578 } # value
2579
2580 1;
[email protected]
 ViewVC Help
Powered by ViewVC 1.1.24