parsexs.pm

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

package ExtUtils::ParseXS;

use 5.006;  # We use /??{}/ in regexes
use Cwd;
use Config;
use File::Basename;
use File::Spec;
use Symbol;

require Exporter;

@ISA = qw(Exporter);
@EXPORT_OK = qw(process_file);

# use strict;  # One of these days...

my(@XSStack);	# Stack of conditionals and INCLUDEs
my($XSS_work_idx, $cpp_next_tmp);

use vars qw($VERSION);
$VERSION = '2.18_02';

use vars qw(%input_expr %output_expr $ProtoUsed @InitFileCode $FH $proto_re $Overload $errors $Fallback
	    $cplusplus $hiertype $WantPrototypes $WantVersionChk $except $WantLineNumbers
	    $WantOptimize $process_inout $process_argtypes @tm
	    $dir $filename $filepathname %IncludedFiles
	    %type_kind %proto_letter
            %targetable $BLOCK_re $lastline $lastline_no
            $Package $Prefix @line @BootCode %args_match %defaults %var_types %arg_list @proto_arg
            $processing_arg_with_types %argtype_seen @outlist %in_out %lengthof
            $proto_in_this_xsub $scope_in_this_xsub $interface $prepush_done $interface_macro $interface_macro_set
            $ProtoThisXSUB $ScopeThisXSUB $xsreturn
            @line_no $ret_type $func_header $orig_args
	   ); # Add these just to get compilation to happen.


