cscan.pm

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

package ModPerl::CScan;

require Exporter;
use Config '%Config';
use File::Basename;

# NOTE to distributors: this module is needed only for mp2 developers,
# it's not a requirement for mod_perl users
use Data::Flow qw(0.05);

use strict;			# Earlier it catches ISA and EXPORT.

@ModPerl::CScan::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.

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

$ModPerl::CScan::VERSION = '0.75';

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 signed while void volatile)) {
  $keywords{$_}++;
}
for (qw(bool class const delete friend inline new operator overload private
        protected public virtual)) {
  $style_keywords{'C++'}{$_}++;
}
for (qw(__func__ _Complex _Imaginary _Bool inline restrict)) {
  $style_keywords{'C9X'}{$_}++;
}
for (qw(inline const asm noreturn 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}++;
  $style_keywords{'GNU'}{__restrict}++;

my $recipes
  = { Defines => { default => '' },
      cppstdin => { default => $Config{cppstdin} },
      cppflags => { default => $Config{cppflags} },
      cppminus => { default => $Config{cppminus} },
      c_styles => { default => [qw(C++ GNU C9X)] },
      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'], },
      struct_chunks => { filter => [ \&struct_chunks, 'full_toplevel'], },
      typedefs_whited => { filter => [ \&typedefs_whited,
				       'full_sanitized', 'typedef_chunks',
				       'keywords_rex'], },
      typedef_texts => { filter => [ \&typedef_texts,
				     'full_text', 'typedef_chunks'], },
      struct_texts => { filter => [ \&typedef_texts,
				    'full_text', 'struct_chunks'], },
      typedef_hash => { filter => [ \&typedef_hash,
				    'typedef_texts', 'typedefs_whited'], },
      typedef_structs => { filter => [ \&typedef_structs,
				       'typedef_hash', 'struct_texts'], },
      typedefs_maybe => { filter => [ sub {[keys %{+shift}]},
				      'typedef_hash'], },
      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'], },
      vdecl_hash => { filter => [ \&vdecl_hash, 'vdecls', 'mdecls' ], },
      parsed_fdecls => { filter => [ \&do_declarations, 'fdecls', 
				     'typedef_hash', 'keywords'], },
      keywords_rex => { filter => [ sub { my @k = keys %{ shift() };
					  local $" = '|';
					  my $r = "(?:@k)";
					  eval 'qr/$r/' or $r	# Older Perls
					}, '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
    $include =~ s,\\\\,/,g if $^O eq 'os2';
    $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
		   ([\s\S]*)	# 3: the rest
		  ][]x );
    ($sym, $args, $mline) = ($1, $2, $3);
    $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 . " " . $ModPerl::CScan::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
		   ([\s\S]*)	# 3: the rest
		  ][]x );
    ($sym, $args, $mline) = ($1, $2, $3);
    $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 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;
}

sub struct_chunks {
  my $txt = shift;
  pos $txt = 0;
  my ($b, $e, @out);
  while ($txt =~ /\b(?=struct\s*(\w*\s*)?\{)/g) {
    push @out, pos $txt;
    $txt =~ /(?=;)|\Z/g;
    push @out, pos $txt;
  }
  \@out;
}

sub typedefs_whited {		# 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, whited_decl($_[2], substr $_[0], $b, $e - $b);
  }
  \@out;
}

sub structs_whited {
  my @lst = @{$_[1]};
  my @out;
  my ($b, $e, $in);
  while ($b = shift @lst) {
    $e = shift @lst;
    $in = substr $_[0], $b, $e - $b;
    $in =~ s/^(struct\s*(\w*\s*)?)(.*)$/$1 . " " x length($3)/es;
    push @out, $in;
  }
  \@out;
}

sub typedef_texts {
  my ($txt, $chunks) = (shift, shift);
  my ($b, $e, $in, @out);
  my @in = @$chunks;
  while (($b, $e) = splice @in, 0, 2) {
    $in = substr($txt, $b, $e - $b);
    # remove any remaining directives
    $in =~ s/^ ( \s* \# .* ( \\ $ \n .* )* ) / ' ' x length($1)/xgem;
    push @out, $in;
  }
  \@out;
}

sub typedef_hash {
  my ($typedefs, $whited) = (shift,shift);
  my %out;

 loop:
  for my $o (0..$#$typedefs) {
    my $wh = $whited->[$o];
    my $td = $typedefs->[$o];
#my $verb = $td =~ /apr_child_errfn_t/ ? 1 : 0;
#warn "$wh || $td\n" if $verb;
    if ($wh =~ /,/ or not $wh =~ /\w/) { # Hard case, guessimates ...
      # Determine whether the new thingies are inside parens
      $wh =~ /,/g;
      my $p = pos $wh;
      my ($s, $e);
      if (matchingbrace($wh)) {	# Inside.  Easy part: just split on /,/...
	$e = pos($wh) - 1;
	$s = $e;
	my $d = 0;
	# Skip back
	while (--$s >= 0) {
	  my $c = substr $wh, $s, 1;
	  if ($c =~ /[\(\{\[]/) {
	    $d--;