whatpm/Whatpm/WebIDL.pm

package Whatpm::WebIDL;
use strict;
our $VERSION=do{my @r=(q$Revision: 1.19 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};

package Whatpm::WebIDL::Parser;

my $integer = qr/-?0([Xx][0-9A-Fa-f]+|[0-7]*)|[1-9][0-9]*/;
  ## ISSUE: Spec's pattern is wrong as a Perl5 regular expression.
my $float = qr/-?([0-9]+\.[0-9]*|[0-9]*\.[0-9]+)([Ee][+-]?[0-9]+)?|[0-9]+[Ee][+-]?[0-9]+/;
my $identifier = qr/[A-Z_a-z][0-9A-Z_a-z]*/;
my $whitespace = qr<[\t\n\r ]+|[\t\n\r ]*((//.*|/\*.*?\*/)[\t\n\r ]*)+>;

my $default_levels = {
                      must => 'm',
                      should => 's',
                      warn => 'w',
                      fact => 'w',
                      undefined => 'w',
                      info => 'i',
                      uncertain => 'u',
                     };

sub new ($) {
  my $self = bless {
    level => $default_levels,
  }, $_[0];
  return $self;
} # new

sub parse_char_string ($$;$) {
  my $self = shift;
  my $s = ref $_[0] ? $_[0] : \($_[0]);

  my $defs = Whatpm::WebIDL::Definitions->new;
  $defs->set_user_data (manakai_source_line => 1);
  $defs->set_user_data (manakai_source_column => 1);

  pos ($$s) = 0;
  my $line = 1;
  my $column = 0;

  my $get_next_token = sub {
    if (length $$s <= pos $$s) {
      return {type => 'eof'};
    }

    while ($$s =~ /\G($whitespace)/gc) {
      my $v = $1;
      while ($v =~ s/^[^\x0D\x0A]*(?>\x0D\x0A?|\x0A)//) {
        $line++;
        $column = 0;
      }
      $column += length $v;
    }

    if (length $$s <= pos $$s) {
      return {type => 'eof'};
    }

    ## ISSUE: "must"s in "A. IDL grammer" are not "MUST"s.

    if ($$s =~ /\G($identifier)/gc) {
      my $v = $1;
      $column += length $v;
      if ({
        module => 1, interface => 1, exception => 1, typedef => 1,
        valuetype => 1, DOMString => 1, sequence => 1, unsigned => 1,
        short => 1, const => 1, TRUE => 1, FALSE => 1, readonly => 1,
        attribute => 1, getraises => 1, setraises => 1, raises => 1, in => 1,
        any => 1, boolean => 1, octet => 1, float => 1, Object => 1,
        short => 1, long => 1, void => 1,
      }->{$v}) {
        return {type => $v};
      } else {
        return {type => 'identifier', value => $v};
      }
    } elsif ($$s =~ /\G($float)/gc) { ## ISSUE: negative number
      $column += length $1;
      return {type => 'float', value => $1};
    } elsif ($$s =~ /\G($integer)/gc) { ## ISSUE: negative nmber
      $column += length $1;
      return {type => 'integer', value => $1};
    } elsif ($$s =~ /\G::/gcs) {
      $column += 2;
      return {type => '::'};
    } elsif ($$s =~ /\G(.)/gcs) { ## NOTE: Should never be a newline char.
      $column++;
      return {type => $1};
    } else {
      die "get_next_token: non-possible case: " . substr ($$s, pos $$s, 20);
    }
  }; # $get_next_token

  my $state = 'before definitions';
  my $token = $get_next_token->();
  my $nest_level = 0;
  my $next_state;
  my $xattrs;
  my $prev_xattrs = [];
  my $last_xattr;
  my $read_only;
  my $current_type;
  my @current = ($defs);

  my $_onerror = $_[1] || sub {
    my %opt = @_;
    my $r = 'Line ' . $opt{line} . ' column ' . $opt{column} . ': ';

    if ($opt{token}) {
      $r .= 'Token ' . (defined $opt{token}->{value}
                        ? $opt{token}->{value} : $opt{token}->{type}) . ': ';
    }

    $r .= $opt{type} . ';' . $opt{level};
    
    warn $r . "\n";
  }; # $_onerror
  my $onerror = sub {
    $_onerror->(line => $line, column => $column, token => $token, @_);
  }; # $onerror

  my $get_scoped_name = sub {
    ## NOTE: Convert a |ScopedName| into a "scoped name".

    my $name = [];

    ## NOTE: "DOMString" is not a scoped name, while "::DOMString"
    ## and "x::DOMString" are.

    if ($token->{type} eq 'identifier') {
      my $identifier = $token->{value};
      $identifier =~ s/^_//;
      push @$name, $identifier;
      $token = $get_next_token->();
      while ($token->{type} eq '::') {
        $token = $get_next_token->();
        if ($token->{type} eq 'identifier') {
          my $identifier = $token->{value};
          $identifier =~ s/^_//;
          push @$name, $identifier;
          $token = $get_next_token->();
        } elsif ($token->{type} eq 'DOMString') {
          push @$name, 'DOMString', '', '';
          $token = $get_next_token->();
          last;
        }
      }
    } elsif ($token->{type} eq '::') {
      push @$name, '';
      while ($token->{type} eq '::') {
        $token = $get_next_token->();
        if ($token->{type} eq 'identifier') {
          my $identifier = $token->{value};
          $identifier =~ s/^_//;
          push @$name, $identifier;
          $token = $get_next_token->();
        } elsif ($token->{type} eq 'DOMString') {
          push @$name, 'DOMString', '', '';
          $token = $get_next_token->();
          last;
        } else {
          last;
        }
      }

      if (@$name == 1) {
        return undef;
      }
    } else {
      # reconsume
      return undef;
    }
    return join '::', @$name;
  }; # $get_scoped_name

  my $get_type;
  $get_type = sub {
    my $r;
    if ({
      void => 1, any => 1, boolean => 1, octet => 1, float => 1,
      DOMString => 1, Object => 1, short => 1,
    }->{$token->{type}}) {
      $r = '::'.$token->{type}.'::';
      $token = $get_next_token->();
    } elsif ($token->{type} eq 'unsigned') {
      $token = $get_next_token->();
      if ($token->{type} eq 'short') {
        $r = '::unsigned '.$token->{type}.'::';
        $token = $get_next_token->();
      } elsif ($token->{type} eq 'long') {
        $token = $get_next_token->();
        if ($token->{type} eq 'long') {
          $r = '::unsigned long long::';
          $token = $get_next_token->();
        } else {
          $r = '::unsigned long::';
          # reconsume
        }
      } else {
        $onerror->(type => 'after unsigned',
                   level => $self->{level}->{must});
        return undef;
      }
    } elsif ($token->{type} eq 'long') {
      $token = $get_next_token->();
      if ($token->{type} eq 'long') {
        $r = '::long long::';
        $token = $get_next_token->();
      } else {
        $r = '::long::';
        # reconsume
      }
    } elsif ($token->{type} eq '::' or $token->{type} eq 'identifier') {
      $r = $get_scoped_name->();
      if (defined $r) {
        # next token
      } else { # "::" not followed by identifier or "DOMString"
        $onerror->(type => 'scoped name:dcolon',
                   level => $self->{level}->{must});
        return undef;
      }
    } elsif ($token->{type} eq 'sequence') {
      $token = $get_next_token->();
      if ($token->{type} eq '<') {
        $token = $get_next_token->();
        if ({
          void => 1, any => 1, boolean => 1, octet => 1, float => 1,
          DOMString => 1, Object => 1, short => 1, long => 1, unsigned => 1,
          sequence => 1, '::' => 1, identifier => 1,
        }->{$token->{type}}) {
          my $type = $get_type->();
          if (defined $type) {
            if ($token->{type} eq '>') {
              $r = '::::sequence::::' . $type;
              $token = $get_next_token->();
            } else {
              $onerror->(type => 'no sequence gt',
                         level => $self->{level}->{must});
              return undef;
            }
          } else {
            # error reported
            return undef;
          }
        } else {
          $onerror->(type => 'no sequence type',
                     level => $self->{level}->{must});
          return undef;
        }
      } else {
        $onerror->(type => 'no sequence lt',
                   level => $self->{level}->{must});
        return undef;
      }
    } else {
      die "get_type: bad token: $token->{type}";
    }

    return $r;
  }; # $get_type

  while (1) {
    if ($state eq 'before definitions') {
      $xattrs = [];
      if ($token->{type} eq '[') {
        $token = $get_next_token->();
        $state = 'before xattr';
        $next_state = 'before def';
      } elsif ({module => 1, interface => 1, exception => 1,
               typedef => 1, valuetype => 1, const => 1}->{$token->{type}}) {
        # reconsume
        $state = 'before def';
      } elsif ($token->{type} eq '}' and @current > 1) {
        $token = $get_next_token->();
        $state = 'before block semicolon';
      } elsif ($token->{type} eq 'eof') {
        last;
      } else {
        $onerror->(type => 'before webidl defs',
                   level => $self->{level}->{must});
        # reconsume
        $state = 'ignore';
        $nest_level = 0;
        $next_state = 'before definitions';
      }
    } elsif ($state eq 'before xattr') {
      if ($token->{type} eq 'identifier') {
        my $id = $token->{value};
        $id =~ s/^_//;
        push @current, Whatpm::WebIDL::ExtendedAttribute->new ($id);
        $current[-1]->set_user_data (manakai_source_line => $line);
        $current[-1]->set_user_data (manakai_source_column => $column);
        push @$xattrs, $current[-1];
        $token = $get_next_token->();
        $state = 'after xattr';
      } else {
        $onerror->(type => 'before xattr', 
                   level => $self->{level}->{must});
        # reconsume
        $state = 'ignore';
        $nest_level = 0;
        $next_state = 'before definitions'; ## TODO:
      }
    } elsif ($state eq 'after xattr') {
      if ($token->{type} eq '=') {
        $token = $get_next_token->();
        $state = 'before xattrarg';
      } elsif ($token->{type} eq '(') {
        $current[-1]->has_argument_list (1);
        $token = $get_next_token->();
        if ($token->{type} eq ')') {
          $token = $get_next_token->();
          push @$prev_xattrs, $xattrs;
          $state = 'after xattrarg';
        } else {
          push @$prev_xattrs, $xattrs;
          # reconsume
          $state = 'before argument';
        }
      } else {
        push @$prev_xattrs, $xattrs;
        # reconsume
        $state = 'after xattrarg';
      }
    } elsif ($state eq 'before xattrarg') {
      if ($token->{type} eq 'identifier') {
        my $identifier = $token->{value};
        $identifier =~ s/^_//;
        $current[-1]->value ($identifier);
        $token = $get_next_token->();
        if ($token->{type} eq '(') {
          $current[-1]->has_argument_list (1);
          $token = $get_next_token->();
          if ($token->{type} eq ')') {
            push @$prev_xattrs, $xattrs;
            $token = $get_next_token->();
            $state = 'after xattrarg';
          } else {
            push @$prev_xattrs, $xattrs;
            # reconsume
            $state = 'before argument';
          }
        } else {
          push @$prev_xattrs, $xattrs;
          # reconsume
          $state = 'after xattrarg';
        }
      } else {
        $onerror->(type => 'before xattrarg',
                   level => $self->{level}->{must});
        # reconsume
        $state = 'ignore';
        $nest_level = 0;
        $next_state = 'before definitions';        
      }
    } elsif ($state eq 'after xattrarg') {
      pop @current; # xattr
      $xattrs = pop @$prev_xattrs;
      if ($token->{type} eq ',') {
        $token = $get_next_token->();
        $state = 'before xattr';
      } elsif ($token->{type} eq ']') {
        $token = $get_next_token->();
        if ($current[-1]->isa ('Whatpm::WebIDL::Definitions') or
            $current[-1]->isa ('Whatpm::WebIDL::Module')) {
          $state = 'before def';
        } elsif ($current[-1]->isa ('Whatpm::WebIDL::Interface')) {
          $state = 'before interface member';
        } elsif ($current[-1]->isa ('Whatpm::WebIDL::Exception')) {
          $state = 'before exception member';
        } elsif ($current[-1]->isa ('Whatpm::WebIDL::Operation') or
                 $current[-1]->isa ('Whatpm::WebIDL::ExtendedAttribute')) {
          $state = 'before argument in';
        } else {
          die "$0: Unknown xattr context: " . ref $current[-1];
        }
      } else {
        $onerror->(type => 'after xattr',
                   level => $self->{level}->{must});
        # reconsume
        $state = 'ignore';
        $nest_level = 0;
        $next_state = 'before definitions'; ## TODO:
      }
    } elsif ($state eq 'before def') {
      if ($token->{type} eq 'module') {
        $token = $get_next_token->();
        if ($token->{type} eq 'identifier') {
          my $identifier = $token->{value};
          $identifier =~ s/^_//;
          push @current, Whatpm::WebIDL::Module->new ($identifier);
          $current[-1]->set_user_data (manakai_source_line => $line);
          $current[-1]->set_user_data (manakai_source_column => $column);
          $current[-1]->set_extended_attribute_node ($_) for @$xattrs;
          $token = $get_next_token->();
          $state = 'before module block';
          next;
        } else {
          $onerror->(type => 'no webidl identifier',
                     text => 'module',
                     level => $self->{level}->{must});
          #
        }        
      } elsif ($token->{type} eq 'interface') {
        $token = $get_next_token->();
        if ($token->{type} eq 'identifier') {
          my $identifier = $token->{value};
          $identifier =~ s/^_//;
          push @current, Whatpm::WebIDL::Interface->new ($identifier);
          $current[-1]->set_user_data (manakai_source_line => $line);
          $current[-1]->set_user_data (manakai_source_column => $column);
          $current[-1]->set_extended_attribute_node ($_) for @$xattrs;
          $token = $get_next_token->();
          $state = 'before interface inheritance';
          next;
        } else {
          $onerror->(type => 'no webidl identifier',
                     text => 'interface',
                     level => $self->{level}->{must});
          #
        }        
      } elsif ($token->{type} eq 'exception') {
        $token = $get_next_token->();
        if ($token->{type} eq 'identifier') {
          my $identifier = $token->{value};
          $identifier =~ s/^_//;
          push @current, Whatpm::WebIDL::Exception->new ($identifier);
          $current[-1]->set_user_data (manakai_source_line => $line);
          $current[-1]->set_user_data (manakai_source_column => $column);
          $current[-1]->set_extended_attribute_node ($_) for @$xattrs;
          $token = $get_next_token->();
          $state = 'before exception block';
          next;
        } else {
          $onerror->(type => 'no webidl identifier',
                     text => 'exception',
                     level => $self->{level}->{must});
          #
        }        
      } elsif ($token->{type} eq 'typedef') {
        $token = $get_next_token->();
        $state = 'before typedef type';
        next;
      } elsif ($token->{type} eq 'valuetype') {
        $token = $get_next_token->();
        if ($token->{type} eq 'identifier') {
          my $identifier = $token->{value};
          $identifier =~ s/^_//;
          push @current, Whatpm::WebIDL::Valuetype->new ($identifier);
          $current[-1]->set_user_data (manakai_source_line => $line);
          $current[-1]->set_user_data (manakai_source_column => $column);
          $current[-1]->set_extended_attribute_node ($_) for @$xattrs;
          $token = $get_next_token->();
          $state = 'before boxed type';
          next;
        } elsif ($token->{type} eq 'DOMString') {
          push @current, Whatpm::WebIDL::Valuetype->new ('::DOMString::');
          $current[-1]->set_user_data (manakai_source_line => $line);
          $current[-1]->set_user_data (manakai_source_column => $column);
          $current[-1]->set_extended_attribute_node ($_) for @$xattrs;
          $token = $get_next_token->();
          if ($token->{type} eq 'sequence') {
            $token = $get_next_token->();
            if ($token->{type} eq '<') {
              $token = $get_next_token->();
              if ($token->{type} eq 'unsigned') {
                $token = $get_next_token->();
                if ($token->{type} eq 'short') {
                  $token = $get_next_token->();
                  if ($token->{type} eq '>') {
                    $current[-1]->type ('::::sequence::::::unsigned short::');
                    $token = $get_next_token->();
                    $state = 'before semicolon';
                    $next_state = 'before definitions';
                    next;
                  } else {
                    #                
                  }
                } else {
                  #                
                }
              } else {
                #
              }
            } else {
              #
            }
          } else {
            #
          }
          $onerror->(type => 'valuetype DOMString',
                     level => $self->{level}->{must});
          pop @current; # valuetype
          #
        } else {
          $onerror->(type => 'no webidl identifier',
                     text => 'valuetype',
                     level => $self->{level}->{must});
          #
        }        
      } elsif ($token->{type} eq 'const') {
        $token = $get_next_token->();
        $state = 'before const type';
        $next_state = 'before definitions';
        next;
      } else {
        $onerror->(type => 'before webidl def',
                   level => $self->{level}->{must});
        # reconsume
        #
      }
      $state = 'ignore';
      $nest_level = 0;
      $next_state = 'before definitions';
    } elsif ($state eq 'before module block') {
      if ($token->{type} eq '{') {
        $token = $get_next_token->();
        $state = 'before definitions';
      } else {
        $onerror->(type => 'before webidl block',
                   text => 'module',
                   level => $self->{level}->{must});
        pop @current; # module
        # reconsume
        $state = 'ignore';
        $nest_level = 0;
        $next_state = 'before definitions';
      }
    } elsif ($state eq 'before interface inheritance') {
      if ($token->{type} eq ':') {
        $token = $get_next_token->();
        $state = 'before parent interface name';
      } elsif ($token->{type} eq ';') {
        $current[-1]->is_forward_declaration (1);
        # reconsume
        $state = 'before semicolon';
        $next_state = 'before interface member';
      } else {
        # reconsume
        $state = 'before interface block';
      }
    } elsif ($state eq 'before parent interface name') {
      my $name = $get_scoped_name->();
      if (defined $name) {
        $current[-1]->append_inheritance ($name);

        if ($token->{type} eq ',') {
          $token = $get_next_token->();
          # stay in the state
        } else {
          # reconsume
          $state = 'before interface block';
        }
      } else {
        $onerror->(type => 'scoped name', level => $self->{level}->{must});
        pop @current; # interface
        # reconsume
        $state = 'ignore';
        $nest_level = 0;
      }
    } elsif ($state eq 'before exception name') {
      my $name = $get_scoped_name->();
      if (defined $name) {
        my $method = $next_state eq '*raises' ? 'append_raises' :
              $next_state eq '*getraises' ? 'append_getraises' :
              'append_setraises';
        $current[-1]->$method ($name);

        if ($token->{type} eq ',') {
          $token = $get_next_token->();
          # stay in the state
        } elsif ($token->{type} eq ')') {
          $token = $get_next_token->();
          if ($next_state eq '*getraises' and $token->{type} eq 'setraises') {
            $token = $get_next_token->();
            $state = 'after raises';
            $next_state = '*setraises';
          } else {
            # reprocess
            $state = 'before semicolon';
            $next_state = 'before interface member';
          }
        } else {
          $onerror->(type => 'after exception name',
                     level => $self->{level}->{must});
          # reconsume
          $state = 'ignore';
          $nest_level = 0;
        }
      } else {
        $onerror->(type => 'scoped name', level => $self->{level}->{must});
        # reconsume
        $state = 'ignore';
        $nest_level = 0;
      }
    } elsif ($state eq 'before interface block') {
      if ($token->{type} eq '{') {
        $token = $get_next_token->();
        $state = 'before members';
        $next_state = 'before interface member';
      } else {
        $onerror->(type => 'before webidl block',
                   text => 'interface',
                   level => $self->{level}->{must});
        pop @current; # interface
        # reconsume
        $state = 'ignore';
        $nest_level = 0;
      }
    } elsif ($state eq 'before exception block') {
      if ($token->{type} eq '{') {
        $token = $get_next_token->();
        $state = 'before members';
        $next_state = 'before exception member';
      } else {
        $onerror->(type => 'before webidl block',
                   text => 'exception',
                   level => $self->{level}->{must});
        pop @current; # exception
        # reconsume
        $state = 'ignore';
        $nest_level = 0;
      }
    } elsif ($state eq 'before members') {
      $xattrs = [];
      if ($token->{type} eq '[') {
        $token = $get_next_token->();
        $state = 'before xattr';
        #$next_state = $next_state; # 'before interface member' or ...
      } elsif ($token->{type} eq '}') {
        $token = $get_next_token->();
        $state = 'before block semicolon';
      } else {
        # reconsume
        $state = $next_state; # ... 'before exception member'
      }
    } elsif ($state eq 'before interface member') {
      if ($token->{type} eq 'const') {
        $token = $get_next_token->();
        $state = 'before const type';
        $next_state = 'before definitions';
      } elsif ($token->{type} eq 'readonly') {
        $read_only = 1;
        $token = $get_next_token->();
        if ($token->{type} eq 'attribute') {
          $token = $get_next_token->();
          $state = 'after attribute';
        } else {
          # reconsume
          $state = 'ignore';
          $nest_level = 0;
          $next_state = 'before interface member';
        }
      } elsif ($token->{type} eq 'attribute') {
        $read_only = 0;
        $token = $get_next_token->();
        $state = 'after attribute';
      } elsif ({
        void => 1, any => 1, boolean => 1, octet => 1, float => 1,
        DOMString => 1, Object => 1, unsigned => 1, short => 1, long => 1,
        '::' => 1, identifier => 1,
      }->{$token->{type}}) {
        # reconsume
        $state = 'before operation type';
      } elsif ($token->{type} eq '}') {
        $token = $get_next_token->();
        $state = 'before semicolon';
        $next_state = 'before definitions';
      } elsif ($token->{type} eq 'eof') {
        last;
      } else {
        $onerror->(type => 'before interface member',
                   level => $self->{level}->{must});
        # reconsume
        $state = 'ignore';
        $nest_level = 0;
      }
    } elsif ($state eq 'before exception member') {
      if ({
        void => 1, any => 1, boolean => 1, octet => 1, float => 1,
        DOMString => 1, Object => 1, unsigned => 1, short => 1, long => 1,
        '::' => 1, identifier => 1,
      }->{$token->{type}}) {
        # reconsume
        $state = 'before exception member type';
      } elsif ($token->{type} eq '}') {
        $token = $get_next_token->();
        $state = 'before semicolon';
        $next_state = 'before definitions';
      } elsif ($token->{type} eq 'eof') {
        last;
      } else {
        $onerror->(type => 'before exception member',
                   level => $self->{level}->{must});
        # reconsume
        $state = 'ignore';
        $nest_level = 0;
      }
    } elsif ($state eq 'before typedef type') {
      if ({
        void => 1, any => 1, boolean => 1, octet => 1, float => 1,
        DOMString => 1, Object => 1, short => 1, long => 1, unsigned => 1,
        sequence => 1, '::' => 1, identifier => 1,
      }->{$token->{type}}) {
        $current_type = $get_type->();
        if (defined $current_type) {
          # next token
          $state = 'before typedef rest';
        } else {
          # reconsume
          $state = 'ignore';
          $nest_level = 0;
          $next_state = 'before definitions';
        }
      } else {
        $onerror->(type => 'before webidl type',
                   text => 'typedef',
                   level => $self->{level}->{must});
        # reconsume
        $state = 'ignore';
        $nest_level = 0;
        $next_state = 'before definitions';
      }
    } elsif ($state eq 'before boxed type') {
      if ({
        boolean => 1, octet => 1, float => 1,
        short => 1, long => 1, unsigned => 1,
        sequence => 1, '::' => 1, identifier => 1,
      }->{$token->{type}}) {
        $current_type = $get_type->();
        if (defined $current_type) {
          $current[-1]->type ($current_type);
          # next token
          $state = 'before semicolon';
          $next_state = 'before definitions';
        } else {
          pop @current; # valuetype
          # reconsume
          $state = 'ignore';
          $nest_level = 0;
          $next_state = 'before definitions';
        }
      } else {
        $onerror->(type => 'before webidl type',
                   text => 'valuetype',
                   level => $self->{level}->{must});
        pop @current; # valuetype
        # reconsume
        $state = 'ignore';
        $nest_level = 0;
        $next_state = 'before definitions';
      }
    } elsif ($state eq 'before const type') {
      if ({
        any => 1, boolean => 1, octet => 1, float => 1,
        DOMString => 1, Object => 1, short => 1, long => 1, unsigned => 1,
        '::' => 1, identifier => 1,
      }->{$token->{type}}) {
        $current_type = $get_type->();
        if (defined $current_type) {
          # next token
          $state = 'before const identifier';
        } else {
          # reconsume
          $state = 'ignore';
          $nest_level = 0;
          #$next_state = $next_state;
        }
      } else {
        $onerror->(type => 'before webidl type',
                   text => 'const',
                   level => $self->{level}->{must});
        # reconsume
        $state = 'ignore';
        $nest_level = 0;
        #$next_state = $next_state;
      }
    } elsif ($state eq 'before typedef rest') {
      if ($token->{type} eq 'identifier') {
        ## TODO: unescape
        push @current, Whatpm::WebIDL::Typedef->new ($token->{value});
        $current[-1]->set_user_data (manakai_source_line => $line);
        $current[-1]->set_user_data (manakai_source_column => $column);
        $current[-1]->type ($current_type);
        $current[-1]->set_extended_attribute_node ($_) for @$xattrs;
        $token = $get_next_token->();
        $state = 'before semicolon';
        $next_state = 'before definitions';
      } elsif ($token->{type} eq 'DOMString') {
        push @current, Whatpm::WebIDL::Typedef->new ('::DOMString::');
        $current[-1]->type ($current_type);
        $current[-1]->set_user_data (manakai_source_line => $line);
        $current[-1]->set_user_data (manakai_source_column => $column);
        $current[-1]->set_extended_attribute_node ($_) for @$xattrs;
        $token = $get_next_token->();
        $state = 'before semicolon';
        $next_state = 'before defnitions';
      } else {
        $onerror->(type => 'no webidl identifier',
                   text => 'typedef',
                   level => $self->{level}->{must});
        # reconsume
        $state = 'ignore';
        $nest_level = 0;
        $next_state = 'before definitions';
      }
    } elsif ($state eq 'before const identifier') {
      if ($token->{type} eq 'identifier') {
        my $identifier = $token->{value};
        $identifier =~ s/^_//;
        push @current, Whatpm::WebIDL::Const->new ($identifier);
        $current[-1]->set_user_data (manakai_source_line => $line);
        $current[-1]->set_user_data (manakai_source_column => $column);
        $current[-1]->type ($current_type);
        $current[-1]->set_extended_attribute_node ($_) for @$xattrs;
        $token = $get_next_token->();
        if ($token->{type} eq '=') {
          $token = $get_next_token->();
          $state = 'before const expr';
          next;
        } else {
          $onerror->(type => 'no const eq', level => $self->{level}->{must});
          #
        }
      } else {
        $onerror->(type => 'no webidl identifier',
                   text => 'const',
                   level => $self->{level}->{must});
        #
      }
      # reconsume
      $state = 'ignore';
      $nest_level = 0;
      #$next_state = $next_state;
    } elsif ($state eq 'before const expr') {
      if ($token->{type} eq 'TRUE' or $token->{type} eq 'FALSE') {
        $current[-1]->value ([$token->{type}]);
        #
      } elsif ($token->{type} eq 'integer') {
        if ($token->{value} =~ /^0[Xx]/) {
          $current[-1]->value ([$token->{type}, hex substr $token->{value},2]);
        } elsif ($token->{value} =~ /^-0[Xx]/) {
          $current[-1]->value ([$token->{type},-hex substr $token->{value},3]);
        } elsif ($token->{value} =~ /^0/) {
          $current[-1]->value ([$token->{type}, oct $token->{value}]);
        } elsif ($token->{value} =~ /^-0/) {
          $current[-1]->value ([$token->{type},-oct substr $token->{value},1]);
        } else {
          $current[-1]->value ([$token->{type}, 0+$token->{value}]);
        }
        #
      } elsif ($token->{type} eq 'float') {
        $current[-1]->value ([$token->{type}, 0+$token->{value}]);
        #
      } else {
        # reconsume
        $state = 'ignore';
        $nest_level = 0;
        #$next_state = $next_state;
        next;
      }
      
      $token = $get_next_token->();
      $state = 'before semicolon';
      #$next_state = $next_state;
    } elsif ($state eq 'after attribute') {
      if ({
        any => 1, boolean => 1, octet => 1, float => 1,
        DOMString => 1, Object => 1, short => 1, long => 1, unsigned => 1,
        '::' => 1, identifier => 1,
      }->{$token->{type}}) {
        $current_type = $get_type->();
        if (defined $current_type) {
          # next token
          $state = 'before attribute identifier';
        } else {
          # reconsume
          $state = 'ignore';
          $nest_level = 0;
          $next_state = 'before interface member';
        }
      } else {
        $onerror->(type => 'before webidl type', 
                   text => 'attribute',
                   level => $self->{level}->{must});
        # reconsume
        $state = 'ignore';
        $nest_level = 0;
        $next_state = 'before interface member';
      }
    } elsif ($state eq 'before exception member type') {
      #if ({
      #  any => 1, boolean => 1, octet => 1, float => 1,
      #  DOMString => 1, Object => 1, short => 1, long => 1, unsigned => 1,
      #  '::' => 1, identifier => 1,
      #}->{$token->{type}}) {
        $current_type = $get_type->();
        if (defined $current_type) {
          # next token
          $state = 'before exception member identifier';
        } else {
          # reconsume
          $state = 'ignore';
          $nest_level = 0;
          $next_state = 'before exception member';
        }
      #} else {
      #  $onerror->(type => 'before webidl type:exception member',
      #             level => $self->{level}->{must});
      #  # reconsume
      #  $state = 'ignore';
      #  $nest_level = 0;
      #  $next_state = 'before exception member';
      #}
    } elsif ($state eq 'before operation type') {
      #if ({
      #  any => 1, boolean => 1, octet => 1, float => 1,
      #  DOMString => 1, Object => 1, short => 1, long => 1, unsigned => 1,
      #  '::' => 1, identifier => 1,
      #  void => 1,
      #}->{$token->{type}}) {
        $current_type = $get_type->();
        if (defined $current_type) {
          # next token
          $state = 'before operation identifier';
        } else {
          # reconsume
          $state = 'ignore';
          $nest_level = 0;
          $next_state = 'before interface member';
        }
      #} else {
      #  $onerror->(type => 'before webidl type',
      #             text => 'operation',
      #             level => $self->{level}->{must});
      #  # reconsume
      #  $state = 'ignore';
      #  $nest_level = 0;
      #  $next_state = 'before interface member';
      #}
    } elsif ($state eq 'before argument type') {
      if ({
        any => 1, boolean => 1, octet => 1, float => 1,
        DOMString => 1, Object => 1, short => 1, long => 1, unsigned => 1,
        '::' => 1, identifier => 1,
      }->{$token->{type}}) {
        $current_type = $get_type->();
        if (defined $current_type) {
          # next token
          $state = 'before argument identifier';
        } else {
          # reconsume
          $state = 'ignore';
          $nest_level = 0;
        }
      } else {
        $onerror->(type => 'before webidl type:argument',
                   level => $self->{level}->{must});
        # reconsume
        $state = 'ignore';
        $nest_level = 0;
      }
    } elsif ($state eq 'before attribute identifier') {
      if ($token->{type} eq 'identifier') {
        my $identifier = $token->{value};
        $identifier =~ s/^_//;
        push @current, Whatpm::WebIDL::Attribute->new ($identifier);
        $current[-1]->set_user_data (manakai_source_line => $line);
        $current[-1]->set_user_data (manakai_source_column => $column);
        $current[-1]->readonly ($read_only);
        $current[-1]->type ($current_type);
        $current[-1]->set_extended_attribute_node ($_) for @$xattrs;
        $token = $get_next_token->();
        if ($token->{type} eq 'getraises') {
          $token = $get_next_token->();
          $state = 'after raises';
          $next_state = '*getraises';
          next;
        } elsif ($token->{type} eq 'setraises') {
          $token = $get_next_token->();
          $state = 'after raises';
          $next_state = '*setraises';
          next;
        } else {
          # reconsume
          $state = 'before semicolon';
          $next_state = 'before interface member';
          next;
        }
      } else {
        $onerror->(type => 'no webidl identifier',
                   text => 'attribute',
                   level => $self->{level}->{must});
        #
      }
      # reconsume
      $state = 'ignore';
      $nest_level = 0;
      $next_state = 'before interface member';
    } elsif ($state eq 'before exception member identifier') {
      if ($token->{type} eq 'identifier') {
        my $identifier = $token->{value};
        $identifier =~ s/^_//;
        push @current, Whatpm::WebIDL::ExceptionMember->new ($identifier);
        $current[-1]->set_user_data (manakai_source_line => $line);
        $current[-1]->set_user_data (manakai_source_column => $column);
        $current[-1]->type ($current_type);
        $current[-1]->set_extended_attribute_node ($_) for @$xattrs;
        $token = $get_next_token->();
        $state = 'before semicolon';
        $next_state = 'before exception member';
      } else {
        $onerror->(type => 'no webidl identifier:exception member',
                   level => $self->{level}->{must});
        # reconsume
        $state = 'ignore';
        $nest_level = 0;
      }
    } elsif ($state eq 'before operation identifier') {
      if ($token->{type} eq 'identifier') {
        ## TODO: unescape
        push @current, Whatpm::WebIDL::Operation->new ($token->{value});
        $current[-1]->set_user_data (manakai_source_line => $line);
        $current[-1]->set_user_data (manakai_source_column => $column);
        $current[-1]->type ($current_type);
        $current[-1]->set_extended_attribute_node ($_) for @$xattrs;
        $token = $get_next_token->();
        if ($token->{type} eq '(') {
          $token = $get_next_token->();
          if ($token->{type} eq ')') {
            $token = $get_next_token->();
            $state = 'before raises';
            $next_state = '*raises';
            next;
          } else {
            # reconsume
            $state = 'before argument';
            next;
          }
        } else {
          $onerror->(type => 'no arguments lparen',
                     level => $self->{level}->{must});
          #
        }
      } else {
        $onerror->(type => 'no webidl identifier:operation',
                   level => $self->{level}->{must});
        #
      }
      # reconsume
      $state = 'ignore';
      $nest_level = 0;
      $next_state = 'before interface member';
    } elsif ($state eq 'before argument identifier') {
      if ($token->{type} eq 'identifier') {
        my $id = $token->{value};
        $id =~ s/^_//;
        my $arg = Whatpm::WebIDL::Argument->new ($id);
        $arg->set_user_data (manakai_source_line => $line);
        $arg->set_user_data (manakai_source_column => $column);
        $arg->type ($current_type);
        $arg->set_extended_attribute_node ($_) for @$xattrs;
        $current[-1]->append_child ($arg);
        $token = $get_next_token->();
        if ($token->{type} eq ')') {
          $token = $get_next_token->();
          if ($current[-1]->isa ('Whatpm::WebIDL::Operation')) {
            $state = 'before raises';
          } else {
            $state = 'after xattrarg';
          }
          next;
        } elsif ($token->{type} eq ',') {
          $token = $get_next_token->();
          $state = 'before argument';
          next;
        } else {
          $onerror->(type => 'after argument',
                     level => $self->{level}->{must});
          #
        }
      } else {
        $onerror->(type => 'no webidl identifier:argument',
                   level => $self->{level}->{must});
        #
      }
      # reconsume
      $state = 'ignore';
      $nest_level = 0;
    } elsif ($state eq 'before argument') {
      $xattrs = [];
      if ($token->{type} eq '[') {
        $token = $get_next_token->();
        $state = 'before xattr';
        $next_state = 'before argument in';
      } else {
        # reconsume
        $state = 'before argument in';
      }
    } elsif ($state eq 'before argument in') {
      if ($token->{type} eq 'in') {
        $token = $get_next_token->();
        $state = 'before argument type';
      } else {
        $onerror->(type => 'no argument in',
                   level => $self->{level}->{must});
        $state = 'ignore';
        $nest_level = 0;
      }
    } elsif ($state eq 'before raises') {
      if ($token->{type} eq 'raises') {
        $token = $get_next_token->();
        $state = 'after raises';
        $next_state = '*raises';
      } else {
        # reconsume
        $state = 'before semicolon';
        $next_state = 'before interface member';
      }
    } elsif ($state eq 'after raises') {
      if ($token->{type} eq '(') {
        $token = $get_next_token->();
        $state = 'before exception name';
      } else {
        $onerror->(type => 'no raises lparen',
                   level => $self->{level}->{must});
        $state = 'ignore';
        $nest_level = 0;
      }
    } elsif ($state eq 'before semicolon') {
      if ($token->{type} eq ';') {
        $current[-2]->append_child ($current[-1]);
        pop @current;
        $token = $get_next_token->();
        if ($current[-1]->isa ('Whatpm::WebIDL::Definitions') or
            $current[-1]->isa ('Whatpm::WebIDL::Module')) {
          $state = 'before definitions';
        } elsif ($current[-1]->isa ('Whatpm::WebIDL::Interface')) {
          $state = 'before members';
          $next_state = 'before interface member';
        } else {
          $state = 'before members';
          $next_state = 'before exception member';
        }
      } else {
        $onerror->(type => 'no webidl semicolon',
                   level => $self->{level}->{must});
        # reconsume
        $state = 'ignore';
        $nest_level = 0;
      }
    } elsif ($state eq 'before block semicolon') {
      if ($token->{type} eq ';') {
        $current[-2]->append_child ($current[-1]);
        pop @current;
        $token = $get_next_token->();
        if ($current[-1]->isa ('Whatpm::WebIDL::Definitions') or
            $current[-1]->isa ('Whatpm::WebIDL::Module')) {
          $state = 'before definitions';
        } elsif ($current[-1]->isa ('Whatpm::WebIDL::Interface')) {
          $state = 'before members';
          $next_state = 'before interface member';
        } else {
          $state = 'before members';
          $next_state = 'before exception member';
        }
      } else {
        $onerror->(type => 'no webidl semicolon',
                   level => $self->{level}->{must});
        pop @current; # avoid appended by 'ignore'
        # reconsume
        $state = 'ignore';
        $nest_level = 0;
      }
    } elsif ($state eq 'ignore') {
      if ($nest_level == 0 and $token->{type} eq ';') {
        while (@current > 1) {
          if ($current[-1]->isa ('Whatpm::WebIDL::Interface') or
              $current[-1]->isa ('Whatpm::WebIDL::Exception') or
              $current[-1]->isa ('Whatpm::WebIDL::Module')) {
            last;
          }
          pop @current;
        }

        $token = $get_next_token->();
        if ($current[-1]->isa ('Whatpm::WebIDL::Definitions') or
            $current[-1]->isa ('Whatpm::WebIDL::Module')) {
          $state = 'before definitions';
        } elsif ($current[-1]->isa ('Whatpm::WebIDL::Interface')) {
          $state = 'before members';
          $next_state = 'before interface member';
        } else {
          $state = 'before members';
          $next_state = 'before exception member';
        }
      } elsif ($token->{type} eq '{') {
        $nest_level++;
        $token = $get_next_token->();
        # stay in the state
      } elsif ($nest_level and $token->{type} eq '}') {
        $nest_level--;
        $token = $get_next_token->();
        # stay in the state
      } elsif ($token->{type} eq 'eof') {
        while (@current > 1) {
          if ($current[-1]->isa ('Whatpm::WebIDL::Interface') or
              $current[-1]->isa ('Whatpm::WebIDL::Exception') or
              $current[-1]->isa ('Whatpm::WebIDL::Module')) {
            last;
          }
          pop @current;
        }

        last;
      } else {
        # ignore the token
        $token = $get_next_token->();
        # stay in the state
      }
    } else {
      die "parse_char_string: unkown state: $state";
    }
  }

  if (@current > 1) {
    $onerror->(type => 'premature end of webidl',
               level => $self->{level}->{must});
    while (@current > 1) {
      $current[-2]->append_child ($current[-1]);
      pop @current;
    }
  }

  $get_type = undef; # unlink loop

  return $defs;
} # parse_char_string

package Whatpm::WebIDL::Node;

require Scalar::Util;

sub new ($) {
  return bless {child_nodes => []}, $_[0];
} # new

sub append_child ($$) {
  my $self = shift;
  my $child = shift;
  
  ## TODO: child type
  ## TODO: parent check

  push @{$self->{child_nodes}}, $child;

  $child->{parent_node} = $self;
  Scalar::Util::weaken ($child->{parent_node});

  return $child;
} # append_child

sub child_nodes ($) {
  return [@{$_[0]->{child_nodes}}]; # dead list
} # child_nodes

sub idl_text ($) {
  return '[[ERROR: ' . (ref $_[0]) . '->idl_text]]';
} # idl_text

sub node_name ($) {
  return $_[0]->{node_name}; # may be undef
} # node_name

sub parent_node ($) {
  return $_[0]->{parent_node};
} # parent_node

sub get_user_data ($$) {
  return $_[0]->{user_data}->{$_[1]};
} # get_user_data

sub set_user_data ($$$) {
  if (defined $_[2]) {
    $_[0]->{user_data}->{$_[1]} = ''.$_[2];
  } else {
    delete $_[0]->{user_data}->{$_[1]};
  }
} # set_user_data

sub has_extended_attribute ($$) {
  my $self = shift;
  my $name = shift;
  $name = '' unless defined $name;
  for (@{$self->{xattrs} or []}) {
    if ($_->node_name eq $name) {
      return 1;
    }
  }
  return 0;
} # has_extended_attribute

sub get_extended_attribute_nodes ($$) {
  my $self = shift;
  my $name = shift;
  $name = '' unless defined $name;
  my $r = [];
  for (@{$self->{xattrs} or []}) {
    if ($_->node_name eq $name) {
      push @$r, $_;
    }
  }
  return $r;
} # get_extended_attribute_nodes

package Whatpm::WebIDL::Definitions;
push our @ISA, 'Whatpm::WebIDL::Node';

sub idl_text ($) {
  return join "\x0A", map {$_->idl_text} @{$_[0]->{child_nodes}};
} # idl_text

my $xattr_defs = {
  Constructor => {
    #allow_id => 0,
    allow_arglist => 1,
    allowed_type => {Interface => 1},
    allow_multiple => 1,
    check => sub {
      my ($self, $onerror, $levels, $items, $item, $xattr, $xattr_name,
          $resolve, $constructors) = @_;

      ## NOTE: Arguments
      unshift @$items,
          map { {node => $_, scope => $item->{scope}} }
          @{$xattr->{child_nodes}};
    },
  },
  ExceptionConsts => {
    allow_id => 1,
    #allow_arglist => 0,
    allowed_type => {Module => 1},
    #allow_multiple => 0,
    check => sub {
      my ($self, $onerror, $levels, $items, $item, $xattr, $xattr_name,
          $resolve, $constructors) = @_;

      my $id = $xattr->value;
      if (defined $id) {
        my $has_x;
        for my $x (@{$item->{node}->child_nodes}) {
          next unless $x->isa ('Whatpm::WebIDL::Exception');
          if ($x->node_name eq $id) {
            $has_x = 1;
            last;
          }
        }
        unless ($has_x) {
          $onerror->(type => 'exception not defined',
                     text => $id,
                     node => $xattr,
                     level => $levels->{must});
        }
      } else {
        $onerror->(type => 'xattr id missing',
                   text => $xattr_name,
                   node => $xattr,
                   level => $levels->{must});
      }
    },
  },
  IndexGetter => {
    #allow_id => 0,
    #allow_arglist => 0,
    allowed_type => {Operation => 1},
    #allow_multiple => 0,
    check => sub {
      my ($self, $onerror, $levels, $items, $item, $xattr, $xattr_name,
          $resolve, $constructors) = @_;

      if (@{$item->{node}->{child_nodes}} != 1 or
          $item->{node}->{child_nodes}->[0]->type_text ne 'unsigned long') {
        $onerror->(type => 'wrong signature accessor',
                   text => $xattr_name,
                   node => $xattr,
                   level => $levels->{fact});
      }
      if ($item->{defined_accessors}->{$xattr_name} and
          $item->{defined_accessors}->{$xattr_name} ne $item->{node}) {
        $onerror->(type => 'duplicate accessor',
                   text => $xattr_name,
                   node => $xattr,
                   level => $levels->{undefined});
      }
      $item->{defined_accessors}->{$xattr_name} = $item->{node};
    },
  },
  IndexSetter => {
    #allow_id => 0,
    #allow_arglist => 0,
    allowed_type => {Operation => 1},
    #allow_multiple => 0,
    check => sub {
      my ($self, $onerror, $levels, $items, $item, $xattr, $xattr_name,
          $resolve, $constructors) = @_;

      if (@{$item->{node}->{child_nodes}} != 2 or
          $item->{node}->{child_nodes}->[0]->type_text ne 'unsigned long') {
        $onerror->(type => 'wrong signature accessor',
                   text => $xattr_name,
                   node => $xattr,
                   level => $levels->{fact});
      }
      if ($item->{defined_accessors}->{$xattr_name} and
          $item->{defined_accessors}->{$xattr_name} ne $item->{node}) {
        $onerror->(type => 'duplicate accessor',
                   text => $xattr_name,
                   node => $xattr,
                   level => $levels->{undefined});
      }
      $item->{defined_accessors}->{$xattr_name} = $item->{node};
    },
  },
  NameGetter => {
    #allow_id => 0,
    #allow_arglist => 0,
    allowed_type => {Operation => 1},
    #allow_multiple => 0,
    check => sub {
      my ($self, $onerror, $levels, $items, $item, $xattr, $xattr_name,
          $resolve, $constructors) = @_;

      if (@{$item->{node}->{child_nodes}} != 1 or
          $item->{node}->{child_nodes}->[0]->type_text ne 'DOMString') {
        $onerror->(type => 'wrong signature accessor',
                   text => $xattr_name,
                   node => $xattr,
                   level => $levels->{fact});
      }
      if ($item->{defined_accessors}->{$xattr_name} and
          $item->{defined_accessors}->{$xattr_name} ne $item->{node}) {
        $onerror->(type => 'duplicate accessor',
                   text => $xattr_name,
                   node => $xattr,
                   level => $levels->{undefined});
      }
      $item->{defined_accessors}->{$xattr_name} = $item->{node};
    },
  },
  NameSetter => {
    #allow_id => 0,
    #allow_arglist => 0,
    allowed_type => {Operation => 1},
    #allow_multiple => 0,
    check => sub {
      my ($self, $onerror, $levels, $items, $item, $xattr, $xattr_name,
          $resolve, $constructors) = @_;

      if (@{$item->{node}->{child_nodes}} != 2 or
          $item->{node}->{child_nodes}->[0]->type ne '::DOMString::') {
        $onerror->(type => 'wrong signature accessor',
                   text => $xattr_name,
                   node => $xattr,
                   level => $levels->{fact});
      }
      if ($item->{defined_accessors}->{$xattr_name} and
          $item->{defined_accessors}->{$xattr_name} ne $item->{node}) {
        $onerror->(type => 'duplicate accessor',
                   text => $xattr_name,
                   node => $xattr,
                   level => $levels->{undefined});
      }
      $item->{defined_accessors}->{$xattr_name} = $item->{node};
    },
  },
  Null => {
    allow_id => 1,
    #allow_arglist => 0,
    allowed_type => {Argument => 1, Attribute => 1},
        ## ISSUE: Is this allwoed for extended attribute's arguments?
    #allow_multiple => 0,
    check => sub {
      my ($self, $onerror, $levels, $items, $item, $xattr, $xattr_name,
          $resolve, $constructors) = @_;
      
      ## ISSUE: [Null=Empty] readonly attribute is not disallowed

      if ($item->{node}->type ne '::DOMString::') {
        $onerror->(type => 'xattr for wrong type',
                   text => $xattr_name,
                   node => $xattr,
                   level => $levels->{fact});
      }

      my $id = $xattr->value;
      if (defined $id) {
        if ($id eq 'Null' or $id eq 'Empty') {
          #
        } else {
          $onerror->(type => 'xattr id value not allowed',
                     text => $xattr_name,
                     value => $id,
                     node => $xattr,
                     level => $levels->{must});
        }
      } else {
        $onerror->(type => 'xattr id missing',
                   text => $xattr_name,
                   node => $xattr,
                   level => $levels->{must});
      }
    },
  },
  PutForwards => {
    allow_id => 1,
    #allow_arglist => 0,
    allowed_type => {Attribute => 1},
    #allow_multiple => 0,
    check => sub {
      my ($self, $onerror, $levels, $items, $item, $xattr, $xattr_name,
          $resolve, $constructors) = @_;

      ## NOTE: Direct or indirect cirlic reference is not an error.

      unless ($item->{node}->readonly) {
        $onerror->(type => 'attr not readonly',
                   text => $xattr_name,
                   node => $xattr,
                   level => $levels->{fact});
      }
      
      my $type_item = $resolve->($item->{node}->type, $item->{scope});
      if ($type_item and
          $type_item->{node}->isa ('Whatpm::WebIDL::Interface')) {
        my $id = $xattr->value;
        if (defined $id) {
          ## ISSUE: "attribute that exists on the interface and which
          ## has the same type as this attribute.": "same type"?
          ## ISSUE: must be read-write attribute?

          my $check = sub ($) {
            my $type_item = shift;
            
            A: {
              for my $attr (@{$type_item->{node}->{child_nodes}}) {
                next unless $attr->isa ('Whatpm::WebIDL::Attribute');
                if ($attr->node_name eq $id) {
                  last A;
                }
              }
              
              $onerror->(type => 'referenced attr not defined',
                         text => $xattr_name,
                         value => $id,
                         node => $xattr,
                         level => $levels->{must});
            } # A
          }; # $check

          if ($type_item->{node}->is_forward_declaration) {
            ## NOTE: Checked later.
            push @$items, {code => sub {
              $check->($resolve->($item->{node}->type, $item->{scope}));
            }};
          } else {
            $check->($type_item);
          }
        } else {
          $onerror->(type => 'xattr id missing',
                     text => $xattr_name,
                     node => $xattr,
                     level => $levels->{must});
        }
      } else {
        ## NOTE: Builtin types, or undefined interface
        $onerror->(type => 'attr type not interface',
                   text => $xattr_name,
                   node => $xattr,
                   level => $levels->{fact});
      }
    },
  },
  Stringifies => {
    allow_id => 1,
    #allow_arglist => 0,
    allowed_type => {Interface => 1},
    #allow_multiple => 0,
    check => sub {
      my ($self, $onerror, $levels, $items, $item, $xattr, $xattr_name,
          $resolve, $constructors) = @_;

      my $id = $xattr->value;
      if (defined $id) {
        A: {
          for my $attr (@{$item->{node}->{child_nodes}}) {
            next unless $attr->isa ('Whatpm::WebIDL::Attribute');
            if ($attr->node_name eq $id) {
              last A;
            }
          }

          $onerror->(type => 'referenced attr not defined',
                     text => $xattr_name,
                     value => $id,
                     node => $xattr,
                     level => $levels->{must});
        } # A
      }
    },
  },
  Variadic => {
    #allow_id => 0,
    #allow_arglist => 0,
    allowed_type => {Argument => 1},
    #allow_multiple => 0,
    check => sub {
      my ($self, $onerror, $levels, $items, $item, $xattr, $xattr_name,
          $resolve, $constructors) = @_;
      
      ## ISSUE: is this allowed on extended attribute arguuments?

      ## NOTE: If this is not the final argument, then an error will
      ## be raised later.
      $item->{has_arg_xattr}->{variadic} = 1;
    },
  },

  ## ECMAScript specific extended attributes
  NamedConstructor => {
    allow_id => 1,
    allow_arglist => 1,
    allowed_type => {Interface => 1, Exception => 1},
    allow_multiple => 1,
    check => sub {
      my ($self, $onerror, $levels, $items, $item, $xattr, $xattr_name,
          $resolve, $constructors) = @_;
      
      ## NOTE: [NamedConstructor=a,NamedConstructor=a] is not disallowed.

      my $id = $xattr->value;
      if (defined $id) {
        if ($constructors->{$id} and
            $constructors->{$id}->{node} ne $item->{node}) {
          $onerror->(type => 'duplicate constructor name',
                     value => $id,
                     node => $xattr,
                     level => $levels->{must});
        } else {
          $constructors->{$id} = {node => $item->{node},
                                  is_named_constructor => $xattr};
        }
      } else {
        $onerror->(type => 'xattr id missing',
                   text => $xattr_name,
                   node => $xattr,
                   level => $levels->{must});
      }
    },
  },
  NativeObject => {
    allow_id => 1,
    #allow_arglist => 0,
    allowed_type => {Interface => 1},
    #allow_multiple => 0,
    check => sub {
      my ($self, $onerror, $levels, $items, $item, $xattr, $xattr_name,
          $resolve, $constructors) = @_;

      my $id = $xattr->value;
      if (defined $id and $id ne 'FunctionOnly') {
        $onerror->(type => 'xattr id value not allowed',
                   text => $xattr_name,
                   value => $id,
                   node => $xattr,
                   level => $levels->{must});
      }

      ## TODO: We should warn if the condition in the section 4.5 is not met.
    },
  },
  NoInterfaceObject => {
    #allow_id => 0,
    #allow_arglist => 0,
    allowed_type => {Interface => 1, Exception => 1},
    #allow_multiple => 0,
    check => sub {
      my ($self, $onerror, $levels, $items, $item, $xattr, $xattr_name,
          $resolve, $constructors) = @_;

      ## ISSUE: [Constructor, NoInterfaceObject]
    },
  },
  Undefined => {
    allow_id => 1,
    #allow_arglist => 0,
    allowed_type => {Argument => 1, Attribute => 1},
        ## ISSUE: Is this allwoed for extended attribute's arguments?
    #allow_multiple => 0,
    #check : is set later
  },
}; # $xattr_defs
$xattr_defs->{Undefined}->{check} = $xattr_defs->{Null}->{check};

sub check ($$;$) {
  my ($self, $onerror, $levels) = @_;

  $levels ||= $default_levels;

  my $check_const_value = sub ($) {
    my $item = shift;
    
    my $type = $item->{node}->type;
    my $value = $item->{node}->value;
    
    ## NOTE: Although it is not explicitly spelled out in the spec,
    ## it can be assumed, imho, that "any" type accepts all of these
    ## constant values.
    ## ISSUE: Should I ask the editor to clarify the spec about this?

    if ($value->[0] eq 'TRUE' or $value->[0] eq 'FALSE') {
      if ($type eq '::boolean::') {
        #
      } elsif ($type eq '::any::') {
        #
      } else {
        $onerror->(type => 'const type mismatch',
                   node => $item->{node},
                   text => $item->{node}->type_text,
                   value => $value->[0],
                   level => $levels->{must});
          }
        } elsif ($value->[0] eq 'integer') {
          if ($type eq '::octet::') {
            if ($value->[1] < 0 or 255 < $value->[1]) {
              $onerror->(type => 'const value out of range',
                         text => $item->{node}->type_text,
                         value => $value->[1],
                         node => $item->{node},
                         level => $levels->{must});
            }
          } elsif ($type eq '::short::') {
            if ($value->[1] < -32768 or 32767 < $value->[1]) {
              $onerror->(type => 'const value out of range',
                         text => $item->{node}->type_text,
                         value => $value->[1],
                         node => $item->{node},
                         level => $levels->{must});
            }
          } elsif ($type eq '::unsigned short::') {
            if ($value->[1] < 0 or 65535 < $value->[1]) {
              $onerror->(type => 'const value out of range',
                         text => $item->{node}->type_text,
                         value => $value->[1],
                         node => $item->{node},
                         level => $levels->{must});
            }
          } elsif ($type eq '::long::') {
            if ($value->[1] < -2147483648 or 2147483647 < $value->[1]) {
              $onerror->(type => 'const value out of range',
                         text => $item->{node}->type_text,
                         value => $value->[1],
                         node => $item->{node},
                         level => $levels->{must});
            }
          } elsif ($type eq '::unsigned long::') {
            if ($value->[1] < 0 or 4294967295 < $value->[1]) {
              $onerror->(type => 'const value out of range',
                         text => $item->{node}->type_text,
                         value => $value->[1],
                         node => $item->{node},
                         level => $levels->{must});
            }
          } elsif ($type eq '::long long::') {
            if ($value->[1] < -9223372036854775808 or
                9223372036854775807 < $value->[1]) {
              $onerror->(type => 'const value out of range',
                         text => $item->{node}->type_text,
                         value => $value->[1],
                         node => $item->{node},
                         level => $levels->{must});
            }
          } elsif ($type eq '::unsigned long long::') {
            if ($value->[1] < 0 or 18446744073709551615 < $value->[1]) {
              $onerror->(type => 'const value out of range',
                         text => $item->{node}->type_text,
                         value => $value->[1],
                         node => $item->{node},
                         level => $levels->{must});
            }
          } elsif ($type eq '::any::') {
            if ($value->[1] < -9223372036854775808 or
                18446744073709551615 < $value->[1]) {
              $onerror->(type => 'const value out of range',
                         text => $item->{node}->type_text,
                         value => $value->[1],
                         node => $item->{node},
                         level => $levels->{must});
            }
          } else {
            $onerror->(type => 'const type mismatch',
                       text => $item->{node}->type_text,
                       value => $value->[1],
                       node => $item->{node},
                       level => $levels->{must});
          }
        } elsif ($value->[0] eq 'float') {
          if ($type eq '::float::' or $type eq '::any::') {
            #
          } else {
            $onerror->(type => 'const type mismatch',
                       text => $item->{node}->type_text,
                       value => $value->[1],
                       node => $item->{node},
                       level => $levels->{must});
          }
        }
        ## NOTE: Otherwise, an error of the implementation or the application.
  }; # $check_const_value

  my $defined_qnames = {};
  my $resolve = sub ($$) {
    my $i_sn = shift;
    my $scope = shift;
    
    if ($i_sn =~ /\A::(?>[^:]+)::\z/ or
        $i_sn =~ /^::::sequence::::/) {
      return undef;
    } elsif ($i_sn =~ /::DOMString\z/ or
             $i_sn =~ /::DOMString::::\z/) {
      return undef;
    } elsif ($i_sn =~ /^::/) {
      if ($defined_qnames->{$i_sn}) {
        return $defined_qnames->{$i_sn};
      } else {
        return undef;
      }
    } else {
      if ($defined_qnames->{$scope . $i_sn}) {
        return $defined_qnames->{$scope . $i_sn};
      } elsif ($defined_qnames->{'::' . $i_sn}) {
        return $defined_qnames->{'::' . $i_sn};
      } else {
        return undef;
      }
    }
  }; # $resolve

  my $items = [map { {node => $_, scope => '::'} } @{$self->{child_nodes}}];

  my $constructors = {};
      ## NOTE: Items are: identifier => {node => $interface_or_exception,
      ## is_named_constructor => $named_constructor_xattr/undef}.

  while (@$items) {
    my $item = shift @$items;
    if (not $item->{node}) {
      $item->{code}->();
      next;
    } elsif ($item->{node}->isa ('Whatpm::WebIDL::Definition') and
             not $item->{defined_members}) {
                 ## NOTE: Const in Interface does not have this.
      if ($item->{node}->isa ('Whatpm::WebIDL::Module')) {
        unshift @$items,
            map {
              {node => $_, parent => $item->{node},
               scope => $item->{scope} . $item->{node}->node_name . '::'}
            }
            @{$item->{node}->{child_nodes}};
      } else {
        unless ($item->{parent}) {
          $onerror->(type => 'non-module definition',
                     node => $item->{node},
                     level => $levels->{should});
        }
      }

      if ($item->{node}->isa ('Whatpm::WebIDL::Interface')) {
        for my $i_sn (@{$item->{node}->{inheritances}}) {
          my $def = $resolve->($i_sn, $item->{scope});

          unless ($def and $def->{node}->isa ('Whatpm::WebIDL::Interface')) {
            $i_sn =~ s/::DOMString::::\z/::DOMString/;
            $onerror->(type => 'interface not defined',
                       node => $item->{node},
                       text => $i_sn,
                       level => $levels->{must});
          }
        }

        my $defined_members = {};
        my $defined_accessors = {};
        unshift @$items,
            map { {node => $_, defined_members => $defined_members,
                   defined_accessors => $defined_accessors,
                   scope => $item->{scope}} }
            @{$item->{node}->{child_nodes}};
      } elsif ($item->{node}->isa ('Whatpm::WebIDL::Exception')) {
        my $defined_members = {};
        unshift @$items,
            map { {node => $_, defined_members => $defined_members,
                   scope => $item->{scope}} }
            @{$item->{node}->{child_nodes}};
      } elsif ($item->{node}->isa ('Whatpm::WebIDL::Const')) {
        $check_const_value->($item);
      } elsif ($item->{node}->isa ('Whatpm::WebIDL::Typedef')) {
        my $name = $item->{node}->node_name;
        my $type = $item->{node}->type;
        if ($name eq '::DOMString::' or
            $type eq '::DOMString::' or
            $type =~ /::DOMString::::\z/) {
          $onerror->(type => 'typedef ignored',
                     node => $item->{node},
                     level => $levels->{info});
        }
        ## ISSUE: Refernece to a non-defined interface is not non-conforming.

        ## ISSUE: What does "ignored" mean?
        ## "typedef dom::DOMString a; typedef long a;" is conforming?
        ## "typedef dom::DOMString b; interface c { attribute b d; };" is?

        ## ISSUE: Is "sequence<undefinedtype>" conforming?

        if ($type =~ /\A::([^:]+)::\z/) {
          $item->{allow_null} = {
            boolean => 1, octet => 1, short => 1, 'unsigned short' => 1,
            long => 1, 'unsigned long' => 1, 'long long' => 1, 
            'unsigned long long' => 1, float => 1,
          }->{$1};
        } elsif ($type =~ /^::::sequence::::/) {
          $item->{allow_null} = 1;
        } else {
          my $def = $resolve->($type, $item->{scope});
          $item->{allow_null} = $def->{allow_null};
        }
      } elsif ($item->{node}->isa ('Whatpm::WebIDL::Valuetype')) {
        my $name = $item->{node}->node_name;
        if ($name eq '::DOMString::') {
          $onerror->(type => 'valuetype ignored',
                     node => $item->{node},
                     level => $levels->{info});
        } else {
          my $type = $item->{node}->type;
          if ($type =~ /\A::[^:]+::\z/) {
            #
          } elsif ($type =~ /^::::sequence::::/) {
            ## ISSUE: Is "sequence<unknowntype>" conforming?
          } else {
            my $def = $resolve->($type, $item->{scope});
            if ($def and 
                $def->{allow_null}) {
              #
            } else {
              ## ISSUE: It is not explicitly specified that ScopedName
              ## must refer a defined type.
              $onerror->(type => 'not boxable type',
                         text => $item->{node}->type_text,
                         node => $item->{node},
                         level => $levels->{must});
            }
          }
        }
      }

      my $qname = $item->{node}->qualified_name;
      if ($defined_qnames->{$qname}) {
        ## NOTE: "The identifier of a definition MUST  be locally unique":
        ## Redundant with another requirement below.

        ## ISSUE: |interface x; interface x {};| is non-conforming
        ## according to the current spec text.

        ## ISSUE: |interface x;| with no |interface x {};| is conforming
        ## according to the current spec text.

        ## ISSUE: |interface x; exception x {}|

        $onerror->(type => 'duplicate qname',
                   node => $item->{node},
                   level => $levels->{must},
                   text => $qname);

        if ($item->{node}->isa ('Whatpm::WebIDL::Interface') and
            $defined_qnames->{$qname}->{node}->isa
                ('Whatpm::WebIDL::Interface') and
            $defined_qnames->{$qname}->{node}->is_forward_declaration) {
          $defined_qnames->{$qname} = $item;
        }
      } else {
        $defined_qnames->{$qname} = $item;
        ## NOTE: This flag must be turned on AFTER inheritance check is
        ## performed (c.f. |interface x : x {};|).
      }
    } elsif ($item->{node}->isa ('Whatpm::WebIDL::InterfaceMember')) {
      if ($item->{node}->isa ('Whatpm::WebIDL::Operation')) {
        ## NOTE: Arguments
        my $has_arg_xattr = {};
        unshift @$items,
            map { {node => $_, scope => $item->{scope},
                   has_arg_xattr => $has_arg_xattr} }
            @{$item->{node}->{child_nodes}};
      } else {
        my $name = $item->{node}->node_name;
        if ($item->{defined_members}->{$name}) {
          $onerror->(type => 'duplicate member',
                     node => $item->{node},
                     text => $name,
                     level => $levels->{must});
          ## ISSUE: Whether the example below is conforming or not
          ## is ambigious:
          ## |interface a { attribute any b; any b (); };|
        } else {
          $item->{defined_members}->{$name} = 1;
        }
      }

      if ($item->{node}->isa ('Whatpm::WebIDL::Attribute') or
          $item->{node}->isa ('Whatpm::WebIDL::Operation')) {
        my $type = $item->{node}->type;
        if ($type =~ /\A::[^:]+::\z/) { # note that sequence<> not allowed
          #
        } else { # scoped name
          my $def = $resolve->($type, $item->{scope});
          
          unless ($def and
                  ($def->{node}->isa ('Whatpm::WebIDL::Interface') or
                   $def->{node}->isa ('Whatpm::WebIDL::Typedef') or
                   $def->{node}->isa ('Whatpm::WebIDL::Valuetype'))) {
            $onerror->(type => 'type not defined',
                       node => $item->{node},
                       text => $item->{node}->type_text,
                       level => $levels->{must});
          }
        }
                
        for (@{$item->{node}->{raises} or []}, # for operations
             @{$item->{node}->{getraises} or []}, # for attributes
             @{$item->{node}->{setraises} or []}) { # for attributes
          my $def = $resolve->($_, $item->{scope});
          
          unless ($def and
                  $def->{node}->isa ('Whatpm::WebIDL::Exception')) {
            $onerror->(type => 'exception not defined',
                       text => $_,
                       node => $item->{node},
                       level => $levels->{must});
          }
        }
        
        ## ISSUE: readonly setraises is not disallowed
        ## ISSUE: raises (x,x) and raises (x,::x) and etc. are not disallowed
      } elsif ($item->{node}->isa ('Whatpm::WebIDL::Const')) {
        $check_const_value->($item);
      }
    } elsif ($item->{node}->isa ('Whatpm::WebIDL::Argument') or
             $item->{node}->isa ('Whatpm::WebIDL::ExceptionMember')) {
      if ($item->{has_arg_xattr}->{variadic} and
          $item->{node}->isa ('Whatpm::WebIDL::Argument')) {
        $onerror->(type => 'argument after variadic',
                   node => $item->{node},
                   level => $levels->{fact});
      }

      ## ISSUE: No uniqueness constraints for arguments in an operation,
      ## so we don't check it for arguments.

      ## ISSUE: For extended attributes, semantics of the argument
      ## (e.g. the identifier is given by the |identifier| in the |Argument|)
      ## is not explicitly defined.  In addition, no uniqueness constraint
      ## is defined, so we don't check it for arguments.

      my $name = $item->{node}->node_name;
      if ($item->{defined_members}->{$name}) {
        $onerror->(type => 'duplicate member',
                   text => $name,
                   node => $item->{node},
                   level => $levels->{must});
      } else {
        $item->{defined_members}->{$name} = 1;
      }

      my $type = $item->{node}->type;
      if ($type =~ /\A::[^:]+::\z/) { # note that sequence<> not allowed
        #
      } else { # scoped name
        my $def = $resolve->($type, $item->{scope});
        
        unless ($def and
                ($def->{node}->isa ('Whatpm::WebIDL::Interface') or
                 $def->{node}->isa ('Whatpm::WebIDL::Typedef') or
                 $def->{node}->isa ('Whatpm::WebIDL::Valuetype'))) {
          $onerror->(type => 'type not defined',
                     text => $item->{node}->type_text,
                     node => $item->{node},
                     level => $levels->{must});
        }
      }
    }

    my $xattrs = $item->{node}->{xattrs} || [];
    my $has_xattr;
    X: for my $xattr (@$xattrs) {
      my $xattr_name = $xattr->node_name;
      my $xattr_def = $xattr_defs->{$xattr_name};

      unless ($xattr_def) {
        $onerror->(type => 'unknown xattr',
                   text => $xattr_name,
                   node => $xattr,
                   level => $levels->{uncertain});
        next X;
      }

      A: {
        for my $cls (keys %{$xattr_def->{allowed_type} or {}}) {
          if ($item->{node}->isa ('Whatpm::WebIDL::' . $cls)) {
            if ($cls eq 'Interface' and
                $item->{node}->is_forward_declaration) {
              #
            } else {
              last A;
            }
          }
        }

        $onerror->(type => 'xattr not applicable',
                   text => $xattr_name,
                   node => $xattr,
                   level => $levels->{fact});
        next X;
      } # A

      if ($has_xattr->{$xattr_name} and not $xattr_def->{allow_multiple}) {
        ## ISSUE: Whether multiple extended attributes with the same
        ## name are allowed is not explicitly specified in the spec.
        ## It is, however, specified that some extended attributes may
        ## be specified more than once.
        $onerror->(type => 'duplicate xattr',
                   text => $xattr_name,
                   node => $xattr,
                   level => $levels->{warn});
      }
      $has_xattr->{$xattr_name} = 1;

      if (not $xattr_def->{allow_id} and defined $xattr->value) {
        $onerror->(type => 'xattr id not allowed',
                   text => $xattr_name,
                   node => $xattr,
                   level => $levels->{must});
      }
      if (not $xattr_def->{allow_arglist} and $xattr->has_argument_list) {
        $onerror->(type => 'xattr arglist not allowed',
                   text => $xattr_name,
                   node => $xattr,
                   level => $levels->{must});
      }

      $xattr_def->{check}->($self, $onerror, $levels, $items, $item,
                            $xattr, $xattr_name, $resolve, $constructors);
    }

    if (not $has_xattr->{NoInterfaceObject} and
        (($item->{node}->isa ('Whatpm::WebIDL::Interface') and
          not $item->{node}->is_forward_declaration) or
         $item->{node}->isa ('Whatpm::WebIDL::Exception'))) {
      my $id = $item->{node}->node_name;
      if ($constructors->{$id} and
          $constructors->{$id}->{is_named_constructor}) {
        $onerror->(type => 'duplicate constructor name',
                   value => $id,
                   node => $constructors->{$id}->{is_named_constructor},
                   level => $levels->{must});
      } else {
        ## NOTE: Duplication is not checked in this case, since any
        ## duplication of interface/exception identifiers are detected
        ## by the parser.
        $constructors->{$id} = {node => $item->{node}};
      }
    }
  }
} # check

package Whatpm::WebIDL::Definition;
push our @ISA, 'Whatpm::WebIDL::Node';

sub new ($$) {
  return bless {child_nodes => [], node_name => ''.$_[1]}, $_[0];
} # new

sub set_extended_attribute_node ($$) {
  my $self = shift;
  ## TODO: check
  push @{$self->{xattrs} ||= []}, shift;
} # set_extended_attribute_node

sub _xattrs_text ($) {
  my $self = shift;

  unless ($self->{xattrs} and
          @{$self->{xattrs}}) {
    return '';
  }

  my $r = '[';
  $r .= join ', ', map {$_->idl_text} @{$self->{xattrs}};
  $r .= ']';
  return $r;
} # _xattrs_text

sub qualified_name ($) {
  my $self = shift;

  my $parent = $self->{parent_node};
  if ($parent and $parent->isa ('Whatpm::WebIDL::Definition')) {
    return $parent->qualified_name . '::' . $self->{node_name};
  } else {
    return '::' . $self->{node_name};
  }
} # qualified_name

sub type ($;$) {
  if (@_ > 1) {
    if (defined $_[1]) {
      $_[0]->{type} = $_[1];
    } else {
      $_[0]->{type} = '::any::';
    }
  }
  return $_[0]->{type};
} # type

  my $serialize_type;
  $serialize_type = sub ($) {
    my $type = shift;
    if ($type =~ s/^::::sequence:::://) {
      return 'sequence<' . $serialize_type->($type) . '>';
    } elsif ($type =~ /\A::([^:]+)::\z/) {
      return $1;
    } else {
      $type =~ s/::DOMString::::\z/::DOMString/;
      return $type; ## TODO: escape identifiers...
    }
  }; # $serialize_type

sub type_text ($) {
  my $type = $_[0]->{type};
  return undef unless defined $type;

  return $serialize_type->($type);
} # type_text

package Whatpm::WebIDL::Module;
push our @ISA, 'Whatpm::WebIDL::Definition';

sub idl_text ($) {
  my $self = shift;
  my $r = $self->_xattrs_text;
  $r .= ' ' if length $r;
  $r .= 'module ' . $self->node_name . " {\x0A\x0A"; ## TODO: escape
  for (@{$self->{child_nodes}}) {
    $r .= $_->idl_text;
  }
  $r .= "\x0A};\x0A";
  return $r;
} # idl_text

package Whatpm::WebIDL::Interface;
push our @ISA, 'Whatpm::WebIDL::Definition';

sub new ($$) {
  my $self = shift->SUPER::new (@_);
  $self->{inheritances} = [];
  return $self;
} # new

sub append_inheritance ($$) {
  my $self = shift;
  my $scoped_name = shift;
  push @{$self->{inheritances}}, $scoped_name;
} # append_inheritance

sub inheritances ($) {
  ## NOTE: Returns a dead list of scoped names of inheriting interfaces.
  return [@{$_[0]->{inheritances}}];
} # inheritances

sub idl_text ($) {
  my $self = shift;
  my $r = $self->_xattrs_text;
  $r .= ' ' if length $r;
  $r .= 'interface ' . $self->node_name;

  if ($self->{is_forward_declaration}) {
    $r .= ";\x0A";
    return $r;
  }

  if (@{$self->{inheritances}}) {
    $r .= ' : '; ## TODO: ...
    $r .= join ', ', map {$serialize_type->($_)} @{$self->{inheritances}};
  }
  $r .= " {\x0A"; ## TODO: escape
  for (@{$self->{child_nodes}}) {
    $r .= '  ' . $_->idl_text;
  }
  $r .= "};\x0A";
  return $r;
} # idl_text

sub is_forward_declaration ($;$) {
  if (@_ > 1) {
    if ($_[1]) {
      $_[0]->{is_forward_declaration} = 1;
    } else {
      delete $_[0]->{is_forward_declaration};
    }
  }

  return $_[0]->{is_forward_declaration};
} # is_forward_declaration

package Whatpm::WebIDL::Exception;
push our @ISA, 'Whatpm::WebIDL::Definition';

sub idl_text ($) {
  my $self = shift;
  my $r = $self->_xattrs_text;
  $r .= ' ' if length $r;
  $r .= 'exception ' . $self->node_name . " {\x0A"; ## TODO: escape
  for (@{$self->{child_nodes}}) {
    $r .= '  ' . $_->idl_text;
  }
  $r .= "};\x0A";
  return $r;
} # idl_text

package Whatpm::WebIDL::Typedef;
push our @ISA, 'Whatpm::WebIDL::Definition';

sub new ($$) {
  my $self = shift->SUPER::new (@_);
  $self->{type} = '::any::';
  return $self;
} # new

sub idl_text ($) {
  my $self = shift;
  my $r = $self->_xattrs_text;
  $r .= ' ' if length $r;
  my $node_name = $self->node_name;
  $node_name = 'DOMString' if $node_name eq '::DOMString::';
  ## TODO: escape
  $r .= 'typedef ' . $self->type_text . ' ' . $node_name . ";\x0A";
  return $r;
} # idl_text

package Whatpm::WebIDL::Valuetype;
push our @ISA, 'Whatpm::WebIDL::Definition';

sub new ($$) {
  my $self = shift->SUPER::new (@_);
  $self->{type} = '::boolean::';
  return $self;
} # new

sub idl_text ($) {
  my $self = shift;
  my $r = $self->_xattrs_text;
  $r .= ' ' if length $r;
  my $name = $self->node_name;
  $name = 'DOMString' if $name eq '::DOMString::';
  ## TODO: escape
  $r .= 'valuetype ' . $name . ' ' . $self->type_text . ";\x0A";
  return $r;
} # idl_text

package Whatpm::WebIDL::InterfaceMember;
push our @ISA, 'Whatpm::WebIDL::Node';

sub new ($$) {
  return bless {node_name => ''.$_[1]}, $_[0];
} # new

sub child_nodes ($) { return [] }

*_xattrs_text = \&Whatpm::WebIDL::Definition::_xattrs_text;

*set_extended_attribute_node = \&Whatpm::WebIDL::Definition::set_extended_attribute_node;

*type = \&Whatpm::WebIDL::Definition::type;

*type_text = \&Whatpm::WebIDL::Definition::type_text;

package Whatpm::WebIDL::Const;
push our @ISA, 'Whatpm::WebIDL::Definition', 'Whatpm::WebIDL::InterfaceMember';

sub new ($$) {
  my $self = shift->SUPER::new (@_); # Definition->new should be called
  $self->{type} = '::boolean::';
  $self->{value} = ['FALSE'];
  return $self;
} # new

sub value ($;$) {
  if (@_ > 1) {
    if (defined $_[1]) {
      $_[0]->{value} = $_[1];
    } else {
      $_[0]->{value} = ['FALSE'];
    }
  }
  
  return $_[0]->{value};
} # value

sub value_text ($) {
  my $value = $_[0]->{value};

  if ($value->[0] eq 'TRUE' or $value->[0] eq 'FALSE') {
    return $value->[0];
  } elsif ($value->[0] eq 'integer' or $value->[0] eq 'float') {
    ## TODO: format
    return $value->[1];
  } else {
    return undef;
  }
} # value_text

sub idl_text ($) {
  my $self = shift;
  my $r = $self->_xattrs_text;
  $r .= ' ' if length $r;
  $r .= 'const ' . $self->type_text . ' ' . $self->node_name . ' = ' . $self->value_text . ";\x0A"; ## TODO: escape
  return $r;
} # idl_text

package Whatpm::WebIDL::Attribute;
push our @ISA, 'Whatpm::WebIDL::InterfaceMember';

sub new ($$) {
  my $self = shift->SUPER::new (@_);
  $self->{type} = '::any::';
  $self->{getraises} = [];
  $self->{setraises} = [];
  return $self;
} # new

sub append_getraises ($$) {
  ## TODO: error check, etc.
  push @{$_[0]->{getraises}}, $_[1];
} # append_getraises

sub append_setraises ($$) {
  ## TODO: error check, etc.
  push @{$_[0]->{setraises}}, $_[1];
} # append_setraises

sub readonly ($;$) {
  if (@_ > 1) {
    $_[0]->{readonly} = $_[1];
  }

  return $_[0]->{readonly};
} # readonly

sub idl_text ($) {
  my $self = shift;
  my $r = $self->_xattrs_text;
  $r .= ' ' if length $r;
  $r .= ($self->readonly ? 'readonly ' : '') . 'attribute ' . $self->type_text . ' ' . $self->node_name;
  ## TODO: escape
  if (@{$self->{getraises}}) {
    $r .= ' getraises (';
    ## todo: ...
    $r .= join ', ', map {$serialize_type->($_)} @{$self->{getraises}};
    $r .= ')';
  }
  if (@{$self->{setraises}}) {
    $r .= ' setraises (';
    ## todo: ...
    $r .= join ', ', map {$serialize_type->($_)} @{$self->{setraises}};
    $r .= ')';
  }
  $r .= ";\x0A";
  return $r;
} # idl_text

package Whatpm::WebIDL::Operation;
push our @ISA, 'Whatpm::WebIDL::InterfaceMember';

sub new ($$) {
  my $self = shift->SUPER::new (@_);
  $self->{type} = '::any::';
  $self->{child_nodes} = [];
  $self->{raises} = [];
  return $self;
} # new

sub append_raises ($$) {
  ## TODO: error check, etc.
  push @{$_[0]->{raises}}, $_[1];
} # append_raises

sub idl_text ($) {
  my $self = shift;
  my $r = $self->_xattrs_text;
  $r .= ' ' if length $r;
  $r .= $self->type_text . ' ' . $self->node_name . ' ('; ## TODO: escape
  $r .= join ', ', map {$_->idl_text} @{$self->{child_nodes}};
  $r .= ')';
  if (@{$self->{raises}}) {
    $r .= ' raises (';
    ## todo: ...
    $r .= join ', ', map {$serialize_type->($_)} @{$self->{raises}};
    $r .= ')';
  }
  $r .= ";\x0A";
  return $r;
} # idl_text

package Whatpm::WebIDL::Argument;
push our @ISA, 'Whatpm::WebIDL::Node';

sub new ($$) {
  return bless {node_name => ''.$_[1], type => '::any::'}, $_[0];
} # new

sub idl_text ($) {
  my $self = shift;
  my $r = $self->_xattrs_text;
  $r .= ' ' if length $r;
  $r .= 'in ' . $self->type_text . ' ' . $self->node_name; ## TODO: escape
  return $r;
} # idl_text

*_xattrs_text = \&Whatpm::WebIDL::Definition::_xattrs_text;

*set_extended_attribute_node = \&Whatpm::WebIDL::Definition::set_extended_attribute_node;

*type = \&Whatpm::WebIDL::Definition::type;

*type_text = \&Whatpm::WebIDL::Definition::type_text;

package Whatpm::WebIDL::ExceptionMember;
push our @ISA, 'Whatpm::WebIDL::Node';

sub new ($$) {
  return bless {node_name => ''.$_[1], type => '::any::'}, $_[0];
} # new

sub idl_text ($) {
  my $self = shift;
  my $r = $self->_xattrs_text;
  $r .= ' ' if length $r;
  $r .= $self->type_text . ' ' . $self->node_name . ";\x0A"; ## TODO: escape
  return $r;
} # idl_text

*_xattrs_text = \&Whatpm::WebIDL::Definition::_xattrs_text;

*set_extended_attribute_node = \&Whatpm::WebIDL::Definition::set_extended_attribute_node;

*type = \&Whatpm::WebIDL::Definition::type;

*type_text = \&Whatpm::WebIDL::Definition::type_text;
             
package Whatpm::WebIDL::ExtendedAttribute;
push our @ISA, 'Whatpm::WebIDL::Node';

sub new ($$) {
  return bless {child_nodes => [], node_name => ''.$_[1]};
} # new

sub has_argument_list ($;$) {
  if (@_ > 1) {
    if ($_[1]) {
      $_[0]->{has_argument_list} = 1;
    } else {
      delete $_[0]->{has_argument_list};
    }
  }
  
  return ($_[0]->{has_argument_list} or scalar @{$_[0]->{child_nodes}});
} # has_argument_list

sub idl_text ($) {
  my $self = shift;
  my $r = $self->node_name; ## TODO:] esceape
  if (defined $self->{value}) {
    $r .= '=' . $self->{value}; ## TODO: escape
  }
  if ($self->has_argument_list) {
    $r .= ' (';
    $r .= join ', ', map {$_->idl_text} @{$self->{child_nodes}};
    $r .= ')';
  }
  return $r;
} # idl_text

sub value ($;$) {
  if (@_ > 1) {
    if (defined $_[1]) {
      $_[0]->{value} = ''.$_[1];
    } else {
      delete $_[0]->{value};
    }
  }

  return $_[0]->{value};
} # value

=head1 LICENSE

Copyright 2008 Wakaba <w@suika.fam.cx>

This library is free software; you can redistribute it
and/or modify it under the same terms as Perl itself.

=cut

1;
# $Date: 2008/09/16 14:41:38 $