scan.pm

来自「ARM上的如果你对底层感兴趣」· PM 代码 · 共 764 行 · 第 1/2 页

package C::Scan;

require Exporter;
use Config '%Config';
use File::Basename;
use Data::Flow qw(0.05);
use strict;			# Earlier it catches ISA and EXPORT.

@C::Scan::ISA = qw(Exporter Data::Flow);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

@C::Scan::EXPORT = qw(
	    );
@C::Scan::EXPORT_OK = qw(
			);
# this flag tells cpp to only output macros
$C::Scan::MACROS_ONLY = '-dM';

$C::Scan::VERSION = '0.5';

my (%keywords,%style_keywords);
for (qw(asm auto break case char continue default do double else enum
        extern float for fortran goto if int long register return short
        sizeof static struct switch typedef union unsigned while void)) {
  $keywords{$_}++;
}
for (qw(bool class const delete friend inline new operator overload private
        protected public virtual)) {
  $style_keywords{'C++'}{$_}++;		
}
for (qw(inline const asm noreturn format section 
	constructor destructor unused weak)) {
  $style_keywords{'GNU'}{$_}++;
  $style_keywords{'GNU'}{"__$ {_}__"}++;
}
  $style_keywords{'GNU'}{__attribute__}++;
  $style_keywords{'GNU'}{__extension__}++;
  $style_keywords{'GNU'}{__consts}++;
  $style_keywords{'GNU'}{__const}++;

my $recipes
  = { Defines => { default => '' },
      cppstdin => { default => $Config{cppstdin} },
      cppflags => { default => $Config{cppflags} },
      cppminus => { default => $Config{cppminus} },
      c_styles => { default => ['C++', 'GNU'] },
      add_cppflags => { default => '' },
      keywords => { prerequisites => ['c_styles'],
		    output => sub {
		      my %kw = %keywords;
		      my %add;
		      for ( @{ shift->{c_styles} } ) {
			%add = %{ $style_keywords{$_} };
			%kw = (%kw, %add);
		      }
		      \%kw;
		    }, },
      'undef' => { default => undef },
      filename_filter => { default => undef },
      full_text => { class_filter => [ 'text', 'C::Preprocessed',
				       qw(undef filename Defines includeDirs Cpp)] },
      text => { class_filter => [ 'text', 'C::Preprocessed',
				  qw(filename_filter filename Defines includeDirs Cpp)] },
      text_only_from => { class_filter => [ 'text_only_from', 'C::Preprocessed',
					    qw(filename_filter filename Defines includeDirs Cpp)] },
      includes => { filter => [ \&includes, 
				qw(filename Defines includeDirs Cpp) ], },
      includeDirs =>  { prerequisites => ['filedir'], 
			output => sub {
			  my $data = shift;
			  [ $data->{filedir}, '/usr/local/include', '.'];
			} },
      Cpp => { prerequisites => [qw(cppminus add_cppflags cppflags cppstdin)], 
	       output => sub {
		 my $data = shift;
		 return { cppstdin => $data->{cppstdin},
			  cppflags => "$data->{cppflags} $data->{add_cppflags}",
			  cppminus => $data->{cppminus} };
	       } },
      filedir => { output => sub { dirname ( shift->{filename} || '.' ) } },
      sanitized => { filter => [ \&sanitize, 'text'], },
      toplevel => { filter => [ \&top_level, 'sanitized'], },
      full_sanitized => { filter => [ \&sanitize, 'full_text'], },
      full_toplevel => { filter => [ \&top_level, 'full_sanitized'], },
      no_type_decl => { filter => [ \&remove_type_decl, 'toplevel'], },
      typedef_chunks => { filter => [ \&typedef_chunks, 'full_toplevel'], },
      typedefs_maybe => { filter => [ \&typedefs_maybe, 
				      'full_sanitized', 'typedef_chunks'], },
      typedef_texts => { filter => [ \&typedef_texts, 
				      'full_text', 'typedef_chunks'], },
      typedef_hash => { prerequisites => ['typedefs_maybe'],
			output => sub { my %h; 
					for (@{$_[0]->{typedefs_maybe}}) {
					  $h{$_}++;
					}
					\%h;
				      }, },
      defines_maybe => { filter => [ \&defines_maybe, 'filename'], },
      defines_no_args => { prerequisites => ['defines_maybe'],
			   output => sub { shift->{defines_maybe}->[0] }, },
      defines_args => { prerequisites => ['defines_maybe'],
			output => sub { shift->{defines_maybe}->[1] }, },

      defines_full => { filter => [ \&defines_full, 
				    qw(filename Defines includeDirs Cpp) ], },
      defines_no_args_full => { prerequisites => ['defines_full'],
				output => sub { shift->{defines_full}->[0] }, },
      defines_args_full => { prerequisites => ['defines_full'],
			output => sub { shift->{defines_full}->[1] }, },

      decl_inlines => { filter => [ \&functions_in, 'no_type_decl'], },
      inline_chunks => { filter => [ sub { shift->[0] }, 'decl_inlines'], },
      inlines => { filter => [ \&from_chunks, 'inline_chunks', 'text'], },
      decl_chunks => { filter => [ sub { shift->[1] }, 'decl_inlines'], },
      decls => { filter => [ \&from_chunks, 'decl_chunks', 'text'], },
      fdecl_chunks => { filter => [ sub { shift->[4] }, 'decl_inlines'], },
      fdecls => { filter => [ \&from_chunks, 'fdecl_chunks', 'text'], },
      mdecl_chunks => { filter => [ sub { shift->[2] }, 'decl_inlines'], },
      mdecls => { filter => [ \&from_chunks, 'mdecl_chunks', 'text'], },
      vdecl_chunks => { filter => [ sub { shift->[3] }, 'decl_inlines'], },
      vdecls => { filter => [ \&from_chunks, 'vdecl_chunks', 'text'], },
      parsed_fdecls => { filter => [ \&do_declarations, 'fdecls', 
				     'typedef_hash', 'keywords'], },
    };

