scan.pm

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

  }
  # pos($_[0]) is after the closing brace now
  return "";				# false
}

sub remove_Comments_no_Strings { # We expect that no strings are around
    my $in = shift;
    $in =~ s,/(/.*|\*[\s\S]*?\*/),,g ; # C and C++
    die "Unfinished comment" if $in =~ m,/\*, ;
    $in;
}

sub sanitize {		# We expect that no strings are around
    my $in = shift;
    # C and C++, strings and characters
    $in =~ s{ / ( 
		 / .*			# C++ style
		 |
		 \* [\s\S]*? \*/	# C style
		)			# (1)
		| '([^\\\']|\\.)+'	# (2) Character constants
		  | "([^\\\"]|\\.)*"	# (3) Strings
		    | ( ^ \s* \# .* 	# (4) Preprocessor
			( \\ $ .* )* )	# and continuation lines
	    } {
	      # We want to preserve the length, so that one may go back
	      defined $1 ? ' ' x length $1 :
		defined $4 ? ' ' x length $4 :
		  defined $2 ? "'" . ' ' x length($2) . "'" :
		    defined $3 ? '"' . ' ' x length($3) . '"' : '???'
	    }xgem ;
    die "Unfinished comment" if $in =~ m{ /\* }x;
    $in;
}