sub process_file {
  
  # Allow for $package->process_file(%hash) in the future
  my ($pkg, %args) = @_ % 2 ? @_ : (__PACKAGE__, @_);
  
  $ProtoUsed = exists $args{prototypes};
  
  # Set defaults.
  %args = (
	   # 'C++' => 0, # Doesn't seem to *do* anything...
	   hiertype => 0,
	   except => 0,
	   prototypes => 0,
	   versioncheck => 1,
	   linenumbers => 1,
	   optimize => 1,
	   prototypes => 0,
	   inout => 1,
	   argtypes => 1,
	   typemap => [],
	   output => \*STDOUT,
	   csuffix => '.c',
	   %args,
	  );

  # Global Constants
  
  my ($Is_VMS, $SymSet);
  if ($^O eq 'VMS') {
    $Is_VMS = 1;
    # Establish set of global symbols with max length 28, since xsubpp
    # will later add the 'XS_' prefix.
    require ExtUtils::XSSymSet;
    $SymSet = new ExtUtils::XSSymSet 28;
  }
  @XSStack = ({type => 'none'});
  ($XSS_work_idx, $cpp_next_tmp) = (0, "XSubPPtmpAAAA");
  @InitFileCode = ();
  $FH = Symbol::gensym();
  $proto_re = "[" . quotemeta('\$%&*@;[]') . "]" ;
  $Overload = 0;
  $errors = 0;
  $Fallback = 'PL_sv_undef';

  # Most of the 1500 lines below uses these globals.  We'll have to
  # clean this up sometime, probably.  For now, we just pull them out
  # of %args.  -Ken
  
  $cplusplus = $args{'C++'};
  $hiertype = $args{hiertype};
  $WantPrototypes = $args{prototypes};
  $WantVersionChk = $args{versioncheck};
  $except = $args{except} ? ' TRY' : '';
  $WantLineNumbers = $args{linenumbers};
  $WantOptimize = $args{optimize};
  $process_inout = $args{inout};
  $process_argtypes = $args{argtypes};
  @tm = ref $args{typemap} ? @{$args{typemap}} : ($args{typemap});
  
  for ($args{filename}) {
    die "Missing required parameter 'filename'" unless $_;
    $filepathname = $_;
    ($dir, $filename) = (dirname($_), basename($_));
    $filepathname =~ s/\\/\\\\/g;
    $IncludedFiles{$_}++;
  }
  
  # Open the input file
  open($FH, $args{filename}) or die "cannot open $args{filename}: $!\n";

  # Open the output file if given as a string.  If they provide some
  # other kind of reference, trust them that we can print to it.
  if (not ref $args{output}) {
    open my($fh), "> $args{output}" or die "Can't create $args{output}: $!";
    $args{outfile} = $args{output};
    $args{output} = $fh;
  }

  # Really, we shouldn't have to chdir() or select() in the first
  # place.  For now, just save & restore.
  my $orig_cwd = cwd();
  my $orig_fh = select();
  
  chdir($dir);
  my $pwd = cwd();
  my $csuffix = $args{csuffix};
  
  if ($WantLineNumbers) {
    my $cfile;
    if ( $args{outfile} ) {
      $cfile = $args{outfile};
    } else {
      $cfile = $args{filename};
      $cfile =~ s/\.xs$/$csuffix/i or $cfile .= $csuffix;
    }
    tie(*PSEUDO_STDOUT, 'ExtUtils::ParseXS::CountLines', $cfile, $args{output});
    select PSEUDO_STDOUT;
  } else {
    select $args{output};
  }

  foreach my $typemap (@tm) {
    die "Can't find $typemap in $pwd\n" unless -r $typemap;
  }

  push @tm, standard_typemap_locations();

  foreach my $typemap (@tm) {
    next unless -f $typemap ;
    # skip directories, binary files etc.
    warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
      unless -T $typemap ;
    open(TYPEMAP, $typemap)
      or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
    my $mode = 'Typemap';
    my $junk = "" ;
    my $current = \$junk;
    while (<TYPEMAP>) {
      next if /^\s*		#/;
        my $line_no = $. + 1;
      if (/^INPUT\s*$/) {
	$mode = 'Input';   $current = \$junk;  next;
      }
      if (/^OUTPUT\s*$/) {
	$mode = 'Output';  $current = \$junk;  next;
      }
      if (/^TYPEMAP\s*$/) {
	$mode = 'Typemap'; $current = \$junk;  next;
      }
      if ($mode eq 'Typemap') {
	chomp;
	my $line = $_ ;
	TrimWhitespace($_) ;
	# skip blank lines and comment lines
	next if /^$/ or /^#/ ;
	my($type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or
	  warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next;
	$type = TidyType($type) ;
	$type_kind{$type} = $kind ;
	# prototype defaults to '$'
	$proto = "\$" unless $proto ;
	warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n")
	  unless ValidProtoString($proto) ;
	$proto_letter{$type} = C_string($proto) ;
      } elsif (/^\s/) {
	$$current .= $_;
      } elsif ($mode eq 'Input') {
	s/\s+$//;
	$input_expr{$_} = '';
	$current = \$input_expr{$_};
      } else {
	s/\s+$//;
	$output_expr{$_} = '';
	$current = \$output_expr{$_};
      }
    }
    close(TYPEMAP);
  }

  foreach my $value (values %input_expr) {
    $value =~ s/;*\s+\z//;
    # Move C pre-processor instructions to column 1 to be strictly ANSI
    # conformant. Some pre-processors are fussy about this.
    $value =~ s/^\s+#/#/mg;
  }
  foreach my $value (values %output_expr) {
    # And again.
    $value =~ s/^\s+#/#/mg;
  }

  my ($cast, $size);
  our $bal = qr[(?:(?>[^()]+)|\((??{ $bal })\))*]; # ()-balanced
  $cast = qr[(?:\(\s*SV\s*\*\s*\)\s*)?]; # Optional (SV*) cast
  $size = qr[,\s* (??{ $bal }) ]x; # Third arg (to setpvn)

  foreach my $key (keys %output_expr) {
    BEGIN { $^H |= 0x00200000 }; # Equivalent to: use re 'eval', but hardcoded so we can compile re.xs

    my ($t, $with_size, $arg, $sarg) =
      ($output_expr{$key} =~
       m[^ \s+ sv_set ( [iunp] ) v (n)?	# Type, is_setpvn
	 \s* \( \s* $cast \$arg \s* ,
	 \s* ( (??{ $bal }) )	# Set from
	 ( (??{ $size }) )?	# Possible sizeof set-from
	 \) \s* ; \s* $
	]x);
    $targetable{$key} = [$t, $with_size, $arg, $sarg] if $t;
  }

  my $END = "!End!\n\n";		# "impossible" keyword (multiple newline)

  # Match an XS keyword
  $BLOCK_re= '\s*(' . join('|', qw(
				   REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT
				   CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE
				   SCOPE INTERFACE INTERFACE_MACRO C_ARGS POSTCALL OVERLOAD FALLBACK
				  )) . "|$END)\\s*:";

  
  our ($C_group_rex, $C_arg);
  # Group in C (no support for comments or literals)
  $C_group_rex = qr/ [({\[]
		       (?: (?> [^()\[\]{}]+ ) | (??{ $C_group_rex }) )*
		       [)}\]] /x ;
  # Chunk in C without comma at toplevel (no comments):
  $C_arg = qr/ (?: (?> [^()\[\]{},"']+ )
	     |   (??{ $C_group_rex })
	     |   " (?: (?> [^\\"]+ )
		   |   \\.
		   )* "		# String literal
			    |   ' (?: (?> [^\\']+ ) | \\. )* ' # Char literal
	     )* /xs;
  
  # Identify the version of xsubpp used
  print <<EOM ;
/*
 * This file was generated automatically by ExtUtils::ParseXS version $VERSION from the
 * contents of $filename. Do not edit this file, edit $filename instead.
 *
 *	ANY CHANGES MADE HERE WILL BE LOST! 
 *
 */