sub from_chunks {
  my $chunks = shift;
  my $txt = shift;
  my @out;
  my $i = 0;
  while ($i < @$chunks) {
    push @out, substr $txt, $chunks->[$i], $chunks->[ $i + 1 ] - $chunks->[$i];
    $i += 2;
  }
  \@out;
}

#sub process { request($recipes, @_) }
# Preloaded methods go here.

sub includes {
  my %seen;
  my $stream = new C::Preprocessed (@_)
    or die "Cannot open pipe from cppstdin: $!\n";
  
  while (<$stream>) {
    next unless m(^\s*\#\s*	# Leading hash
		  (line\s*)?	# 1: Optional line
		  ([0-9]+)\s*	# 2: Line number
		  (.*)		# 3: The rest
		 )x;
    my $include = $3;
    $include = $1 if $include =~ /"(.*)"/; # Filename may be in quotes
    $seen{$include}++ if $include ne "";
  }
  [keys %seen];
}

sub defines_maybe {
  my $file = shift;
  my ($mline,$line,%macros,%macrosargs,$sym,$args);
  open(C, $file) or die "Cannot open file $file: $!\n";
  while (not eof(C) and $line = <C>) {
    next unless 
      ( $line =~ s[
		   ^ \s* \# \s*	# Start of directive
		   define \s+
		   (\w+)	# 1: symbol
		   (?:
		    \( (.*?) \s* \) # 2: Minimal match for arguments
                                    # in parenths (without trailing
                                    # spaces)
		   )?		# optional, no grouping
		   \s*		# rest is the definition
		  ][]x );
    ($sym, $args) = ($1, $2);
    $mline = $';
    $mline .= <C> while not eof(C) and $mline =~ s/\\\n/\n/;
    chomp $mline;
    #print "sym: `$sym', args: `$args', mline: `$mline'\n";
    if (defined $args) {
      $macrosargs{$sym} = [ [split /\s*,\s*/, $args], $mline];
    } else {
      $macros{$sym} = $mline;
    }
  }
  close(C) or die "Cannot close file $file: $!\n";
  [\%macros, \%macrosargs];
}

sub defines_full {
  my $Cpp = $_[3];
  my ($mline,$line,%macros,%macrosargs,$sym,$args);

  # save the old cppflags and add the flag for only ouputting macro definitions
  my $old_cppstdin = $Cpp->{'cppstdin'};
  $Cpp->{'cppstdin'} = $old_cppstdin . " " . $C::Scan::MACROS_ONLY;

  my $stream = new C::Preprocessed (@_)
    or die "Cannot open pipe from cppstdin: $!\n";
  
  while (defined ($line = <$stream>)) {
    next unless 
      ( $line =~ s[
		   ^ \s* \# \s*	# Start of directive
		   define \s+
		   (\w+)	# 1: symbol
		   (?:
		    \( (.*?) \s* \) # 2: Minimal match for arguments
                                    # in parenths (without trailing
                                    # spaces)
		   )?		# optional, no grouping
		   \s*		# rest is the definition
		  ][]x );
    ($sym, $args) = ($1, $2);
    $mline = $';
    $mline .= <$stream> while ($mline =~ s/\\\n/\n/);
    chomp $mline;
#print STDERR "sym: `$sym', args: `$args', mline: `$mline'\n";
    if (defined $args) {
      $macrosargs{$sym} = [ [split /\s*,\s*/, $args], $mline];
    } else {
      $macros{$sym} = $mline;
    }
  }
  # restore the original cppflags
  $Cpp->{'cppstdin'} = $old_cppstdin;
  [\%macros, \%macrosargs];
}

# sub nexttypedef {
#   return unless $_[0] =~ /(\G|^|;)\s*typedef\b/g;
#   my $start = pos($_[0]) - 7;
#   nextsemi($_[0]);
#   my $end = pos $_[0];
#   # warn "Found `", substr($_[0], $start, $end - $start), "'\n" if $debug;
#   return $start, $end;
# }  

