home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / grammar.pm < prev    next >
Encoding:
Perl POD Document  |  2002-06-12  |  11.6 KB  |  482 lines
  1. package ExtUtils::XSBuilder::C::grammar;
  2.  
  3. # initial grammar is taken from Inline::C::grammar & Inline::Struct::grammar
  4.  
  5. use strict;
  6. use vars qw{$VERSION @EXPORT @ISA} ;
  7. use Exporter ;
  8. use Data::Dumper ;
  9.  
  10.  
  11. $VERSION = '0.30';
  12.  
  13. @ISA = qw{Exporter} ;
  14. @EXPORT = qw{cdef_define cdef_enum cdef_struct cdef_function_declaration} ;
  15.  
  16.  
  17. # ============================================================================
  18.  
  19. sub cdef_define
  20.     {
  21.     my ($thisparser, $name, $comment) = @_ ;
  22.  
  23.     my $elem = { name => $name, $comment?(comment => $comment):() } ;
  24.     if ($thisparser->{srcobj}->handle_define($elem)) 
  25.         {
  26.         push @{$thisparser->{data}{constants}}, $elem ;
  27.         print "constant: $name\n" ;
  28.         }
  29.     else
  30.         {
  31.         print "constant: $name (ignore because handle_define returned false)\n" ;
  32.         }
  33.     }
  34.     
  35. # ============================================================================
  36.  
  37. sub cdef_enum
  38.     {
  39.     my ($thisparser, $names) = @_ ;
  40.  
  41.     for (@{$names})
  42.         {
  43.         if (ref $_) 
  44.             {
  45.         my $elem = { name => $_ -> [0], $_->[1] && @{$_->[1]}?('comment' => join (' ', @{$_->[1]})):() } ;
  46.             push @{$thisparser->{data}{constants}}, $elem if ($thisparser->{srcobj}->handle_enum($elem)) ; 
  47.             }
  48.         }
  49.     1 ;
  50.     }
  51.  
  52. # ============================================================================
  53.  
  54. sub cdef_struct
  55.     {
  56.     my ($thisparser, $perlname, $cname, $fields, $type) = @_;
  57.     my $seen = \$thisparser->{data}{structure}{$cname || $type} ;
  58.     my $s = $$seen ;
  59.     return 0 if ($s && ($s -> {elts} && !$type)) ;
  60.     #print "cdef $cname $type\n" ;
  61.     $s ||= {} ;
  62.     $s -> {type} ||= $cname ;
  63.     $s -> {type} = $type if ($type) ;
  64.     if ($fields)
  65.         {
  66.         my @fields;
  67.         my @comment ;
  68.         for (@$fields)
  69.             {
  70.             if (ref $_) 
  71.                 {
  72.                 push @fields, { 
  73.                     'type' => $_->[0], 
  74.                     'name' => $_->[1], 
  75.                     ($_->[2] && @{$_->[2]}) || @comment?('comment' => join (' ', @{$_->[2]}, @comment)):(), 
  76.                     $_->[3] && @{$_->[3]}?('args' => $_->[3]):(), 
  77.                     } ; 
  78.                 @comment = () ;
  79.                 }
  80.             else
  81.                 {
  82.                 push @comment, $_ ;
  83.                 }
  84.             }
  85.         $s -> {elts} = \@fields ;
  86.         }
  87.     $s -> {stype} = $cname if ($cname) ; 
  88.     if ($fields)
  89.         {
  90.         if ($thisparser->{srcobj}->handle_struct($s)) 
  91.             {
  92.             push @{$thisparser->{data}{structures}}, $s ;
  93.             print "struct:   $cname (type=$type)\n" ;
  94.             }
  95.         else
  96.             {
  97.             print "struct:   $cname (ignore because handle_struct returned false)\n" ;
  98.             }
  99.         }
  100.     $$seen = $s ;
  101.     return $s ;
  102.     }
  103.  
  104.  
  105. # ============================================================================
  106.  
  107. sub cdef_function_declaration
  108.     {
  109.     my ($thisparser, $function, $rettype, $args) = @_ ;
  110.     return 0 if (!$function) ;
  111.     return 0 if ($thisparser->{data}{function}{$function}++) ;
  112.     my $s = { 'name' => $function } ;
  113.     my $dummy = 'arg0' ;
  114.     $s -> {return_type} = $rettype ;
  115.     my @args ;
  116.     my $i = 0 ;
  117.     for (@{$args})
  118.         {
  119.         if (ref $_) 
  120.             {
  121.             push @args, { 
  122.                 'type' => $_->[0], 
  123.                 'name' => $_->[1] || "arg$i", 
  124.                 } if ($_->[0] ne 'void') ; 
  125.             }
  126.         $i++ ;
  127.         }
  128.     $s -> {args} = \@args ;
  129.      if ($thisparser->{srcobj}->handle_function($s)) 
  130.         {
  131.         push @{$thisparser->{data}{functions}}, $s ;
  132.         print "func:     $function\n" ;
  133.         }
  134.     else
  135.         {
  136.         print "func:     $function (ignore because handle_function returned false)\n" ;
  137.         }
  138.     return $s ;
  139.     }
  140.  
  141. # ============================================================================
  142.  
  143. sub grammar {
  144.     <<'END';
  145.  
  146. { 
  147. use ExtUtils::XSBuilder::C::grammar ; # import cdef_xxx functions 
  148. }
  149.  
  150. code:    comment_part(s) {1}
  151.  
  152. comment_part:
  153.     comment(s?) part
  154.         { 
  155.         #print "comment: ", Data::Dumper::Dumper(\@item) ;
  156.         $item[2] -> {comment} = "@{$item[1]}" if (ref $item[1] && @{$item[1]} && ref $item[2]) ;
  157.         1 ;
  158.         }
  159.     | comment
  160.  
  161. part:   
  162.     prepart 
  163.     | stdpart
  164.         {
  165.         if ($thisparser -> {my_neednewline}) 
  166.             {
  167.             print "\n" ;
  168.             $thisparser -> {my_neednewline} = 0 ;
  169.             }
  170.         $return = $item[1] ;
  171.         }
  172.  
  173. # prepart can be used to extent the parser (for default it always fails)
  174.  
  175. prepart:  '?' 
  176.         {0}
  177.  
  178.            
  179. stdpart:   
  180.     define
  181.         {
  182.         $return = cdef_define ($thisparser, $item[1][0], $item[1][1]) ;
  183.         }
  184.     | struct
  185.         {
  186.         $return = cdef_struct ($thisparser, @{$item[1]}) ;
  187.         }
  188.     | enum
  189.         {
  190.         $return = cdef_enum ($thisparser, $item[1][1]) ;
  191.         }
  192.     | function_declaration
  193.         {
  194.         $return = cdef_function_declaration ($thisparser, @{$item[1]}) ;
  195.         }
  196.     | struct_typedef
  197.         {
  198.         my ($type,$alias) = @{$item[1]}[0,1];
  199.         $return = cdef_struct ($thisparser, undef, $type, undef, $alias) ;
  200.         }
  201.     | comment
  202.     | anything_else
  203.  
  204. comment:
  205.     m{\s* // \s* ([^\n]*) \s*? \n }x
  206.         { $1 }
  207.     | m{\s* /\* \s* ([^*]+|\*(?!/))* \s*? \*/  ([ \t]*)? }x
  208.         { $item[1] =~ m#/\*\s*?(.*?)\s*?\*/#s ; $1 }
  209.  
  210. semi_linecomment:
  211.     m{;\s*\n}x
  212.         {
  213.         $return = [] ;
  214.         1 ;
  215.         }
  216.     | ';' comment(s?)
  217.         {
  218.         $item[2]
  219.         }
  220.  
  221. function_definition:
  222.     rtype IDENTIFIER '(' <leftop: arg ',' arg>(s?) ')' '{'
  223.         {[@item[2,1], $item[4]]}
  224.  
  225. pTHX:
  226.     'pTHX_'
  227.  
  228. function_declaration:
  229.     type_identifier '(' pTHX(?) <leftop: arg_decl ',' arg_decl>(s?) ')' function_declaration_attr ( ';' | '{' )
  230.         {
  231.         #print Data::Dumper::Dumper (\@item) ;
  232.             [
  233.             $item[1][1], 
  234.             $item[1][0], 
  235.             @{$item[3]}?[['pTHX', 'aTHX' ], @{$item[4]}]:$item[4] 
  236.             ]
  237.         }
  238.  
  239. define:
  240.     '#define' IDENTIFIER /.*?\n/
  241.         {
  242.         $item[3] =~ m{(?:/\*\s*(.*?)\s*\*/|//\s*(.*?)\s*$)} ; [$item[2], $1] 
  243.         }
  244.  
  245. ignore_cpp:
  246.     '#' /.*?\n/
  247.  
  248. struct: 
  249.     'struct' IDENTIFIER '{' field(s) '}' ';'
  250.         {
  251.         # [perlname, cname, fields]
  252.         [$item[2], "@item[1,2]", $item[4]]
  253.         }
  254.     | 'typedef' 'struct' '{' field(s) '}' IDENTIFIER ';'
  255.         {
  256.         # [perlname, cname, fields]
  257.         [$item[6], undef, $item[4], $item[6]]
  258.         }
  259.     | 'typedef' 'struct' IDENTIFIER '{' field(s) '}' IDENTIFIER ';'
  260.         {
  261.         # [perlname, cname, fields, alias]
  262.         [$item[3], "@item[2,3]", $item[5], $item[7]]
  263.         }
  264.  
  265. struct_typedef: 
  266.     'typedef' 'struct' IDENTIFIER IDENTIFIER ';'
  267.         {
  268.     ["@item[2,3]", $item[4]]
  269.     }
  270.  
  271. enum: 
  272.     'enum' IDENTIFIER '{' enumfield(s) '}' ';'
  273.         {
  274.         [$item[2], $item[4]]
  275.         }
  276.     | 'typedef' 'enum' '{' enumfield(s) '}' IDENTIFIER ';'
  277.         {
  278.         [undef, $item[4], $item[6]]
  279.         }
  280.     | 'typedef' 'enum' IDENTIFIER '{' enumfield(s) '}' IDENTIFIER ';'
  281.         {
  282.         [$item[3], $item[5], $item[7]]
  283.         }
  284.  
  285. field: 
  286.     comment 
  287.     | define
  288.     {
  289.         $return = cdef_define ($thisparser, $item[1][0], $item[1][1]) ;
  290.     }
  291.     | valuefield 
  292.     | callbackfield
  293.     | ignore_cpp
  294.  
  295. valuefield: 
  296.     type_identifier comment(s?) semi_linecomment
  297.         {
  298.         $thisparser -> {my_neednewline} = 1 ;
  299.         print "  valuefield: $item[1][0] : $item[1][1]\n" ;
  300.     [$item[1][0], $item[1][1], [$item[2]?@{$item[2]}:() , $item[3]?@{$item[3]}:()] ]
  301.         }
  302.  
  303.  
  304. callbackfield: 
  305.     rtype '(' '*' IDENTIFIER ')' '(' <leftop: arg_decl ',' arg_decl>(s?) ')' comment(s?) semi_linecomment
  306.         {
  307.         my $type = "$item[1](*)(" . join(',', map { "$_->[0] $_->[1]" } @{$item[7]}) . ')' ;
  308.         my $dummy = 'arg0' ;
  309.         my @args ;
  310.         for (@{$item[7]})
  311.             {
  312.             if (ref $_) 
  313.                 {
  314.                 push @args, { 
  315.                     'type' => $_->[0], 
  316.                     'name' => $_->[1], 
  317.                     } if ($_->[0] ne 'void') ; 
  318.                 }
  319.             }
  320.         my $s = { 'name' => $type, 'return_type' => $item[1], args => \@args } ;
  321.         push @{$thisparser->{data}{callbacks}}, $s  if ($thisparser->{srcobj}->handle_callback($s)) ;
  322.  
  323.         $thisparser -> {my_neednewline} = 1 ;
  324.         print "  callbackfield: $type : $item[4]\n" ;
  325.         [$type, $item[4], [$item[9]?@{$item[9]}:() , $item[10]?@{$item[10]}:()]] ;
  326.         }
  327.  
  328.  
  329. enumfield: 
  330.     comment
  331.     | IDENTIFIER  comment(s?) /,?/ comment(s?)
  332.         {
  333.         [$item[1], [$item[2]?@{$item[2]}:() , $item[4]?@{$item[4]}:()] ] ;
  334.         }
  335.  
  336. rtype:  
  337.     modmodifier(s) TYPE star(s?)
  338.         {
  339.         my @modifier = @{$item[1]} ;
  340.         shift @modifier if ($modifier[0] eq 'extern' || $modifier[0] eq 'static') ;
  341.  
  342.         $return = join ' ',@modifier, $item[2] ;
  343.         $return .= join '',' ',@{$item[3]} if @{$item[3]};
  344.         1 ;
  345.     }
  346.     | TYPE(s) star(s?)
  347.         {
  348.         $return = join (' ', @{$item[1]}) ;
  349.         $return .= join '',' ',@{$item[2]} if @{$item[2]};
  350.     #print "rtype $return \n" ;
  351.         1 ;
  352.         }
  353.     modifier(s)  star(s?)
  354.         {
  355.         join ' ',@{$item[1]}, @{$item[2]} ;
  356.     }
  357.  
  358. arg:
  359.     type_identifier 
  360.         {[$item[1][0],$item[1][1]]}
  361.     | '...'
  362.         {['...']}
  363.  
  364. arg_decl: 
  365.     rtype '(' '*' IDENTIFIER ')' '(' <leftop: arg_decl ',' arg_decl>(s?) ')'
  366.         {
  367.         my $type = "$item[1](*)(" . join(',', map { "$_->[0] $_->[1]" } @{$item[7]}) . ')' ;
  368.         my $dummy = 'arg0' ;
  369.         my @args ;
  370.         for (@{$item[7]})
  371.             {
  372.             if (ref $_) 
  373.                 {
  374.                 push @args, { 
  375.                     'type' => $_->[0], 
  376.                     'name' => $_->[1], 
  377.                     } if ($_->[0] ne 'void') ; 
  378.                 }
  379.             }
  380.         my $s = { 'name' => $type, 'return_type' => $item[1], args => \@args } ;
  381.         push @{$thisparser->{data}{callbacks}}, $s  if ($thisparser->{srcobj}->handle_callback($s)) ;
  382.  
  383.         [$type, $item[4], [$item[9]?@{$item[9]}:() , $item[11]?@{$item[11]}:()]] ;
  384.         }
  385.     | 'pTHX'
  386.     {
  387.     ['pTHX', 'aTHX' ]
  388.     }
  389.     | type_identifier
  390.     {
  391.     [$item[1][0], $item[1][1] ]
  392.     }
  393.     | '...'
  394.         {['...']}
  395.  
  396. function_declaration_attr:
  397.  
  398. type_identifier:
  399.     type_varname 
  400.         { 
  401.         my $r ;
  402.     my @type = @{$item[1]} ;
  403.     #print "type = @type\n" ;
  404.     my $name = pop @type ;
  405.     if (@type && ($name !~ /\*/)) 
  406.         {
  407.             $r = [join (' ', @type), $name] 
  408.         }
  409.     else
  410.         {
  411.         $r = [join (' ', @{$item[1]})] ;
  412.         }                
  413.     #print "r = @$r\n" ;
  414.         $r ;
  415.         }
  416.  
  417. type_varname:   
  418.     attribute(s?) TYPE(s) star(s) varname(?)
  419.         {
  420.     [@{$item[1]}, @{$item[2]}, @{$item[3]}, @{$item[4]}] ;    
  421.     }
  422.     | attribute(s?) varname(s)
  423.         {
  424.     $item[2] ;    
  425.     }
  426.  
  427.  
  428. varname:
  429.     ##IDENTIFIER '[' IDENTIFIER ']'
  430.     IDENTIFIER '[' /[^]]+/ ']'
  431.     {
  432.     "$item[1]\[$item[3]\]" ;
  433.     }
  434.     | IDENTIFIER ':' IDENTIFIER
  435.     {
  436.     $item[1]
  437.     }
  438.     | IDENTIFIER
  439.     {
  440.     $item[1]
  441.     }
  442.  
  443.  
  444. star: '*' | 'const' '*'
  445.         
  446. modifier: 'const' | 'struct' | 'enum' | 'unsigned' | 'long' | 'extern' | 'static' | 'short' | 'signed'
  447.  
  448. modmodifier: 'const' | 'struct' | 'enum' | 'extern' | 'static'
  449.  
  450. attribute: 'extern' | 'static' 
  451.  
  452. # IDENTIFIER: /[a-z]\w*/i
  453. IDENTIFIER: /\w+/
  454.  
  455. TYPE: /\w+/
  456.  
  457. anything_else: /.*/
  458.  
  459. END
  460. }
  461.  
  462. 1;
  463.  
  464. __END__
  465.  
  466.  
  467. =pod
  468.     | function_definition
  469.     {
  470.      my $function = $item[1][0];
  471.          $return = 1, last if $thisparser->{data}{done}{$function}++;
  472.      push @{$thisparser->{data}{functions}}, $function;
  473.      $thisparser->{data}{function}{$function}{return_type} = 
  474.              $item[1][1];
  475.      $thisparser->{data}{function}{$function}{arg_types} = 
  476.              [map {ref $_ ? $_->[0] : '...'} @{$item[1][2]}];
  477.      $thisparser->{data}{function}{$function}{arg_names} = 
  478.              [map {ref $_ ? $_->[1] : '...'} @{$item[1][2]}];
  479.     }
  480. =cut
  481.  
  482.