Parent Directory
| 
Revision Log
++ whatpm/Whatpm/ChangeLog 19 Jul 2008 07:25:16 -0000 2008-07-19 Wakaba <wakaba@suika.fam.cx> * WebIDL.pm: Hierarchical scoped name support was broken. Support for raises, setraises, and getraises syntaxes.
| 1 | wakaba | 1.1 | package Whatpm::WebIDL; |
| 2 | use strict; | ||
| 3 | |||
| 4 | package Whatpm::WebIDL::Parser; | ||
| 5 | |||
| 6 | my $integer = qr/-?0([0-7]*|[Xx][0-9A-Fa-f]+)|[1-9][0-9]*/; | ||
| 7 | my $float = qr/-?([0-9]+\.[0-9]*|[0-9]*\.[0-9]+)([Ee][+-]?[0-9]+)?|[0-9]+[Ee][+-]?[0-9]+/; | ||
| 8 | my $identifier = qr/[A-Z_a-z][0-9A-Z_a-z]*/; | ||
| 9 | my $whitespace = qr<[\t\n\r ]+|[\t\n\r ]*((//.*|/\*.*?\*/)[\t\n\r ]*)+>; | ||
| 10 | |||
| 11 | sub new ($) { | ||
| 12 | my $self = bless { | ||
| 13 | must_level => 'm', | ||
| 14 | should_level => 's', | ||
| 15 | warn_level => 'w', | ||
| 16 | info_level => 'i', | ||
| 17 | }, $_[0]; | ||
| 18 | return $self; | ||
| 19 | } # new | ||
| 20 | |||
| 21 | sub parse_char_string ($$;$) { | ||
| 22 | my $self = shift; | ||
| 23 | my $s = ref $_[0] ? $_[0] : \($_[0]); | ||
| 24 | |||
| 25 | my $defs = Whatpm::WebIDL::Definitions->new; | ||
| 26 | |||
| 27 | pos ($$s) = 0; | ||
| 28 | my $line = 1; | ||
| 29 | my $column = 0; | ||
| 30 | |||
| 31 | my $get_next_token = sub { | ||
| 32 | if (length $$s <= pos $$s) { | ||
| 33 | return {type => 'eof'}; | ||
| 34 | } | ||
| 35 | |||
| 36 | while ($$s =~ /\G($whitespace)/gc) { | ||
| 37 | my $v = $1; | ||
| 38 | while ($v =~ s/^[^\x0D\x0A]*(?>\x0D\x0A?|\x0A)//) { | ||
| 39 | $line++; | ||
| 40 | $column = 0; | ||
| 41 | } | ||
| 42 | $column += length $v; | ||
| 43 | } | ||
| 44 | |||
| 45 | if (length $$s <= pos $$s) { | ||
| 46 | return {type => 'eof'}; | ||
| 47 | } | ||
| 48 | |||
| 49 | ## ISSUE: "must"s in "A. IDL grammer" are not "MUST"s. | ||
| 50 | |||
| 51 | if ($$s =~ /\G($identifier)/gc) { | ||
| 52 | my $v = $1; | ||
| 53 | $column += length $v; | ||
| 54 | if ({ | ||
| 55 | module => 1, interface => 1, exception => 1, typedef => 1, | ||
| 56 | valuetype => 1, DOMString => 1, sequence => 1, unsigned => 1, | ||
| 57 | short => 1, const => 1, TRUE => 1, FALSE => 1, readonly => 1, | ||
| 58 | attribute => 1, getraises => 1, setraises => 1, raises => 1, in => 1, | ||
| 59 | any => 1, boolean => 1, octet => 1, float => 1, Object => 1, | ||
| 60 | short => 1, long => 1, void => 1, | ||
| 61 | }->{$v}) { | ||
| 62 | return {type => $v}; | ||
| 63 | } else { | ||
| 64 | return {type => 'identifier', value => $v}; | ||
| 65 | } | ||
| 66 | } elsif ($$s =~ /\G($float)/gc) { ## ISSUE: negative number | ||
| 67 | $column += length $1; | ||
| 68 | return {type => 'float', value => $1}; | ||
| 69 | } elsif ($$s =~ /\G($integer)/gc) { ## ISSUE: negative nmber | ||
| 70 | $column += length $1; | ||
| 71 | return {type => 'integer', value => $1}; | ||
| 72 | } elsif ($$s =~ /\G::/gcs) { | ||
| 73 | $column += 2; | ||
| 74 | return {type => '::'}; | ||
| 75 | } elsif ($$s =~ /\G(.)/gcs) { ## NOTE: Should never be a newline char. | ||
| 76 | $column++; | ||
| 77 | return {type => $1}; | ||
| 78 | } else { | ||
| 79 | die "get_next_token: non-possible case: " . substr ($$s, pos $$s, 20); | ||
| 80 | } | ||
| 81 | }; # $get_next_token | ||
| 82 | |||
| 83 | my $state = 'before definitions'; | ||
| 84 | my $token = $get_next_token->(); | ||
| 85 | my $nest_level = 0; | ||
| 86 | my $next_state; | ||
| 87 | my $xattrs; | ||
| 88 | my $last_xattr; | ||
| 89 | my $read_only; | ||
| 90 | my $current_type; | ||
| 91 | my @current = ($defs); | ||
| 92 | < |