home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / CScan.pm < prev    next >
Encoding:
Perl POD Document  |  2004-06-21  |  30.6 KB  |  997 lines
  1. package ModPerl::CScan;
  2.  
  3. require Exporter;
  4. use Config '%Config';
  5. use File::Basename;
  6.  
  7. # NOTE to distributors: this module is needed only for mp2 developers,
  8. # it's not a requirement for mod_perl users
  9. use Data::Flow qw(0.05);
  10.  
  11. use strict;            # Earlier it catches ISA and EXPORT.
  12.  
  13. @ModPerl::CScan::ISA = qw(Exporter Data::Flow);
  14.  
  15. # Items to export into callers namespace by default. Note: do not export
  16. # names by default without a very good reason. Use EXPORT_OK instead.
  17. # Do not simply export all your public functions/methods/constants.
  18.  
  19. @ModPerl::CScan::EXPORT = qw(
  20.         );
  21. @ModPerl::CScan::EXPORT_OK = qw(
  22.             );
  23. # this flag tells cpp to only output macros
  24. $ModPerl::CScan::MACROS_ONLY = '-dM';
  25.  
  26. $ModPerl::CScan::VERSION = '0.75';
  27.  
  28. my (%keywords,%style_keywords);
  29. for (qw(asm auto break case char continue default do double else enum
  30.         extern float for fortran goto if int long register return short
  31.         sizeof static struct switch typedef union unsigned signed while void volatile)) {
  32.   $keywords{$_}++;
  33. }
  34. for (qw(bool class const delete friend inline new operator overload private
  35.         protected public virtual)) {
  36.   $style_keywords{'C++'}{$_}++;
  37. }
  38. for (qw(__func__ _Complex _Imaginary _Bool inline restrict)) {
  39.   $style_keywords{'C9X'}{$_}++;
  40. }
  41. for (qw(inline const asm noreturn section 
  42.     constructor destructor unused weak)) {
  43.   $style_keywords{'GNU'}{$_}++;
  44.   $style_keywords{'GNU'}{"__$ {_}__"}++;
  45. }
  46.   $style_keywords{'GNU'}{__attribute__}++;
  47.   $style_keywords{'GNU'}{__extension__}++;
  48.   $style_keywords{'GNU'}{__consts}++;
  49.   $style_keywords{'GNU'}{__const}++;
  50.   $style_keywords{'GNU'}{__restrict}++;
  51.  
  52. my $recipes
  53.   = { Defines => { default => '' },
  54.       cppstdin => { default => $Config{cppstdin} },
  55.       cppflags => { default => $Config{cppflags} },
  56.       cppminus => { default => $Config{cppminus} },
  57.       c_styles => { default => [qw(C++ GNU C9X)] },
  58.       add_cppflags => { default => '' },
  59.       keywords => { prerequisites => ['c_styles'],
  60.             output => sub {
  61.               my %kw = %keywords;
  62.               my %add;
  63.               for ( @{ shift->{c_styles} } ) {
  64.             %add = %{ $style_keywords{$_} };
  65.             %kw = (%kw, %add);
  66.               }
  67.               \%kw;
  68.             }, },
  69.       'undef' => { default => undef },
  70.       filename_filter => { default => undef },
  71.       full_text => { class_filter => [ 'text', 'C::Preprocessed',
  72.                        qw(undef filename Defines includeDirs Cpp)] },
  73.       text => { class_filter => [ 'text', 'C::Preprocessed',
  74.                   qw(filename_filter filename Defines includeDirs Cpp)] },
  75.       text_only_from => { class_filter => [ 'text_only_from', 'C::Preprocessed',
  76.                         qw(filename_filter filename Defines includeDirs Cpp)] },
  77.       includes => { filter => [ \&includes, 
  78.                 qw(filename Defines includeDirs Cpp) ], },
  79.       includeDirs =>  { prerequisites => ['filedir'], 
  80.             output => sub {
  81.               my $data = shift;
  82.               [ $data->{filedir}, '/usr/local/include', '.'];
  83.             } },
  84.       Cpp => { prerequisites => [qw(cppminus add_cppflags cppflags cppstdin)], 
  85.            output => sub {
  86.          my $data = shift;
  87.          return { cppstdin => $data->{cppstdin},
  88.               cppflags => "$data->{cppflags} $data->{add_cppflags}",
  89.               cppminus => $data->{cppminus} };
  90.            } },
  91.       filedir => { output => sub { dirname ( shift->{filename} || '.' ) } },
  92.       sanitized => { filter => [ \&sanitize, 'text'], },
  93.       toplevel => { filter => [ \&top_level, 'sanitized'], },
  94.       full_sanitized => { filter => [ \&sanitize, 'full_text'], },
  95.       full_toplevel => { filter => [ \&top_level, 'full_sanitized'], },
  96.       no_type_decl => { filter => [ \&remove_type_decl, 'toplevel'], },
  97.       typedef_chunks => { filter => [ \&typedef_chunks, 'full_toplevel'], },
  98.       struct_chunks => { filter => [ \&struct_chunks, 'full_toplevel'], },
  99.       typedefs_whited => { filter => [ \&typedefs_whited,
  100.                        'full_sanitized', 'typedef_chunks',
  101.                        'keywords_rex'], },
  102.       typedef_texts => { filter => [ \&typedef_texts,
  103.                      'full_text', 'typedef_chunks'], },
  104.       struct_texts => { filter => [ \&typedef_texts,
  105.                     'full_text', 'struct_chunks'], },
  106.       typedef_hash => { filter => [ \&typedef_hash,
  107.                     'typedef_texts', 'typedefs_whited'], },
  108.       typedef_structs => { filter => [ \&typedef_structs,
  109.                        'typedef_hash', 'struct_texts'], },
  110.       typedefs_maybe => { filter => [ sub {[keys %{+shift}]},
  111.                       'typedef_hash'], },
  112.       defines_maybe => { filter => [ \&defines_maybe, 'filename'], },
  113.       defines_no_args => { prerequisites => ['defines_maybe'],
  114.                output => sub { shift->{defines_maybe}->[0] }, },
  115.       defines_args => { prerequisites => ['defines_maybe'],
  116.             output => sub { shift->{defines_maybe}->[1] }, },
  117.  
  118.       defines_full => { filter => [ \&defines_full, 
  119.                     qw(filename Defines includeDirs Cpp) ], },
  120.       defines_no_args_full => { prerequisites => ['defines_full'],
  121.                 output => sub { shift->{defines_full}->[0] }, },
  122.       defines_args_full => { prerequisites => ['defines_full'],
  123.             output => sub { shift->{defines_full}->[1] }, },
  124.  
  125.       decl_inlines => { filter => [ \&functions_in, 'no_type_decl'], },
  126.       inline_chunks => { filter => [ sub { shift->[0] }, 'decl_inlines'], },
  127.       inlines => { filter => [ \&from_chunks, 'inline_chunks', 'text'], },
  128.       decl_chunks => { filter => [ sub { shift->[1] }, 'decl_inlines'], },
  129.       decls => { filter => [ \&from_chunks, 'decl_chunks', 'text'], },
  130.       fdecl_chunks => { filter => [ sub { shift->[4] }, 'decl_inlines'], },
  131.       fdecls => { filter => [ \&from_chunks, 'fdecl_chunks', 'text'], },
  132.       mdecl_chunks => { filter => [ sub { shift->[2] }, 'decl_inlines'], },
  133.       mdecls => { filter => [ \&from_chunks, 'mdecl_chunks', 'text'], },
  134.       vdecl_chunks => { filter => [ sub { shift->[3] }, 'decl_inlines'], },
  135.       vdecls => { filter => [ \&from_chunks, 'vdecl_chunks', 'text'], },
  136.       vdecl_hash => { filter => [ \&vdecl_hash, 'vdecls', 'mdecls' ], },
  137.       parsed_fdecls => { filter => [ \&do_declarations, 'fdecls', 
  138.                      'typedef_hash', 'keywords'], },
  139.       keywords_rex => { filter => [ sub { my @k = keys %{ shift() };
  140.                       local $" = '|';
  141.                       my $r = "(?:@k)";
  142.                       eval 'qr/$r/' or $r    # Older Perls
  143.                     }, 'keywords'], },
  144.     };
  145.  
  146. sub from_chunks {
  147.   my $chunks = shift;
  148.   my $txt = shift;
  149.   my @out;
  150.   my $i = 0;
  151.   while ($i < @$chunks) {
  152.     push @out, substr $txt, $chunks->[$i], $chunks->[ $i + 1 ] - $chunks->[$i];
  153.     $i += 2;
  154.   }
  155.   \@out;
  156. }
  157.  
  158. #sub process { request($recipes, @_) }
  159. # Preloaded methods go here.
  160.  
  161. sub includes {
  162.   my %seen;
  163.   my $stream = new C::Preprocessed (@_)
  164.     or die "Cannot open pipe from cppstdin: $!\n";
  165.  
  166.   while (<$stream>) {
  167.     next unless m(^\s*\#\s*    # Leading hash
  168.           (line\s*)?    # 1: Optional line
  169.           ([0-9]+)\s*    # 2: Line number
  170.           (.*)        # 3: The rest
  171.          )x;
  172.     my $include = $3;
  173.     $include = $1 if $include =~ /"(.*)"/; # Filename may be in quotes
  174.     $include =~ s,\\\\,/,g if $^O eq 'os2';
  175.     $seen{$include}++ if $include ne "";
  176.   }
  177.   [keys %seen];
  178. }
  179.  
  180. sub defines_maybe {
  181.   my $file = shift;
  182.   my ($mline,$line,%macros,%macrosargs,$sym,$args);
  183.   open(C, $file) or die "Cannot open file $file: $!\n";
  184.   while (not eof(C) and $line = <C>) {
  185.     next unless 
  186.       ( $line =~ s[
  187.            ^ \s* \# \s*    # Start of directive
  188.            define \s+
  189.            (\w+)    # 1: symbol
  190.            (?:
  191.             \( (.*?) \s* \) # 2: Minimal match for arguments
  192.                                     # in parenths (without trailing
  193.                                     # spaces)
  194.            )?        # optional, no grouping
  195.            \s*        # rest is the definition
  196.            ([\s\S]*)    # 3: the rest
  197.           ][]x );
  198.     ($sym, $args, $mline) = ($1, $2, $3);
  199.     $mline .= <C> while not eof(C) and $mline =~ s/\\\n/\n/;
  200.     chomp $mline;
  201.     #print "sym: `$sym', args: `$args', mline: `$mline'\n";
  202.     if (defined $args) {
  203.       $macrosargs{$sym} = [ [split /\s*,\s*/, $args], $mline];
  204.     } else {
  205.       $macros{$sym} = $mline;
  206.     }
  207.   }
  208.   close(C) or die "Cannot close file $file: $!\n";
  209.   [\%macros, \%macrosargs];
  210. }
  211.  
  212. sub defines_full {
  213.   my $Cpp = $_[3];
  214.   my ($mline,$line,%macros,%macrosargs,$sym,$args);
  215.  
  216.   # save the old cppflags and add the flag for only ouputting macro definitions
  217.   my $old_cppstdin = $Cpp->{'cppstdin'};
  218.   $Cpp->{'cppstdin'} = $old_cppstdin . " " . $ModPerl::CScan::MACROS_ONLY;
  219.  
  220.   my $stream = new C::Preprocessed (@_)
  221.     or die "Cannot open pipe from cppstdin: $!\n";
  222.  
  223.   while (defined ($line = <$stream>)) {
  224.     next unless 
  225.       ( $line =~ s[
  226.            ^ \s* \# \s*    # Start of directive
  227.            define \s+
  228.            (\w+)    # 1: symbol
  229.            (?:
  230.             \( (.*?) \s* \) # 2: Minimal match for arguments
  231.                                     # in parenths (without trailing
  232.                                     # spaces)
  233.            )?        # optional, no grouping
  234.            \s*        # rest is the definition
  235.            ([\s\S]*)    # 3: the rest
  236.           ][]x );
  237.     ($sym, $args, $mline) = ($1, $2, $3);
  238.     $mline .= <$stream> while ($mline =~ s/\\\n/\n/);
  239.     chomp $mline;
  240. #print STDERR "sym: `$sym', args: `$args', mline: `$mline'\n";
  241.     if (defined $args) {
  242.       $macrosargs{$sym} = [ [split /\s*,\s*/, $args], $mline];
  243.     } else {
  244.       $macros{$sym} = $mline;
  245.     }
  246.   }
  247.   # restore the original cppflags
  248.   $Cpp->{'cppstdin'} = $old_cppstdin;
  249.   [\%macros, \%macrosargs];
  250. }
  251.  
  252. sub typedef_chunks {        # Input is toplevel, output: starts and ends
  253.   my $txt = shift;
  254.   pos $txt = 0;
  255.   my ($b, $e, @out);
  256.   while ($txt =~ /\btypedef\b/g) {
  257.     push @out, pos $txt;
  258.     $txt =~ /(?=;)|\Z/g;
  259.     push @out, pos $txt;
  260.   }
  261.   \@out;
  262. }
  263.  
  264. sub struct_chunks {
  265.   my $txt = shift;
  266.   pos $txt = 0;
  267.   my ($b, $e, @out);
  268.   while ($txt =~ /\b(?=struct\s*(\w*\s*)?\{)/g) {
  269.     push @out, pos $txt;
  270.     $txt =~ /(?=;)|\Z/g;
  271.     push @out, pos $txt;
  272.   }
  273.   \@out;
  274. }
  275.  
  276. sub typedefs_whited {        # Input is sanitized text, and list of beg/end.
  277.   my @lst = @{$_[1]};
  278.   my @out;
  279.   my ($b, $e);
  280.   while ($b = shift @lst) {
  281.     $e = shift @lst;
  282.     push @out, whited_decl($_[2], substr $_[0], $b, $e - $b);
  283.   }
  284.   \@out;
  285. }
  286.  
  287. sub structs_whited {
  288.   my @lst = @{$_[1]};
  289.   my @out;
  290.   my ($b, $e, $in);
  291.   while ($b = shift @lst) {
  292.     $e = shift @lst;
  293.     $in = substr $_[0], $b, $e - $b;
  294.     $in =~ s/^(struct\s*(\w*\s*)?)(.*)$/$1 . " " x length($3)/es;
  295.     push @out, $in;
  296.   }
  297.   \@out;
  298. }
  299.  
  300. sub typedef_texts {
  301.   my ($txt, $chunks) = (shift, shift);
  302.   my ($b, $e, $in, @out);
  303.   my @in = @$chunks;
  304.   while (($b, $e) = splice @in, 0, 2) {
  305.     $in = substr($txt, $b, $e - $b);
  306.     # remove any remaining directives
  307.     $in =~ s/^ ( \s* \# .* ( \\ $ \n .* )* ) / ' ' x length($1)/xgem;
  308.     push @out, $in;
  309.   }
  310.   \@out;
  311. }
  312.  
  313. sub typedef_hash {
  314.   my ($typedefs, $whited) = (shift,shift);
  315.   my %out;
  316.  
  317.  loop:
  318.   for my $o (0..$#$typedefs) {
  319.     my $wh = $whited->[$o];
  320.     my $td = $typedefs->[$o];
  321. #my $verb = $td =~ /apr_child_errfn_t/ ? 1 : 0;
  322. #warn "$wh || $td\n" if $verb;
  323.     if ($wh =~ /,/ or not $wh =~ /\w/) { # Hard case, guessimates ...
  324.       # Determine whether the new thingies are inside parens
  325.       $wh =~ /,/g;
  326.       my $p = pos $wh;
  327.       my ($s, $e);
  328.       if (matchingbrace($wh)) {    # Inside.  Easy part: just split on /,/...
  329.     $e = pos($wh) - 1;
  330.     $s = $e;
  331.     my $d = 0;
  332.     # Skip back
  333.     while (--$s >= 0) {
  334.       my $c = substr $wh, $s, 1;
  335.       if ($c =~ /[\(\{\[]/) {
  336.         $d--;
  337.       } elsif ($c =~ /[\)\]\}]/) {
  338.         $d++;
  339.       }
  340.       last if $d < 0;
  341.     }
  342.     if ($s < 0) {        # Should not happen
  343.       warn("panic: could not match braces in\n\t$td\nwhited as\n\t$wh\n");
  344.       next loop;
  345.     }
  346.     $s++;
  347.       } else {            # We are at toplevel
  348.     # We need to skip back all the modifiers attached to the first thingy
  349.     # Guesstimates: everything after the first '*' (inclusive)
  350.     pos $wh = 0;
  351.     $wh = /(?=\w)/g;
  352.     my $ws = pos $wh;
  353.     my $pre = substr $wh, 0, $ws;
  354.     $s = $ws;
  355.     $s = pos $pre if $pre =~ /(?=\*)/g;
  356.     $e = length $wh;
  357.       }
  358.       # Now: need to split $td based on commas in $wh!
  359.       # And need to split each chunk of $td based on word in the chunk of $wh!
  360.       my $td_decls = substr($td, $s, $e - $s);
  361.       my ($pre, $post) = (substr($td, 0, $s), substr($td, $e));
  362.       my $wh_decls = substr($wh, $s, $e - $s);
  363.       my @wh_decls = split /,/, $wh_decls;
  364.       my $td_s = 0;
  365.       my (@td_decl, @td_pre, @td_post, @td_word);
  366.       for my $wh_d (@wh_decls) {
  367.     my $td_d = substr $td, $td_s, length $wh_d;
  368.     push @td_decl, $td_d;
  369.     $wh_d =~ /(\w+)/g;
  370.     push @td_word, $1;
  371.     push @td_post, substr $td_d, pos($wh_d);
  372.     push @td_pre,  substr $td_d, pos($wh_d) - length $1, length $1;
  373.     $td_s += 1 + length $wh_d; # Skip over ','
  374.       }
  375.       for my $i (0..$#wh_decls) {
  376.     my $p = "$td_post[$i]$post";
  377.     $p = '' unless $p =~ /\S/;
  378.     $out{$td_word[$i]} = ["$pre$td_pre[$i]", $p];
  379.       }
  380.     } elsif ($td =~ /\(\s* \*? \s* ([^)]+) \s* \) \s* \(.*\)/gxs){    # XXX: function pointer typedef
  381.       $out{$1} = ['XXX: pre_foo', 'XXX: post_bar']; # XXX: not sure what to stuff here
  382.       #warn "[$1] [$td]" if $verb;
  383.     } else {            # Only one thing defined...
  384.       $wh =~ /(\w+)/g;
  385.       my $e    = pos $wh;
  386.       my $s    = $e - length $1;
  387.       my $type    = $1;
  388.       my $pre    = substr $td, 0, $s;
  389.       my $post    = substr $td, $e, length($td) - $e;
  390.       $post = '' unless $post =~ /\S/;
  391.       $out{$type} = [$pre, $post];
  392.     }
  393.  
  394.     #die if $verb;
  395.  
  396.   }
  397.   \%out;
  398. }
  399.  
  400. sub typedef_structs {
  401.   my($typehash, $structs) = @_;
  402.   my %structs;
  403.   for (0 .. $#$structs) {
  404.     my $in = $structs->[$_];
  405.     my $key;
  406.     next unless $in =~ /^struct\s*(\w+)/;
  407.     next unless $in =~ s{^(struct\s*)(\w+)}{
  408.       $key = "struct $2";
  409.       $1 . " " x length($2)
  410.     }e;
  411.     my $name = parse_struct($in, \%structs);
  412.     $structs{$key} = defined($name) ? $structs{$name} : undef;
  413.   }
  414.   while (my($key, $text) = each %$typehash) {
  415.     my $name = parse_struct($text->[0], \%structs);
  416.     $structs{$key} = defined($name) ? $structs{$name} : undef;
  417.   }
  418.   \%structs;
  419. }
  420.  
  421. sub parse_struct {
  422.   my($in, $structs) = @_;
  423.   my($b, $e, $chunk, $vars, $struct, $structname);
  424.   return "$1 $2" if $in =~ /
  425.     ^ \s* (struct | union) \s+ (\w+) \s* $
  426.   /x;
  427.   ($structname, $in) = $in =~ /
  428.     ^ \s* ( (?: struct | union ) (?: \s+ \w+ )? ) \s* { \s* (.*?) \s* } \s* $
  429.   /gisx or return;
  430.   $structname .= " _ANON" unless $structname =~ /\s/;
  431.   $structname .= " 0" if exists $structs->{$structname};
  432.   $structname =~ s/(\d+$)/$1 + 1/e while exists $structs->{$structname};
  433.   $structname =~ s/\s+/ /g;
  434.   $b = 0;
  435.   while ($in =~ /(\{|;|$)/g) {
  436.     matchingbrace($in), next if $1 eq '{';
  437.     $e = pos($in);
  438.     next if $b == $e;
  439.     $chunk = substr($in, $b, $e - $b);
  440.     $b = $e;
  441.     if ($chunk =~ /\G\s*(struct|union|enum).*\}/gs) {
  442.       my $term = pos $chunk;
  443.       my $name = parse_struct(substr($chunk, 0, $term), $structs);
  444.       $vars = parse_vars(join ' ', $name, substr $chunk, $term);
  445.     } else {
  446.       $vars = parse_vars($chunk);
  447.     }
  448.     push @$struct, @{$vars||[]};
  449.   }
  450.   $structs->{$structname} = $struct;
  451.   $structname;
  452. }
  453.  
  454. sub parse_vars {
  455.   my $in = shift;
  456.   my($vars, $type, $word, $id, $post, $func);
  457.  
  458.   while ($in =~ /\G\s*([\[;,(]|\*+|:\s*\d+|\S+?\b|$)\s*/gc) {
  459.     $word = $1;
  460.     if ($word eq ';' || $word eq '') {
  461.       next unless defined $id;
  462.       $type = 'int' unless defined $type;    # or is this an error?
  463.       push @$vars, [ $type, $post, $id ];
  464.       ($type, $post, $id, $func) = (undef, undef, undef);
  465.     } elsif ($word eq ',') {
  466.       warn "panic: expecting name before comma in '$in'\n" unless defined $id;
  467.       $type = 'int' unless defined $type;    # or is this an error?
  468.       push @$vars, [ $type, $post, $id ];
  469.       $type =~ s/[ *]*$//;
  470.       $id = undef;
  471.     } elsif ($word eq '[') {
  472.       warn "panic: expecting name before '[' in '$in'\n" unless defined $id;
  473.       $type = 'int' unless defined $type;    # or is this an error?
  474.       my $b = pos $in;
  475.       matchingbrace($in);
  476.       $post .= $word . substr $in, $b, pos($in) - $b;
  477.     } elsif ($word eq '(') {
  478.       # simple hack for function pointers
  479.       $type = join ' ', grep defined, $type, $id if defined $id;
  480.       $type = 'int' unless defined $type;
  481.       if ($in =~ /\G\s*(\*[\s\*]*?)\s*(\w+)[\[\]\d\s]*(\)\s*\()/gc) {
  482.     $type .= "($1";
  483.     $id = $2;
  484.     $post = $3;
  485.     my $b = pos $in;
  486.     matchingbrace($in);
  487.     $post .= substr $in, $b, pos($in) - $b;
  488.       } else {
  489.     warn "panic: can't parse function pointer declaration in '$in'\n";
  490.     return;
  491.       }
  492.     } elsif ($word =~ /^:/) {
  493.       # bitfield
  494.       $type = 'int' unless defined $type;
  495.       $post .= $word;
  496.     } else {
  497.       if (defined $post) {
  498.     if ($func) {
  499.       $post .= $word;
  500.     } else {
  501.       warn "panic: not expecting '$word' after array bounds in '$in'\n";
  502.     }
  503.       } else {
  504.     $type = join ' ', grep defined, $type, $id if defined $id;
  505.     $id = $word;
  506.       }
  507.     }
  508.   }
  509. unless ($vars) {
  510.   warn sprintf "failed on <%s> with type=<%s>, id=<%s>, post=<%s> at pos=%d\n",
  511.     $in, $type, $id, $post, pos($in);
  512. }
  513.   $vars;
  514. }
  515.  
  516. sub vdecl_hash {
  517.   my($vdecls, $mdecls) = @_;
  518.   my %vdecl_hash;
  519.   for (@$vdecls, @$mdecls) {
  520.     next if /[()]/;    # ignore functions, and function pointers
  521.     my $copy = $_;
  522.     next unless $copy =~ s/^\s*extern\s*//;
  523.     my $vars = parse_vars($copy);
  524.     $vdecl_hash{$_->[2]} = [ @$_[0, 1] ] for @$vars;
  525.   }
  526.   \%vdecl_hash;
  527. }
  528.  
  529. # The output is the list of list of inline chunks and list of
  530. # declaration chunks.
  531.  
  532. sub functions_in {        # The arg is text without type declarations.
  533.   my $in = shift;        # remove_type_decl(top_level(sanitize($txt)));
  534.   # What remains now consists of variable and function declarations,
  535.   # and inline functions.
  536.   $in =~ /(?=\S)/g;
  537.   my ($b, $e, $b1, $e1, @inlines, @decls, @mdecls, @fdecls, @vdecls);
  538.   $b = pos $in;
  539.   my $chunk;
  540.   while (defined($b) && $b != length $in) {
  541.     $in =~ /;/g or pos $in = $b, $in =~ /.*\S|\Z/g ; # Or last non-space
  542.     $e = pos $in;
  543.     $chunk = substr $in, $b, $e - $b;
  544.     # Now subdivide the chunk.
  545.     # 
  546.     # What we got is one chunk, probably finished by `;'. Whoever, it
  547.     # may start with several inline functions.
  548.     #
  549.     # Note that inline functions contain ( ) { } in the stripped version.
  550.     $b1 = 0;
  551.     while ($chunk =~ /\(\s*\)\s*\{\s*\}/g) {
  552.       $e1 = pos $chunk;
  553.       push @inlines, $b + $b1, $b + $e1;
  554.       $chunk =~ /(?=\S)/g;
  555.       $b1 = pos $chunk; 
  556.       $b1 = length $chunk, last unless defined $b1;
  557.     }
  558.     if ($e - $b - $b1 > 0) {
  559.       my($isvar, $isfunc) = (1, 1);
  560.       substr ($chunk, 0, $b1) = '';
  561.       if ($chunk =~ /,/) {    # Contains multiple declarations.
  562.     push @mdecls, $b + $b1, $e;
  563.       } else  {            # Non-multiple.
  564.     # Since leading \s* is not optimized, this is quadratic!
  565.     $chunk =~ s{
  566.              ( ( const | __const
  567.              | __attribute__ \s* \( \s* \)
  568.                ) \s* )* ( ; \s* )? \Z # Strip from the end
  569.            }()x;
  570.     $chunk =~ s/\s*\Z//;
  571.     if ($chunk =~ /\)\Z/) { # Function declaration ends on ")"!
  572.       if ($chunk !~ m{ 
  573.               \( .* \( # Multiple parenths
  574.              }x
  575.           and $chunk =~ / \w \s* \( /x) { # Most probably pointer to a function?
  576.         $isvar = 0;
  577.       }
  578.     } elsif ($chunk =~ /
  579.       ^ \s* (enum|struct|union|class) \s+ \w+ \s* $
  580.     /x) {
  581.       $isvar = $isfunc = 0;
  582.     }
  583.     if ($isvar)  {    # Heuristically variable
  584.       push @vdecls, $b + $b1, $e;
  585.     } elsif ($isfunc) {
  586.       push @fdecls, $b + $b1, $e;
  587.     }
  588.       }
  589.       push @decls, $b + $b1, $e if $isvar || $isfunc;
  590.     }
  591.     $in =~ /\G\s*/g ;
  592.     $b = pos $in;
  593.   }
  594.   [\@inlines, \@decls, \@mdecls, \@vdecls, \@fdecls];
  595. }
  596.  
  597. # XXXX This is heuristical in many respects...
  598. # Recipe: remove all struct-ish chunks.  Remove all array specifiers.
  599. # Remove GCC attribute specifiers.
  600. # What remains may contain function's arguments, old types, and newly
  601. # defined types.
  602. # Remove function arguments using heuristics methods.
  603. # Now out of several words in a row the last one is a newly defined type.
  604.  
  605. sub whited_decl {        # Input is sanitized.
  606.   my $keywords_rex = shift;
  607.   my $in = shift;        # Text of a declaration
  608.  
  609.   #typedef ret_type*(*func) -> typedef ret_type* (*func)
  610.   $in =~ s/\*\(\*/* \(*/;
  611.  
  612.   my $rest  = $in;
  613.   my $out  = $in;        # Whited out $in
  614.  
  615.   # Remove all the structs
  616.   while ($out =~ /(\b(struct|union|class|enum)(\s+\w+)?\s*\{)/g) {
  617.     my $pos_start = pos($out) - length $1;
  618.  
  619.     matchingbrace($out);
  620.     my $pos_end = pos $out;
  621.     substr($out, $pos_start, $pos_end - $pos_start) =
  622.     ' ' x ($pos_end - $pos_start);
  623.     pos $out = $pos_end;
  624.   }
  625.  
  626.   # Deal with glibc's wierd ass __attribute__ tag.  Just dump it.
  627.   # Maaaybe this should check to see if you're using GCC, but I don't
  628.   # think so since glibc is nice enough to do that for you.  [MGS]
  629.   while ( $out =~ m/(\b(__attribute__|attribute)\s*\((?=\s*\())/g ) {
  630.       my $att_pos_start = pos($out) - length($1);
  631.  
  632.       # Need to figure out where ((..)) ends.
  633.       matchingbrace($out);
  634.       my $att_pos_end = pos $out;
  635.  
  636.       # Remove the __attribute__ tag.
  637.       substr($out, $att_pos_start, $att_pos_end - $att_pos_start) =
  638.     ' ' x ($att_pos_end - $att_pos_start);
  639.       pos $out = $att_pos_end;
  640.   }
  641.  
  642.   # Remove arguments of functions (heuristics only).
  643.   # These things (start) arglist of a declared function:
  644.   # paren word comma
  645.   # paren word space non-paren
  646.   # paren keyword paren
  647.   # start a list of arguments. (May be "cdecl *myfunc"?) XXXXX ?????
  648.   while ( $out =~ /(\(\s*(\w+(,|\s*[^\)\s])|$keywords_rex\s*\)))/g ) {
  649.     my $pos_start = pos($out) - length($1);
  650.     pos $out = $pos_start + 1;
  651.     matchingbrace($out);
  652.     substr ($out, $pos_start + 1, pos($out) - 2 - $pos_start)
  653.       = ' ' x (pos($out) - 2 - $pos_start);
  654.   }
  655.   # Remove array specifiers
  656.   $out =~ s/(\[[\w\s\+]*\])/ ' ' x length $1 /ge;
  657.   my $tout = $out;
  658.   # Several words in a row cannot be new typedefs, but the last one.
  659.   $out =~ s/((\w+\**\s+)+(?=[^\s,;\[\{\)]))/ ' ' x length $1 /ge;
  660.   unless ($out =~ /\w/) {
  661.     # Probably a function-type declaration: typedef int f(int);
  662.     # Redo scan leaving the last word of the first group of words:
  663.     $tout =~ /(\w+\s+)*(\w+)\s*\(/g;
  664.     $out = ' ' x (pos($tout) - length $2)
  665.       . $2 . ' ' x (length($tout) - pos($tout));
  666.     # warn "function typedef\n\t'$in'\nwhited-out as\n\t'$out'\n";
  667.   }
  668.   warn "panic: length mismatch\n\t'$in'\nwhited-out as\n\t'$out'\n"
  669.     if length($in) != length $out;
  670.   # Sanity check
  671.   warn "panic: multiple types without intervening comma in\n\t$in\nwhited-out as\n\t$out\n"
  672.     if $out =~ /\w[^\w,]+\w/;
  673.   warn "panic: no types found in\n\t$in\nwhited-out as\n\t$out\n"
  674.     unless $out =~ /\w/;
  675.   $out
  676. }
  677.  
  678. sub matchingbrace {
  679.   # pos($_[0]) is after the opening brace now
  680.   my $n = 0;
  681.   while ($_[0] =~ /([\{\[\(])|([\]\)\}])/g) {
  682.     $1 ? $n++ : $n-- ;
  683.     return 1 if $n < 0;
  684.   }
  685.   # pos($_[0]) is after the closing brace now
  686.   return;                # false
  687. }
  688.  
  689. sub remove_Comments_no_Strings { # We expect that no strings are around
  690.     my $in = shift;
  691.     $in =~ s,/(/.*|\*[\s\S]*?\*/),,g ; # C and C++
  692.     die "Unfinished comment" if $in =~ m,/\*, ;
  693.     $in;
  694. }
  695.  
  696. sub sanitize {        # We expect that no strings are around
  697.     my $in = shift;
  698.     # C and C++, strings and characters
  699.     $in =~ s{ / (
  700.          / .*            # C++ style
  701.          |
  702.          \* [\s\S]*? \*/    # C style
  703.         )            # (1)
  704.          | '((?:[^\\\']|\\.)+)'    # (2) Character constants
  705.          | "((?:[^\\\"]|\\.)*)"    # (3) Strings
  706.          | ( ^ \s* \# .*         # (4) Preprocessor
  707.          ( \\ $ \n .* )* )    # and continuation lines
  708.         } {
  709.           # We want to preserve the length, so that one may go back
  710.           defined $1 ? ' ' x (1 + length $1) :
  711.         defined $4 ? ' ' x length $4 :
  712.           defined $2 ? "'" . ' ' x length($2) . "'" :
  713.             defined $3 ? '"' . ' ' x length($3) . '"' : '???'
  714.         }xgem ;
  715.     die "Unfinished comment" if $in =~ m{ /\* }x;
  716.     $in;
  717. }
  718.  
  719. sub top_level {            # We expect argument is sanitized
  720.   # Note that this may remove the variable in declaration: int (*func)();
  721.   my $in = shift;
  722.   my $start;
  723.   my $out = $in;
  724.   while ($in =~ /[\[\{\(]/g ) {
  725.     $start = pos $in;
  726.     matchingbrace($in);
  727.     substr($out, $start, pos($in) - 1 - $start) 
  728.       = ' ' x (pos($in) - 1 - $start);
  729.   }
  730.   $out;
  731. }
  732.  
  733. sub remove_type_decl {        # We suppose that the arg is top-level only.
  734.   my $in = shift;
  735.   $in =~ s/(\b__extension__)(\s+typedef\b)/(' ' x length $1) . $2/gse;
  736.   $in =~ s/(\btypedef\b.*?;)/' ' x length $1/gse;
  737.   # The following form may appear only in the declaration of the type itself:
  738.   $in =~ 
  739.     s/(\b(enum|struct|union|class)\b[\s\w]*\{\s*\}\s*;)/' ' x length $1/gse;
  740.   $in;
  741. }
  742.  
  743. sub new {
  744.   my $class = shift;
  745.   my $out = SUPER::new $class $recipes;
  746.   $out->set(@_);
  747.   $out;
  748. }
  749.  
  750. sub do_declarations {
  751.   my @d = map do_declaration($_, $_[1], $_[2]), @{ $_[0] };
  752.   \@d;
  753. }
  754.  
  755. # Forth argument: if defined, there maybe no identifier. Generate one
  756. # basing on this argument.
  757.  
  758. sub do_declaration {
  759.   my ($decl, $typedefs, $keywords, $argnum) = @_;
  760.   $decl =~ s/;?\s*$//;
  761.  
  762.   my ($type, $typepre, $typepost, $ident, $args, $w, $pos, $repeater);
  763.   $decl =~ s/[\r\n]\s*/ /g;
  764. #warn "DECLAR [$decl][$argnum]\n";
  765.   $decl =~ s/^\s*__extension__\b\s*//;
  766.   $decl =~ s/^\s*extern\b\s*//;
  767.   $decl =~ s/^\s*__inline\b\s*//;
  768.   $pos = 0;
  769.   while ($decl =~ /(\w+)/g and ($typedefs->{$1} or $keywords->{$1})) {
  770.     $w = $1;
  771.     if ($w =~ /^(struct|class|enum|union)$/) {
  772.       $decl =~ /\G\s+\w+/g or die "`$w' is not followed by word in `$decl'";
  773.     }
  774.     $pos = pos $decl;
  775.   }
  776. #warn "pos: $pos\n";
  777.   pos $decl = $pos;
  778.   $decl =~ /\G[\s*]*\*/g or pos $decl = $pos;
  779.   $type = substr $decl, 0, pos $decl;
  780.   $decl =~ /\G\s*/g or pos $decl = length $type; # ????
  781.   $pos = pos $decl;
  782. #warn "pos: $pos\n";
  783.   if (defined $argnum) {
  784.     if ($decl =~ /\G(\w+)((\s*\[[^][]*\])*)/g) { # The best we can do with [2]
  785.       $ident = $1;
  786.       $repeater = $2;
  787.       $pos = pos $decl;
  788.     } else {
  789.       pos $decl = $pos = length $decl;
  790.       $type = $decl;
  791.       $ident = "arg$argnum";
  792.     }
  793.   } else {
  794.     die "Cannot process declaration `$decl' without an identifier"
  795.       unless $decl =~ /\G(\w+)/g;
  796.     $ident = $1;
  797.     $pos = pos $decl;
  798.   }
  799. #warn "pos: $pos\n";
  800.   $decl =~ /\G\s*/g or pos $decl = $pos;
  801.   $pos = pos $decl;
  802. #my $st = length $decl;
  803. #warn substr($decl, 0, $pos), "\n";
  804. #warn "pos: $pos $st\n";
  805. #warn "DECLAR [$decl][$argnum]\n";
  806.   if (pos $decl != length $decl) {
  807.     pos $decl = $pos;
  808.     die "Expecting parenth after identifier in `$decl'\nafter `",
  809.       substr($decl, 0, $pos), "'"
  810.       unless $decl =~ /\G\(/g;
  811.     my $argstring = substr($decl, pos($decl) - length $decl);
  812.     matchingbrace($argstring) or die "Cannot find matching parenth in `$decl'";
  813.     $argstring = substr($argstring, 0, pos($argstring) - 1);
  814.     $argstring =~ s/ ^ ( \s* void )? \s* $ //x;
  815.     $args = [];
  816.     my @args;
  817.     if ($argstring ne '') {
  818.       my $top = top_level $argstring;
  819.       my $p = 0;
  820.       my $arg;
  821.       while ($top =~ /,/g) {
  822.     $arg = substr($argstring, $p, pos($top) - 1 - $p);
  823.     $arg =~ s/^\s+|\s+$//gs;
  824.     push @args, $arg;
  825.     $p = pos $top;
  826.       }
  827.       $arg = substr $argstring, $p;
  828.       $arg =~ s/^\s+|\s+$//gs;
  829.       push @args, $arg;
  830.     }
  831.     my $i = 0;
  832.     for (@args) {
  833.       push @$args, do_declaration1($_, $typedefs, $keywords, $i++);
  834.     }
  835.   }
  836.   [$type, $ident, $args, $decl, $repeater];
  837. }
  838.  
  839. sub do_declaration1 {
  840.   my ($decl, $typedefs, $keywords, $argnum) = @_;
  841.   $decl =~ s/;?\s*$//;
  842. #warn "DECLARO [$decl][$argnum]\n";
  843.   my ($type, $typepre, $typepost, $ident, $args, $w, $pos, $repeater);
  844.   $pos = 0;
  845.   while ($decl =~ /(\w+)/g and ($typedefs->{$1} or $keywords->{$1})) {
  846.     $w = $1;
  847.     if ($w =~ /^(struct|class|enum|union)$/) {
  848.       $decl =~ /\G\s+\w+/g or die "`$w' is not followed by word in `$decl'";
  849.     }
  850.     $pos = pos $decl;
  851.   }
  852. #warn "POS: $pos\n";
  853.   pos $decl = $pos;
  854.   $decl =~ /\G[\s*]*\*/g or pos $decl = $pos;
  855.   $type = substr $decl, 0, pos $decl;
  856.   $decl =~ /\G\s*/g or pos $decl = length $type; # ????
  857.   $pos = pos $decl;
  858.   if (defined $argnum) {
  859.     if ($decl =~ /\G(\w+)((\s*\[[^][]*\])*)/g) { # The best we can do with [2]
  860.       $ident = $1;
  861.       $repeater = $2;
  862.       $pos = pos $decl;
  863.     } else {
  864.       pos $decl = $pos = length $decl;
  865.       $type = $decl;
  866.       $ident = "arg$argnum";
  867.     }
  868.   } else {
  869.     die "Cannot process declaration `$decl' without an identifier" 
  870.       unless $decl =~ /\G(\w+)/g;
  871.     $ident = $1;
  872.     $pos = pos $decl;
  873.   }
  874.   $decl =~ /\G\s*/g or pos $decl = $pos;
  875.   $pos = pos $decl;
  876. #warn "DECLAR1 [$decl][$argnum]\n";
  877. #my $st = length $decl;
  878. #warn substr($decl, 0, $pos), "\n";
  879. #warn "pos: $pos $st\n";
  880.   if (pos $decl != length $decl) {
  881.     pos $decl = $pos;
  882.     die "Expecting parenth after identifier in `$decl'\nafter `",
  883.       substr($decl, 0, $pos), "'"
  884.       unless $decl =~ /\G\(/g;
  885.     my $argstring = substr($decl, pos($decl) - length $decl);
  886.     matchingbrace($argstring) or die "Cannot find matching parenth in `$decl'";
  887.     $argstring = substr($argstring, 0, pos($argstring) - 1);
  888.     $argstring =~ s/ ^ ( \s* void )? \s* $ //x;
  889.     $args = [];
  890.     my @args;
  891.     if ($argstring ne '') {
  892.       my $top = top_level $argstring;
  893.       my $p = 0;
  894.       my $arg;
  895.       while ($top =~ /,/g) {
  896.     $arg = substr($argstring, $p, pos($top) - 1 - $p);
  897.     $arg =~ s/^\s+|\s+$//gs;
  898.     push @args, $arg;
  899.     $p = pos $top;
  900.       }
  901.       $arg = substr $argstring, $p;
  902.       $arg =~ s/^\s+|\s+$//gs;
  903.       push @args, $arg;
  904.     }
  905.     my $i = 0;
  906.     for (@args) {
  907.       push @$args, do_declaration1($_, $typedefs, $keywords, $i++);
  908.     }
  909.   }
  910.   [$type, $ident, $args, $decl, $repeater];
  911. }
  912.  
  913. ############################################################
  914.  
  915. package C::Preprocessed;
  916. use Symbol;
  917. use File::Basename;
  918. use Config;
  919. use constant WIN32 => $^O eq 'MSWin32';
  920.  
  921. sub new {
  922.     die "usage: C::Preprocessed->new(filename[, defines[, includes[, cpp]]])" 
  923.       if @_ < 2 or @_ > 5;
  924.     my ($class, $filename, $Defines, $Includes, $Cpp) 
  925.       = (shift, shift, shift, shift, shift);
  926.     $Cpp ||= \%Config::Config;
  927.     my $filedir = dirname $filename || '.';
  928.     $Includes ||= [$filedir, '/usr/local/include', '.'];
  929.     my $addincludes = "";
  930.     $addincludes = "-I" . join(" -I", @$Includes)
  931.       if defined $Includes and @$Includes;
  932.     my($sym) = gensym;
  933.     my $cmd = WIN32 ?
  934.         "$Cpp->{cppstdin} $Defines $addincludes $Cpp->{cppflags} $filename |" :
  935.         "echo '\#include \"$filename\"' | $Cpp->{cppstdin} $Defines $addincludes $Cpp->{cppflags} $Cpp->{cppminus} |";
  936.     #my $cmd = "echo '\#include <$filename>' | $Cpp->{cppstdin} $Defines $addincludes $Cpp->{cppflags} $Cpp->{cppminus} |";
  937.  
  938.     (open($sym, $cmd) or die "Cannot open pipe from `$cmd': $!")
  939.       and bless $sym => $class;
  940. }
  941.  
  942. sub text {
  943.   my $class = shift;
  944.   my $filter = shift;
  945.   if (defined $filter) {
  946.     return text_only_from($class, $filter, @_);
  947.   }
  948.   my $stream = $class->new(@_);
  949.   my $oh = select $stream;
  950.   local $/;
  951.   select $oh;
  952.   <$stream>;
  953. }
  954.  
  955. sub text_only_from {
  956.   my $class = shift;
  957.   my $from = shift || die "Expecting argument in `text_only_from'";
  958.   my $stream = $class->new(@_);
  959.   my $on = $from eq $_[0];
  960.   my $eqregexp = $on ? '\"\"|' : '';
  961.   my @out;
  962.   while (<$stream>) {
  963.     #print;
  964.  
  965.     $on = /$eqregexp[\"\/]\Q$from\"/ if /^\#/;
  966.     push @out, $_ if $on;
  967.   }
  968.   join '', @out;
  969. }
  970.  
  971. sub DESTROY {
  972.   close($_[0]) 
  973.     or die "Cannot close pipe from `$Config::Config{cppstdin}': err $?, $!\n";
  974. }
  975.  
  976. # Autoload methods go after __END__, and are processed by the autosplit program.
  977. # Return to the principal package.
  978. package ModPerl::CScan;
  979.  
  980. 1;
  981. __END__
  982.  
  983. =head1 NAME
  984.  
  985. ModPerl::CScan - scan C language files for easily recognized constructs.
  986.  
  987. =head1 SYNOPSIS
  988.  
  989. =head1 DESCRIPTION
  990.  
  991. See the C<C::Scan> manpage. This package is just a fork to fix certain
  992. things that didn't work in the original C<C::Scan>, which is not
  993. maintained any longer. These fixes required to make it work with the
  994. Apache 2 source code.
  995.  
  996. =cut
  997.