sub top_level {			# We expect argument is sanitized
  # Note that this may remove the variable in declaration: int (*func)();
  my $in = shift;
  my $start;
  my $out = $in;
  while ($in =~ /[\[\{\(]/g ) {
    $start = pos $in;
    matchingbrace($in);
    substr($out, $start, pos($in) - 1 - $start) 
      = ' ' x (pos($in) - 1 - $start);
  }
  $out;
}

sub remove_type_decl {		# We suppose that the arg is top-level only.
  my $in = shift;
  $in =~ s/(\btypedef\b.*?;)/' ' x length $1/gse;
  # The following form may appear only in the declaration of the type itself:
  $in =~ 
    s/(\b(enum|struct|union|class)\b[\s\w]*\{\s*\}\s*;)/' ' x length $1/gse;
  $in;
}

sub new { 
  my $class = shift; 
  my $out = SUPER::new $class $recipes;  
  $out->set(@_); 
  $out;
}

sub do_declarations {
  my @d = map do_declaration($_, $_[1], $_[2]), @{ $_[0] };
  \@d;
}

# Forth argument: if defined, there maybe no identifier. Generate one
# basing on this argument.

sub do_declaration {
  my ($decl, $typedefs, $keywords, $argnum) = @_;
  $decl =~ s/;?\s*$//;
  my ($type, $typepre, $typepost, $ident, $args, $w, $pos, $repeater);
  $decl =~ s/^\s*extern\b\s*//;
  $pos = 0;
  while ($decl =~ /(\w+)/g and ($typedefs->{$1} or $keywords->{$1})) {
    $w = $1;
    if ($w =~ /^(struct|class|enum|union)$/) {
      $decl =~ /\G\s+\w+/g or die "`$w' is not followed by word in `$decl'";
    }
    $pos = pos $decl;
  }
  pos $decl = $pos;
  $decl =~ /\G[\s*]*\*/g or pos $decl = $pos;
  $type = substr $decl, 0, pos $decl;
  $decl =~ /\G\s*/g or pos $decl = length $type; # ????
  $pos = pos $decl;
  if (defined $argnum) {
    if ($decl =~ /\G(\w+)((\s*\[[^][]*\])*)/g) { # The best we can do with [2]
      $ident = $1;
      $repeater = $2;
      $pos = pos $decl;
    } else {
      pos $decl = $pos = length $decl;
      $type = $decl;
      $ident = "arg$argnum";
    }
  } else {
    die "Cannot process declaration `$decl' without an identifier" 
      unless $decl =~ /\G(\w+)/g;
    $ident = $1;
    $pos = pos $decl;
  }
  $decl =~ /\G\s*/g or pos $decl = $pos;
  $pos = pos $decl;
  if (pos $decl != length $decl) {
    pos $decl = $pos;
    die "Expecting parenth after identifier in `$decl'\nafter `",
      substr($decl, 0, $pos), "'"
      unless $decl =~ /\G\(/g;
    my $argstring = substr($decl, pos($decl) - length $decl);
    matchingbrace($argstring) or die "Cannot find matching parenth in `$decl'";
    $argstring = substr($argstring, 0, pos($argstring) - 1);
    $argstring =~ s/ ^ ( \s* void )? \s* $ //x;
    $args = [];
    my @args;
    if ($argstring ne '') {
      my $top = top_level $argstring;
      my $p = 0;
      my $arg;
      while ($top =~ /,/g) {
	$arg = substr($argstring, $p, pos($top) - 1 - $p);
	$arg =~ s/^\s+|\s+$//gs;
	push @args, $arg;
	$p = pos $top;
      }
      $arg = substr $argstring, $p;
      $arg =~ s/^\s+|\s+$//gs;
      push @args, $arg;
    }
    my $i = 0;
    for (@args) {
      push @$args, do_declaration1($_, $typedefs, $keywords, $i++);
    }
  }
  [$type, $ident, $args, $decl, $repeater];
}

sub do_declaration1 {
  my ($decl, $typedefs, $keywords, $argnum) = @_;
  $decl =~ s/;?\s*$//;
  my ($type, $typepre, $typepost, $ident, $args, $w, $pos, $repeater);
  $pos = 0;
  while ($decl =~ /(\w+)/g and ($typedefs->{$1} or $keywords->{$1})) {
    $w = $1;
    if ($w =~ /^(struct|class|enum|union)$/) {
      $decl =~ /\G\s+\w+/g or die "`$w' is not followed by word in `$decl'";
    }
    $pos = pos $decl;
  }
  pos $decl = $pos;
  $decl =~ /\G[\s*]*\*/g or pos $decl = $pos;
  $type = substr $decl, 0, pos $decl;
  $decl =~ /\G\s*/g or pos $decl = length $type; # ????
  $pos = pos $decl;
  if (defined $argnum) {
    if ($decl =~ /\G(\w+)((\s*\[[^][]*\])*)/g) { # The best we can do with [2]
      $ident = $1;
      $repeater = $2;
      $pos = pos $decl;
    } else {
      pos $decl = $pos = length $decl;
      $type = $decl;
      $ident = "arg$argnum";
    }
  } else {
    die "Cannot process declaration `$decl' without an identifier" 
      unless $decl =~ /\G(\w+)/g;
    $ident = $1;
    $pos = pos $decl;
  }
  $decl =~ /\G\s*/g or pos $decl = $pos;
  $pos = pos $decl;
  if (pos $decl != length $decl) {
    pos $decl = $pos;
    die "Expecting parenth after identifier in `$decl'\nafter `",
      substr($decl, 0, $pos), "'"
      unless $decl =~ /\G\(/g;
    my $argstring = substr($decl, pos($decl) - length $decl);
    matchingbrace($argstring) or die "Cannot find matching parenth in `$decl'";
    $argstring = substr($argstring, 0, pos($argstring) - 1);
    $argstring =~ s/ ^ ( \s* void )? \s* $ //x;
    $args = [];
    my @args;
    if ($argstring ne '') {
      my $top = top_level $argstring;
      my $p = 0;
      my $arg;
      while ($top =~ /,/g) {
	$arg = substr($argstring, $p, pos($top) - 1 - $p);
	$arg =~ s/^\s+|\s+$//gs;
	push @args, $arg;
	$p = pos $top;
      }
      $arg = substr $argstring, $p;
      $arg =~ s/^\s+|\s+$//gs;
      push @args, $arg;
    }
    my $i = 0;
    for (@args) {
      push @$args, do_declaration2($_, $typedefs, $keywords, $i++);
    }
  }
  [$type, $ident, $args, $decl, $repeater];
}

############################################################

package C::Preprocessed;
use POSIX 'closedir';		# gensym only, not exported
use File::Basename;
use Config;

sub new {
    die "usage: C::Preprocessed->new(filename[, defines[, includes[, cpp]]])" 
      if @_ < 2 or @_ > 5;
    my ($class, $filename, $Defines, $Includes, $Cpp) 
      = (shift, shift, shift, shift, shift);
    $Cpp ||= \%Config::Config;
    my $filedir = dirname $filename || '.';
    $Includes ||= [$filedir, '/usr/local/include', '.'];
    my $addincludes = "";
    $addincludes = "-I" . join(" -I", @$Includes)
      if defined $Includes and @$Includes;
    my($sym) = $class->POSIX::gensym;
    my $cmd = "echo '\#include \"$filename\"' | $Cpp->{cppstdin} $Defines $addincludes $Cpp->{cppflags} $Cpp->{cppminus} |";
    #my $cmd = "$Cpp->{cppstdin} $Defines $addincludes $Cpp->{cppflags} $Cpp->{cppminus} < $filename |";
    #my $cmd = "echo '\#include <$filename>' | $Cpp->{cppstdin} $Defines $addincludes $Cpp->{cppflags} $Cpp->{cppminus} |";

    (open($sym, $cmd) or die "Cannot open pipe from `$cmd': $!")
      and bless $sym => $class;
}

sub text {
  my $class = shift;
  my $filter = shift;
  if (defined $filter) {
    return text_only_from($class, $filter, @_);
  }
  my $stream = $class->new(@_);
  my $oh = select $stream;
  $/ = undef;
  select $oh;
  <$stream>;
}

sub text_only_from {
  my $class = shift;
  my $from = shift || die "Expecting argument in `text_only_from'";
  my $stream = $class->new(@_);
  my $on = $from eq $_[0];
  my $eqregexp = $on ? '\"\"|' : '';
  my @out;
  while (<$stream>) {
    #print;
    
    $on = /$eqregexp[\"\/]\Q$from\"/ if /^\#/;
    push @out, $_ if $on;
  }
  join '', @out;
}

sub DESTROY {
  close($_[0]) 
    or die "Cannot close pipe from `$Config::Config{cppstdin}': err $?, $!\n";
}

# Autoload methods go after __END__, and are processed by the autosplit program.
# Return to the principal package.
package C::Scan;

1;
__END__

=head1 NAME

C::Scan - scan C language files for easily recognized constructs.

=head1 SYNOPSIS

  $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter,
                   'add_cppflags' => $addflags;
  $c->set('includeDirs' => [$Config::Config{shrpdir}]);
  
  my $fdec = $c->get('parsed_fdecls');


=head1 DESCRIPTION

B<This description is I<VERY> incomplete.>

This module uses C<Data::Flow> interface, thus one uses it in the
following fashion:

  $c = new C::Scan(attr1 => $value1, attr2 => $value2);
  $c->set( attr3 => $value3 );

  $value4 = $c->get('attr4');

Attributes are depending on some other attributes. The only
I<required> attribute, i.e., the attribute which I<should> be set, is
C<filename>, which denotes which file to parse.

All other attributes are either optional, or would be calculated basing on values of required and optional attributes.

=head2 Output attributes

=over 14

=item C<includes>

Value: reference to a list of included files.

=item C<defines_args>

Value: reference to hash of macros with arguments. The values are
references to an array of length 2, the first element is a reference
to the list of arguments, the second one being the expansion.
Newlines are not unescaped, thus

  #define C(x,y) E\
                 F

will finish with C<("C" =E<gt> [ ["x", "y"], "E\nF"])>.

=item C<defines_no_args>

Value: reference to hash of macros without arguments.  Newlines are
not escaped, thus

  #define A B

will finish with C<("A" =E<gt> "B")>.

=item C<fdecls>

Value: reference to list of declarations of functions.

=item C<inlines>

Value: reference to list of definitions of functions.

=item C<parsed_fdecls>

Value: reference to list of parsed declarations of functions. 

A parsed declaration is a reference to a list of C<(rt, nm, args, ft,
mod)>. Here C<rt> is return type of a function, C<nm> is the name,
C<args> is the list of arguments, C<ft> is the full text of the
declaration, and C<mod> is the modifier (which is always C<undef>).

Each entry in the list C<args> is of the same form C<(ty, nm, args,
ft, mod)>, here C<ty> is the type of an argument, C<nm> is the name (a
generated one if missing in the declaration), C<args> is C<undef>, and
C<mod> is the string of array modifiers.

=item C<typedef_hash>

Value: a reference to a hash which contains known C<typedef>s as keys.

=item C<typedef_texts>

Value: a reference to a list which contains known expansions of
C<typedef>s.

=item C<typedefs_maybe>

Value: a reference to a list of C<typedef>ed names. (Syncronized with
C<typedef_texts>).

=item C<vdecls>

Value: a reference to a list of C<extern> variable declarations.

=back

=cut