1# this module will be loaded by ExtUtils/XSpp/Grammar.pm and needs to
2# define subroutines in the ExtUtils::XSpp::Grammar namespace
3package ExtUtils::XSpp::Lexer;
4# for the indexer and friends
5use strict;
6use warnings;
7
8package ExtUtils::XSpp::Grammar;
9
10use ExtUtils::XSpp::Node;
11use ExtUtils::XSpp::Node::Access;
12use ExtUtils::XSpp::Node::Argument;
13use ExtUtils::XSpp::Node::Class;
14use ExtUtils::XSpp::Node::Comment;
15use ExtUtils::XSpp::Node::Constructor;
16use ExtUtils::XSpp::Node::Destructor;
17use ExtUtils::XSpp::Node::File;
18use ExtUtils::XSpp::Node::Function;
19use ExtUtils::XSpp::Node::Member;
20use ExtUtils::XSpp::Node::Method;
21use ExtUtils::XSpp::Node::Module;
22use ExtUtils::XSpp::Node::Package;
23use ExtUtils::XSpp::Node::Raw;
24use ExtUtils::XSpp::Node::Type;
25use ExtUtils::XSpp::Node::PercAny;
26use ExtUtils::XSpp::Node::Enum;
27use ExtUtils::XSpp::Node::EnumValue;
28use ExtUtils::XSpp::Node::Preprocessor;
29
30use ExtUtils::XSpp::Typemap;
31use ExtUtils::XSpp::Exception;
32
33use Digest::MD5 qw(md5_hex);
34
35my %tokens = ( '::' => 'DCOLON',
36               ':'  => 'COLON',
37               '%{' => 'OPSPECIAL',
38               '%}' => 'CLSPECIAL',
39               '{%' => 'OPSPECIAL',
40                '{' => 'OPCURLY',
41                '}' => 'CLCURLY',
42                '(' => 'OPPAR',
43                ')' => 'CLPAR',
44                ';' => 'SEMICOLON',
45                '%' => 'PERC',
46                '~' => 'TILDE',
47                '*' => 'STAR',
48                '&' => 'AMP',
49                '|' => 'PIPE',
50                ',' => 'COMMA',
51                '=' => 'EQUAL',
52                '/' => 'SLASH',
53                '.' => 'DOT',
54                '-' => 'DASH',
55                '<' => 'OPANG',
56                '>' => 'CLANG',
57               # these are here due to my lack of skill with yacc
58               '%name'       => 'p_name',
59               '%typemap'    => 'p_typemap',
60               '%exception'  => 'p_exceptionmap',
61               '%catch'      => 'p_catch',
62               '%file'       => 'p_file',
63               '%module'     => 'p_module',
64               '%code'       => 'p_code',
65               '%cleanup'    => 'p_cleanup',
66               '%postcall'   => 'p_postcall',
67               '%package'    => 'p_package',
68               '%length'     => 'p_length',
69               '%loadplugin' => 'p_loadplugin',
70               '%include'    => 'p_include',
71               '%alias'      => 'p_alias',
72               '%_type'      => 'p__type',
73             );
74
75my %keywords = ( const           => 1,
76                 class           => 1,
77                 unsigned        => 1,
78                 short           => 1,
79                 long            => 1,
80                 int             => 1,
81                 char            => 1,
82                 void            => 1,
83                 package_static  => 1,
84                 class_static    => 1,
85                 static          => 1,
86                 public          => 1,
87                 private         => 1,
88                 protected       => 1,
89                 virtual         => 1,
90                 enum            => 1,
91                 );
92
93sub get_lex_mode { return $_[0]->YYData->{LEX}{MODES}[0] || '' }
94
95sub push_lex_mode {
96  my( $p, $mode ) = @_;
97
98  push @{$p->YYData->{LEX}{MODES}}, $mode;
99}
100
101sub pop_lex_mode {
102  my( $p, $mode ) = @_;
103
104  die "Unexpected mode: '$mode'"
105    unless get_lex_mode( $p ) eq $mode;
106
107  pop @{$p->YYData->{LEX}{MODES}};
108}
109
110sub read_more {
111  my $v = readline $_[0]->YYData->{LEX}{FH};
112  my $buf = $_[0]->YYData->{LEX}{BUFFER};
113
114  unless( defined $v ) {
115    if( $_[0]->YYData->{LEX}{NEXT} ) {
116      $_[0]->YYData->{LEX} = $_[0]->YYData->{LEX}{NEXT};
117      $buf = $_[0]->YYData->{LEX}{BUFFER};
118
119      return $buf if length $$buf;
120      return read_more( $_[0] );
121    } else {
122      return;
123    }
124  }
125
126  $$buf .= $v;
127
128  return $buf;
129}
130
131# for tests
132sub _random_digits { sprintf '%06d', rand 100000 }
133
134sub push_conditional {
135  my $p = $_[0];
136  my $file = $p->YYData->{LEX}{FILE} ?
137                 substr md5_hex( $p->YYData->{LEX}{FILE} ), 0, 8 :
138                 'zzzzzzzz';
139  my $rand = _random_digits;
140
141  my $symbol = 'XSpp_' . $file . '_' . $rand;
142  push @{$p->YYData->{LEX}{CONDITIONAL}}, $symbol;
143
144  return $symbol;
145}
146
147sub pop_conditional {
148  pop @{$_[0]->YYData->{LEX}{CONDITIONAL}};
149}
150
151sub get_conditional {
152  return undef unless $_[0]->YYData->{LEX}{CONDITIONAL};
153  return undef unless @{$_[0]->YYData->{LEX}{CONDITIONAL}};
154  return $_[0]->YYData->{LEX}{CONDITIONAL}[-1];
155}
156
157sub yylex {
158  my $data = $_[0]->YYData->{LEX};
159  my $buf = $data->{BUFFER};
160
161  for(;;) {
162    if( !length( $$buf ) && !( $buf = read_more( $_[0] ) ) ) {
163      return ( '', undef );
164    }
165
166    if( get_lex_mode( $_[0] ) eq 'special' ) {
167      if( $$buf =~ s/^%}// ) {
168        return ( 'CLSPECIAL', '%}' );
169      } elsif( $$buf =~ s/^([^\n]*)\n$// ) {
170        my $line = $1;
171
172        if( $line =~ m/^(.*?)\%}(.*)$/ ) {
173          $$buf = "%}$2\n";
174          $line = $1;
175        }
176
177        return ( 'line', $line );
178      }
179    } else {
180      $$buf =~ s/^[\s\n\r]+//;
181      next unless length $$buf;
182
183      if( $$buf =~ s/^([+-]?0x[0-9a-fA-F]+)// ) {
184        return ( 'INTEGER', $1 );
185      } elsif( $$buf =~ s/^([+-]?(?=\d|\.\d)\d*(?:\.\d*)?(?:[Ee](?:[+-]?\d+))?)// ) {
186        my $v = $1;
187        return ( 'INTEGER', $v ) if $v =~ /^[+-]?\d+$/;
188        return ( 'FLOAT', $v );
189      } elsif( $$buf =~ s/^\/\/(.*)(?:\r\n|\r|\n)// ) {
190        return ( 'COMMENT', [ $1 ] );
191      } elsif( $$buf =~ /^\/\*/ ) {
192        my @rows;
193        for(; length( $$buf ) || ( $buf = read_more( $_[0] ) ); $$buf = '') {
194          if( $$buf =~ s/(.*?\*\/)// ) {
195              push @rows, $1;
196              return ( 'COMMENT', \@rows );
197          }
198          $$buf =~ s/(?:\r\n|\r|\n)$//;
199          push @rows, $$buf;
200        }
201      } elsif( $$buf =~ s/^(\%\w+)// ) {
202        return ( $tokens{$1}, $1 ) if exists $tokens{$1};
203        return ( 'p_any', substr $1, 1 );
204      } elsif( $$buf =~ s/^( \%}
205                      | \%\{ | \{\%
206                      | [{}();%~*&,=\/\.\-<>|]
207                      | :: | :
208                       )//x ) {
209        return ( $tokens{$1}, $1 );
210      } elsif( $$buf =~ s/^(INCLUDE(?:_COMMAND)?:.*)(?:\r\n|\r|\n)// ) {
211        return ( 'RAW_CODE', "$1\n" );
212      } elsif( $$buf =~ s/^([a-zA-Z_]\w*)// ) {
213        return ( $1, $1 ) if exists $keywords{$1};
214
215        return ( 'ID', $1 );
216      } elsif( $$buf =~ s/^("[^"]*")// ) {
217        return ( 'QUOTED_STRING', $1 );
218      } elsif( $$buf =~ s/^(#\s*(if|ifdef|ifndef|else|elif|endif)\b.*)(?:\r\n|\r|\n)// ) {
219        my $symbol;
220        if( $2 eq 'else' || $2 eq 'elif' || $2 eq 'endif' ) {
221          pop_conditional( $_[0] );
222        }
223        if( $2 ne 'endif' ) {
224          $symbol = push_conditional( $_[0] );
225        }
226
227        return ( 'PREPROCESSOR', [ $1, $symbol ] );
228      } elsif( $$buf =~ s/^(#.*)(?:\r\n|\r|\n)// ) {
229        return ( 'RAW_CODE', $1 );
230      } else {
231        die $$buf;
232      }
233    }
234  }
235}
236
237sub yyerror {
238  my $data = $_[0]->YYData->{LEX};
239  my $buf = $data->{BUFFER};
240  my $fh = $data->{FH};
241
242  print STDERR "Error: line " . $fh->input_line_number . " (Current token type: '",
243    $_[0]->YYCurtok, "') (Current value: '",
244    $_[0]->YYCurval, '\') Buffer: "', ( $buf ? $$buf : '--empty buffer--' ),
245      q{"} . "\n";
246  print STDERR "Expecting: (", ( join ", ", map { "'$_'" } $_[0]->YYExpect ),
247        ")\n";
248}
249
250sub make_const { $_[0]->{CONST} = 1; $_[0] }
251sub make_ref   { $_[0]->{REFERENCE} = 1; $_[0] }
252sub make_ptr   { $_[0]->{POINTER}++; $_[0] }
253sub make_type  { ExtUtils::XSpp::Node::Type->new( base => $_[0] ) }
254
255sub make_template {
256    ExtUtils::XSpp::Node::Type->new( base          => $_[0],
257                                     template_args => $_[1],
258                                     )
259}
260
261sub add_typemap {
262  my( $name, $type, @args ) = @_;
263  my $tm = ExtUtils::XSpp::Typemap::create( $name, type => $type, @args );
264
265  ExtUtils::XSpp::Typemap::add_typemap_for_type( $type, $tm );
266}
267
268sub add_data_raw {
269  my $p = shift;
270  my $rows = shift;
271
272  ExtUtils::XSpp::Node::Raw->new( rows => $rows );
273}
274
275sub add_data_comment {
276  my $p = shift;
277  my $rows = shift;
278
279  ExtUtils::XSpp::Node::Comment->new( rows => $rows );
280}
281
282sub add_top_level_directive {
283  my( $parser, %args ) = @_;
284
285  $parser->YYData->{PARSER}->handle_toplevel_tag_plugins
286    ( $args{any},
287      named                    => $args{named},
288      positional               => $args{positional},
289      any_named_arguments      => $args{named},
290      any_positional_arguments => $args{positional},
291      condition                => $parser->get_conditional,
292      );
293}
294
295sub make_argument {
296  my( $p, $type, $name, $default, @args ) = @_;
297  my %args   = @args;
298  _merge_keys( 'tag', \%args, \@args );
299
300  my $arg = ExtUtils::XSpp::Node::Argument->new
301                ( type    => $type,
302                  name    => $name,
303                  default => $default,
304                  tags    => $args{tag} );
305
306  return $arg;
307}
308
309sub create_class {
310  my( $parser, $name, $bases, $metadata, $methods, $condition ) = @_;
311  my %args = @$metadata;
312  _merge_keys( 'catch', \%args, $metadata );
313
314  my $class = ExtUtils::XSpp::Node::Class->new( %args, # <-- catch only for now
315                                                cpp_name     => $name,
316                                                base_classes => $bases,
317                                                condition    => $condition,
318                                                );
319
320  # when adding a class C, automatically add weak typemaps for C* and C&
321  ExtUtils::XSpp::Typemap::add_class_default_typemaps( $name );
322
323  my @any  = grep  $_->isa( 'ExtUtils::XSpp::Node::PercAny' ), @$methods;
324  my @rest = grep !$_->isa( 'ExtUtils::XSpp::Node::PercAny' ), @$methods;
325
326  # finish creating the class
327  $class->add_methods( @rest );
328
329  foreach my $meth ( grep $_->isa( 'ExtUtils::XSpp::Node::Method' ), @rest ) {
330    call_argument_tags( $parser, $meth );
331
332    my $nodes = $parser->YYData->{PARSER}->handle_method_tags_plugins( $meth, $meth->tags );
333
334    $class->add_methods( @$nodes );
335  }
336
337  foreach my $any ( @any ) {
338    if( $any->{NAME} eq 'accessors' ) {
339      # TODO use plugin infrastructure, add decent validation
340      my %args = @{$any->{NAMED_ARGUMENTS}};
341      if( $args{get_style} ) {
342          if( @{$args{get_style}} ) {
343              $class->set_getter_style( $args{get_style}[0][0] );
344          } else {
345              die "Invalid accessor style declaration";
346          }
347      }
348      if( $args{set_style} ) {
349          if( @{$args{set_style}} ) {
350              $class->set_setter_style( $args{set_style}[0][0] );
351          } else {
352              die "Invalid accessor style declaration";
353          }
354      }
355      next;
356    }
357
358    my $nodes = $parser->YYData->{PARSER}->handle_class_tag_plugins
359      ( $class, $any->{NAME},
360        named                    => $any->{NAMED_ARGUMENTS},
361        positional               => $any->{POSITIONAL_ARGUMENTS},
362        any_named_arguments      => $any->{NAMED_ARGUMENTS},
363        any_positional_arguments => $any->{POSITIONAL_ARGUMENTS},
364        );
365
366    $class->add_methods( @$nodes );
367  }
368
369  return $class;
370}
371
372# support multiple occurrances of specific keys
373# => transform to flattened array ref
374sub _merge_keys {
375  my $key = shift;
376  my $argshash = shift;
377  my $paramlist = shift;
378  my @occurrances;
379  for (my $i = 0; $i < @$paramlist; $i += 2) {
380    if (defined $paramlist->[$i] and $paramlist->[$i] eq $key) {
381      push @occurrances, $paramlist->[$i+1];
382    }
383  }
384  @occurrances = map {ref($_) eq 'ARRAY' ? @$_ : $_} @occurrances;
385  $argshash->{$key} = \@occurrances;
386}
387
388
389sub create_member {
390  my( $parser, @args ) = @_;
391  my %args   = @args;
392  _merge_keys( 'tag', \%args, \@args );
393
394  return ExtUtils::XSpp::Node::Member->new
395              ( cpp_name  => $args{name},
396                perl_name => $args{perl_name},
397                class     => $args{class},
398                type      => $args{type},
399                condition => $args{condition},
400                tags      => $args{tag},
401                );
402}
403
404sub add_data_function {
405  my( $parser, @args ) = @_;
406  my %args   = @args;
407  _merge_keys( 'catch', \%args, \@args );
408  _merge_keys( 'alias', \%args, \@args );
409  _merge_keys( 'tag', \%args, \@args );
410  $args{alias} = +{@{$args{alias}}} if exists $args{alias};
411
412  return ExtUtils::XSpp::Node::Function->new
413              ( cpp_name  => $args{name},
414                perl_name => $args{perl_name},
415                class     => $args{class},
416                ret_type  => $args{ret_type},
417                arguments => $args{arguments},
418                code      => $args{code},
419                cleanup   => $args{cleanup},
420                postcall  => $args{postcall},
421                catch     => $args{catch},
422                condition => $args{condition},
423                alias     => $args{alias},
424                tags      => $args{tag},
425                );
426}
427
428sub add_data_method {
429  my( $parser, @args ) = @_;
430  my %args   = @args;
431  _merge_keys( 'catch', \%args, \@args );
432  _merge_keys( 'alias', \%args, \@args );
433  _merge_keys( 'tag', \%args, \@args );
434  $args{alias} = +{@{$args{alias}}} if exists $args{alias};
435
436  my $m = ExtUtils::XSpp::Node::Method->new
437            ( cpp_name  => $args{name},
438              ret_type  => $args{ret_type},
439              arguments => $args{arguments},
440              const     => $args{const},
441              code      => $args{code},
442              cleanup   => $args{cleanup},
443              postcall  => $args{postcall},
444              perl_name => $args{perl_name},
445              catch     => $args{catch},
446              condition => $args{condition},
447              alias     => $args{alias},
448              tags      => $args{tag},
449              );
450
451  return $m;
452}
453
454sub add_data_ctor {
455  my( $parser, @args ) = @_;
456  my %args   = @args;
457  _merge_keys( 'catch', \%args, \@args );
458  _merge_keys( 'tag', \%args, \@args );
459
460  my $m = ExtUtils::XSpp::Node::Constructor->new
461            ( cpp_name  => $args{name},
462              arguments => $args{arguments},
463              code      => $args{code},
464              cleanup   => $args{cleanup},
465              postcall  => $args{postcall},
466              catch     => $args{catch},
467              condition => $args{condition},
468              tags      => $args{tag},
469              );
470
471  return $m;
472}
473
474sub add_data_dtor {
475  my( $parser, @args ) = @_;
476  my %args   = @args;
477  _merge_keys( 'catch', \%args, \@args );
478  _merge_keys( 'tag', \%args, \@args );
479
480  my $m = ExtUtils::XSpp::Node::Destructor->new
481            ( cpp_name  => $args{name},
482              code      => $args{code},
483              cleanup   => $args{cleanup},
484              postcall  => $args{postcall},
485              catch     => $args{catch},
486              condition => $args{condition},
487              tags      => $args{tag},
488              );
489
490  return $m;
491}
492
493sub process_function {
494  my( $parser, $function ) = @_;
495
496  $function->resolve_typemaps;
497  $function->resolve_exceptions;
498  call_argument_tags( $parser, $function );
499
500  my $nodes = $parser->YYData->{PARSER}->handle_function_tags_plugins( $function, $function->tags );
501
502  return [ $function, @$nodes ];
503}
504
505sub call_argument_tags {
506  my( $parser, $function ) = @_;
507
508  foreach my $arg ( @{$function->arguments} ) {
509    $parser->YYData->{PARSER}->handle_argument_tags_plugins( $arg, $arg->tags );
510  }
511}
512
5131;
514