EOM


  print("#line 1 \"$filepathname\"\n")
    if $WantLineNumbers;

  firstmodule:
  while (<$FH>) {
    if (/^=/) {
      my $podstartline = $.;
      do {
	if (/^=cut\s*$/) {
	  # We can't just write out a /* */ comment, as our embedded
	  # POD might itself be in a comment. We can't put a /**/
	  # comment inside #if 0, as the C standard says that the source
	  # file is decomposed into preprocessing characters in the stage
	  # before preprocessing commands are executed.
	  # I don't want to leave the text as barewords, because the spec
	  # isn't clear whether macros are expanded before or after
	  # preprocessing commands are executed, and someone pathological
	  # may just have defined one of the 3 words as a macro that does
	  # something strange. Multiline strings are illegal in C, so
	  # the "" we write must be a string literal. And they aren't
	  # concatenated until 2 steps later, so we are safe.
	  #     - Nicholas Clark
	  print("#if 0\n  \"Skipped embedded POD.\"\n#endif\n");
	  printf("#line %d \"$filepathname\"\n", $. + 1)
	    if $WantLineNumbers;
	  next firstmodule
	}
	
      } while (<$FH>);
      # At this point $. is at end of file so die won't state the start
      # of the problem, and as we haven't yet read any lines &death won't
      # show the correct line in the message either.
      die ("Error: Unterminated pod in $filename, line $podstartline\n")
	unless $lastline;
    }
    last if ($Package, $Prefix) =
      /^MODULE\s*=\s*[\w:]+(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;
    
    print $_;
  }
  unless (defined $_) {
    warn "Didn't find a 'MODULE ... PACKAGE ... PREFIX' line\n";
    exit 0; # Not a fatal error for the caller process
  }

    print <<"EOF";
#ifndef PERL_UNUSED_VAR
#  define PERL_UNUSED_VAR(var) if (0) var = var
#endif

EOF

  print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;

  $lastline    = $_;
  $lastline_no = $.;

 PARAGRAPH:
  while (fetch_para()) {
    # Print initial preprocessor statements and blank lines
    while (@line && $line[0] !~ /^[^\#]/) {
      my $line = shift(@line);
      print $line, "\n";
      next unless $line =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/;
      my $statement = $+;
      if ($statement eq 'if') {
	$XSS_work_idx = @XSStack;
	push(@XSStack, {type => 'if'});
      } else {
	death ("Error: `$statement' with no matching `if'")
	  if $XSStack[-1]{type} ne 'if';
	if ($XSStack[-1]{varname}) {
	  push(@InitFileCode, "#endif\n");
	  push(@BootCode,     "#endif");
	}
	
	my(@fns) = keys %{$XSStack[-1]{functions}};
	if ($statement ne 'endif') {
	  # Hide the functions defined in other #if branches, and reset.
	  @{$XSStack[-1]{other_functions}}{@fns} = (1) x @fns;
	  @{$XSStack[-1]}{qw(varname functions)} = ('', {});
	} else {
	  my($tmp) = pop(@XSStack);
	  0 while (--$XSS_work_idx
		   && $XSStack[$XSS_work_idx]{type} ne 'if');
	  # Keep all new defined functions
	  push(@fns, keys %{$tmp->{other_functions}});
	  @{$XSStack[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
	}
      }
    }
    
    next PARAGRAPH unless @line;
    
    if ($XSS_work_idx && !$XSStack[$XSS_work_idx]{varname}) {
      # We are inside an #if, but have not yet #defined its xsubpp variable.
      print "#define $cpp_next_tmp 1\n\n";
      push(@InitFileCode, "#if $cpp_next_tmp\n");
      push(@BootCode,     "#if $cpp_next_tmp");
      $XSStack[$XSS_work_idx]{varname} = $cpp_next_tmp++;
    }

    death ("Code is not inside a function"
	   ." (maybe last function was ended by a blank line "
	   ." followed by a statement on column one?)")
      if $line[0] =~ /^\s/;
    
    my ($class, $externC, $static, $ellipsis, $wantRETVAL, $RETVAL_no_return);
    my (@fake_INPUT_pre);	# For length(s) generated variables
    my (@fake_INPUT);
    
    # initialize info arrays
    undef(%args_match);
    undef(%var_types);
    undef(%defaults);
    undef(%arg_list) ;
    undef(@proto_arg) ;
    undef($processing_arg_with_types) ;
    undef(%argtype_seen) ;
    undef(@outlist) ;
    undef(%in_out) ;
    undef(%lengthof) ;
    undef($proto_in_this_xsub) ;
    undef($scope_in_this_xsub) ;
    undef($interface);
    undef($prepush_done);
    $interface_macro = 'XSINTERFACE_FUNC' ;
    $interface_macro_set = 'XSINTERFACE_FUNC_SET' ;
    $ProtoThisXSUB = $WantPrototypes ;
    $ScopeThisXSUB = 0;
    $xsreturn = 0;

    $_ = shift(@line);
    while (my $kwd = check_keyword("REQUIRE|PROTOTYPES|FALLBACK|VERSIONCHECK|INCLUDE")) {
      &{"${kwd}_handler"}() ;
      next PARAGRAPH unless @line ;
      $_ = shift(@line);
    }

    if (check_keyword("BOOT")) {
      &check_cpp;
      push (@BootCode, "#line $line_no[@line_no - @line] \"$filepathname\"")
	if $WantLineNumbers && $line[0] !~ /^\s*#\s*line\b/;
      push (@BootCode, @line, "") ;
      next PARAGRAPH ;
    }


    # extract return type, function name and arguments
    ($ret_type) = TidyType($_);
    $RETVAL_no_return = 1 if $ret_type =~ s/^NO_OUTPUT\s+//;

    # Allow one-line ANSI-like declaration
    unshift @line, $2
      if $process_argtypes
	and $ret_type =~ s/^(.*?\w.*?)\s*\b(\w+\s*\(.*)/$1/s;

    # a function definition needs at least 2 lines
    blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH
      unless @line ;

    $externC = 1 if $ret_type =~ s/^extern "C"\s+//;
    $static  = 1 if $ret_type =~ s/^static\s+//;

    $func_header = shift(@line);
    blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
      unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\s*(;\s*)?$/s;

    ($class, $func_name, $orig_args) =  ($1, $2, $3) ;
    $class = "$4 $class" if $4;
    ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
    ($clean_func_name = $func_name) =~ s/^$Prefix//;
    $Full_func_name = "${Packid}_$clean_func_name";
    if ($Is_VMS) {
      $Full_func_name = $SymSet->addsym($Full_func_name);
    }

    # Check for duplicate function definition
    for my $tmp (@XSStack) {
      next unless defined $tmp->{functions}{$Full_func_name};
      Warn("Warning: duplicate function definition '$clean_func_name' detected");
      last;
    }
    $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ;
    %XsubAliases = %XsubAliasValues = %Interfaces = @Attributes = ();
    $DoSetMagic = 1;

    $orig_args =~ s/\\\s*/ /g;	# process line continuations
    my @args;

    my %only_C_inlist;		# Not in the signature of Perl function
    if ($process_argtypes and $orig_args =~ /\S/) {
      my $args = "$orig_args ,";
      if ($args =~ /^( (??{ $C_arg }) , )* $ /x) {
	@args = ($args =~ /\G ( (??{ $C_arg }) ) , /xg);
	for ( @args ) {
	  s/^\s+//;
	  s/\s+$//;
	  my ($arg, $default) = / ( [^=]* ) ( (?: = .* )? ) /x;
	  my ($pre, $name) = ($arg =~ /(.*?) \s*
					     \b ( \w+ | length\( \s*\w+\s* \) )
					     \s* $ /x);
	  next unless defined($pre) && length($pre);
	  my $out_type = '';
	  my $inout_var;
	  if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//) {
	    my $type = $1;
	    $out_type = $type if $type ne 'IN';
	    $arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//;
	    $pre =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//;
	  }
	  my $islength;
	  if ($name =~ /^length\( \s* (\w+) \s* \)\z/x) {
	    $name = "XSauto_length_of_$1";
	    $islength = 1;
	    die "Default value on length() argument: `$_'"
	      if length $default;
	  }
	  if (length $pre or $islength) { # Has a type
	    if ($islength) {
	      push @fake_INPUT_pre, $arg;
	    } else {
	      push @fake_INPUT, $arg;
	    }
	    # warn "pushing '$arg'\n";
	    $argtype_seen{$name}++;
	    $_ = "$name$default"; # Assigns to @args
	  }
	  $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST" or $islength;
	  push @outlist, $name if $out_type =~ /OUTLIST$/;
	  $in_out{$name} = $out_type if $out_type;
	}
      } else {
	@args = split(/\s*,\s*/, $orig_args);
	Warn("Warning: cannot parse argument list '$orig_args', fallback to split");
      }
    } else {
      @args = split(/\s*,\s*/, $orig_args);
      for (@args) {
	if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\s+//) {
	  my $out_type = $1;
	  next if $out_type eq 'IN';
	  $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST";
	  push @outlist, $name if $out_type =~ /OUTLIST$/;
	  $in_out{$_} = $out_type;
	}
      }
    }
    if (defined($class)) {
      my $arg0 = ((defined($static) or $func_name eq 'new')
		  ? "CLASS" : "THIS");
      unshift(@args, $arg0);