/[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.20 - (show annotations) (download)
Mon Oct 13 06:18:32 2008 UTC (16 years ago) by wakaba
Branch: MAIN
CVS Tags: HEAD
Changes since 1.19: +32 -2 lines 
++ whatpm/t/ChangeLog	13 Oct 2008 06:18:26 -0000
2008-10-13  Wakaba  <wakaba@suika.fam.cx>

	* tokenizer-test-2.dat: A test result was wrong.

++ whatpm/Whatpm/ChangeLog	13 Oct 2008 06:17:59 -0000
2008-10-13  Wakaba  <wakaba@suika.fam.cx>

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