cscan.pm

视频监控网络部分的协议ddns,的模块的实现代码,请大家大胆指正.

          my $mid = $tout =~ s/.*?(\w*)$/$1/ ? length $1 : 0;
          # restore the length
          $out = $tout . ' ' x ($len - $mid);
      }
      # warn "function typedef\n\t'$in'\nwhited-out as\n\t'$out'\n";
  }
  warn "panic: length mismatch\n\t'$in'\nwhited-out as\n\t'$out'\n"
    if length($in) != length $out;
  # Sanity check
  warn "panic: multiple types without intervening comma in\n\t'$in'\nwhited-out as\n\t'$out'\n"
    if $out =~ /\w[^\w,]+\w/;
  warn "panic: no types found in\n\t'$in'\nwhited-out as\n\t'$out'\n"
    unless $out =~ /\w/;
  $out
}

sub matchingbrace {
  # pos($_[0]) is after the opening brace now
  my $n = 0;
  while ($_[0] =~ /([\{\[\(])|([\]\)\}])/g) {
    $1 ? $n++ : $n-- ;
    return 1 if $n < 0;
  }
  # 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
		 ( \\ $ \n .* )* )	# and continuation lines
	    } {
	      # We want to preserve the length, so that one may go back
	      defined $1 ? ' ' x (1 + 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/(\b__extension__)(\s+typedef\b)/(' ' x length $1) . $2/gse;
  $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/[\r\n]\s*/ /g;
#warn "DECLAR [$decl][$argnum]\n";
  $decl =~ s/^\s*__extension__\b\s*//;
  $decl =~ s/^\s*extern\b\s*//;
  $decl =~ s/^\s*__inline\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;
  }
#warn "pos: $pos\n";
  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;
#warn "pos: $pos\n";
  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;
  }
#warn "pos: $pos\n";
  $decl =~ /\G\s*/g or pos $decl = $pos;
  $pos = pos $decl;
#my $st = length $decl;
#warn substr($decl, 0, $pos), "\n";
#warn "pos: $pos $st\n";
#warn "DECLAR [$decl][$argnum]\n";
  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*$//;
#warn "DECLARO [$decl][$argnum]\n";
  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;
  }
#warn "POS: $pos\n";
  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;
#warn "DECLAR1 [$decl][$argnum]\n";
#my $st = length $decl;
#warn substr($decl, 0, $pos), "\n";
#warn "pos: $pos $st\n";
  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];
}

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

package C::Preprocessed;
use Symbol;
use File::Basename;
use Config;
use constant WIN32 => $^O eq 'MSWin32';

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) = gensym;
    my $cmd = WIN32 ?
        "$Cpp->{cppstdin} $Defines $addincludes $Cpp->{cppflags} $filename |" :
        "echo '\#include \"$filename\"' | $Cpp->{cppstdin} $Defines $addincludes $Cpp->{cppflags} $Cpp->{cppminus} |";
    #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;
  local $/;
  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 ModPerl::CScan;

1;
__END__

=head1 NAME

ModPerl::CScan - scan C language files for easily recognized constructs.

=head1 SYNOPSIS

=head1 DESCRIPTION

See the C<C::Scan> manpage. This package is just a fork to fix certain
things that didn't work in the original C<C::Scan>, which is not
maintained any longer. These fixes required to make it work with the
Apache 2 source code.

=cut