# sub nextsemi {
#   my $n = 0;
#   while ($_[0] =~ /([\(\{\[])|([\]\)\}])|(\;)/g) {
#     $n++ if defined $1;
#     $n-- if defined $2;
#     return if defined $3 and $n == 0;
#   }
#   die "No semicolon on the outer level";
# }

sub typedef_texts {
  my ($txt, $chunks) = (shift, shift);
  my ($b, $e, @out);
  my @in = @$chunks;
  while (($b, $e) = splice @in, 0, 2) {
    push @out, substr($txt, $b, $e - $b);
  }
  [@out];
}

sub typedef_chunks {		# Input is toplevel, output: starts and ends
  my $txt = shift;
  pos $txt = 0;
  my ($b, $e, @out);
  while ($txt =~ /\btypedef\b/g) {
    push @out, pos $txt;
    $txt =~ /;|\Z/g;
    push @out, pos $txt;
  }
  \@out;
}

# The output is the list of list of inline chunks and list of
# declaration chunks.

sub functions_in {		# The arg is text without type declarations.
  my $in = shift;		# remove_type_decl(top_level(sanitize($txt)));
  # What remains now consists of variable and function declarations,
  # and inline functions.
  $in =~ /(?=\S)/g;
  my ($b, $e, $b1, $e1, @inlines, @decls, @mdecls, @fdecls, @vdecls);
  $b = pos $in;
  my $chunk;
  while ($b != length $in) {
    $in =~ /;/g or pos $in = $b, $in =~ /.*\S|\Z/g ; # Or last non-space
    $e = pos $in;
    $chunk = substr $in, $b, $e - $b;
    # Now subdivide the chunk.
    # 
    # What we got is one chunk, probably finished by `;'. Whoever, it
    # may start with several inline functions.
    #
    # Note that inline functions contain ( ) { } in the stripped version.
    $b1 = 0;
    while ($chunk =~ /\(\s*\)\s*\{\s*\}/g) {
      $e1 = pos $chunk;
      push @inlines, $b + $b1, $b + $e1;
      $chunk =~ /(?=\S)/g;
      $b1 = pos $chunk; 
      $b1 = length $chunk, last unless defined $b1;
    }
    if ($e - $b - $b1 > 0) {
      push @decls, $b + $b1, $e;
      substr ($chunk, 0, $b1) = '';
      if ($chunk =~ /,/) {	# Contains multiple declarations.
	push @mdecls, $b + $b1, $e;
      } else  {			# Non-multiple.
	my $isvar = 1;
	$chunk =~ s{
		    \s* ( ( const
			    | __attribute__ \s* \( \s* \)
			  ) \s* )* ( ; \s* )? \Z # Strip from the end
		   }()x;
	if ($chunk =~ /\)\Z/) { # Function declaration ends on ")"!
	  if ($chunk !~ m{ 
			  \( .* \( # Multiple parenths
			 }x
	      and $chunk =~ / \w \s* \( /x) { # Most probably pointer to a function?
	    $isvar = 0;
	  }
	}
	if ($isvar)  {	# Heuristically variable
	  push @vdecls, $b + $b1, $e;
	} else {
	  push @fdecls, $b + $b1, $e;
	}
      }
    }
    $in =~ /\G\s*/g ;
    $b = pos $in;
  }
  [\@inlines, \@decls, \@mdecls, \@vdecls, \@fdecls];
}

sub typedefs_maybe {		# Input is sanitized text, and list of beg/end.
  my @lst = @{$_[1]};
  my @out;
  my ($b, $e);
  while ($b = shift @lst) {
    $e = shift @lst;
    push @out, typedef_words(substr $_[0], $b, $e - $b);
  }
  \@out;
}

sub typedef_words {		# Input is sanitized.
  my $in = shift;		# Text of typedef.
  # Remove all the structs
  my $rest  = $in;
  my $start = "";
  while ($rest =~ s/\b(struct|union|class|enum)(\s+\w+)?\s*\{//) {
    $rest = $';
    $start .= $`;
    pos $rest = 0;
    matchingbrace($rest);
    $rest = substr $rest, pos $rest;
  }
  $in = $start . $rest;
  # Remove arguments of functions (heuristics only): 
  # paren word comma
  # paren word space non-paren
  # start a list of arguments. (May be "cdecl *myfunc"?) XXXXX ?????
  while ( $in =~ /\(\s*\w+(,|\s+[^\)\s])/g ) {
    pos $in = $start = pos($in) - length($&) + 1; # Cannot use $` because of optimizations
    matchingbrace($in);
    substr ($in, $start, pos($in) - 1 - $start) = '';
  } 
  # Remove array specifiers
  $in =~ s/\[[\w\s]*\]/ /g;
  # Several words in a row cannot be new typedefs, but the last one.
  $in =~ s/(\w+\s+)+(?=[^\s,;\[\{\)])//g;
  ( $in =~ /(\w+)/g );
}

sub matchingbrace {
  # pos($_[0]) is after the opening brace now
  my $n = 0;
  while ($_[0] =~ /([\{\[\(])|([\]\)\}])/g) {
    $1 ? $n++ : $n-- ;
    return 1 if $n < 0;