parsexs.pm

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

      ($report_args = "$arg0, $report_args") =~ s/^\w+, $/$arg0/;
    }
    my $extra_args = 0;
    @args_num = ();
    $num_args = 0;
    my $report_args = '';
    foreach my $i (0 .. $#args) {
      if ($args[$i] =~ s/\.\.\.//) {
	$ellipsis = 1;
	if ($args[$i] eq '' && $i == $#args) {
	  $report_args .= ", ...";
	  pop(@args);
	  last;
	}
      }
      if ($only_C_inlist{$args[$i]}) {
	push @args_num, undef;
      } else {
	push @args_num, ++$num_args;
	$report_args .= ", $args[$i]";
      }
      if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) {
	$extra_args++;
	$args[$i] = $1;
	$defaults{$args[$i]} = $2;
	$defaults{$args[$i]} =~ s/"/\\"/g;
      }
      $proto_arg[$i+1] = '$' ;
    }
    $min_args = $num_args - $extra_args;
    $report_args =~ s/"/\\"/g;
    $report_args =~ s/^,\s+//;
    my @func_args = @args;
    shift @func_args if defined($class);

    for (@func_args) {
      s/^/&/ if $in_out{$_};
    }
    $func_args = join(", ", @func_args);
    @args_match{@args} = @args_num;

    $PPCODE = grep(/^\s*PPCODE\s*:/, @line);
    $CODE = grep(/^\s*CODE\s*:/, @line);
    # Detect CODE: blocks which use ST(n)= or XST_m*(n,v)
    #   to set explicit return values.
    $EXPLICIT_RETURN = ($CODE &&
			("@line" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x ));
    $ALIAS  = grep(/^\s*ALIAS\s*:/,  @line);
    $INTERFACE  = grep(/^\s*INTERFACE\s*:/,  @line);

    $xsreturn = 1 if $EXPLICIT_RETURN;

    $externC = $externC ? qq[extern "C"] : "";

    # print function header
    print Q(<<"EOF");
#$externC
#XS(XS_${Full_func_name}); /* prototype to pass -Wmissing-prototypes */
#XS(XS_${Full_func_name})
#[[
##ifdef dVAR
#    dVAR; dXSARGS;
##else
#    dXSARGS;
##endif
EOF
    print Q(<<"EOF") if $ALIAS ;
#    dXSI32;
EOF
    print Q(<<"EOF") if $INTERFACE ;
#    dXSFUNCTION($ret_type);
EOF
    if ($ellipsis) {
      $cond = ($min_args ? qq(items < $min_args) : 0);
    } elsif ($min_args == $num_args) {
      $cond = qq(items != $min_args);
    } else {
      $cond = qq(items < $min_args || items > $num_args);
    }

    print Q(<<"EOF") if $except;
#    char errbuf[1024];
#    *errbuf = '\0';
EOF

    if ($ALIAS)
      { print Q(<<"EOF") if $cond }
#    if ($cond)
#       Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "$report_args");
EOF
    else
      { print Q(<<"EOF") if $cond }
#    if ($cond)
#       Perl_croak(aTHX_ "Usage: %s(%s)", "$pname", "$report_args");
EOF
    
     # cv doesn't seem to be used, in most cases unless we go in 
     # the if of this else
     print Q(<<"EOF");
#    PERL_UNUSED_VAR(cv); /* -W */
EOF

    #gcc -Wall: if an xsub has PPCODE is used
    #it is possible none of ST, XSRETURN or XSprePUSH macros are used
    #hence `ax' (setup by dXSARGS) is unused
    #XXX: could breakup the dXSARGS; into dSP;dMARK;dITEMS
    #but such a move could break third-party extensions
    print Q(<<"EOF") if $PPCODE;
#    PERL_UNUSED_VAR(ax); /* -Wall */
EOF

    print Q(<<"EOF") if $PPCODE;
#    SP -= items;
EOF

    # Now do a block of some sort.

    $condnum = 0;
    $cond = '';			# last CASE: condidional
    push(@line, "$END:");
    push(@line_no, $line_no[-1]);
    $_ = '';
    &check_cpp;
    while (@line) {
      &CASE_handler if check_keyword("CASE");
      print Q(<<"EOF");
#   $except [[
EOF

      # do initialization of input variables
      $thisdone = 0;
      $retvaldone = 0;
      $deferred = "";
      %arg_list = () ;
      $gotRETVAL = 0;
	
      INPUT_handler() ;
      process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD") ;

      print Q(<<"EOF") if $ScopeThisXSUB;
#   ENTER;
#   [[
EOF
	
      if (!$thisdone && defined($class)) {
	if (defined($static) or $func_name eq 'new') {
	  print "\tchar *";
	  $var_types{"CLASS"} = "char *";
	  &generate_init("char *", 1, "CLASS");
	}
	else {
	  print "\t$class *";
	  $var_types{"THIS"} = "$class *";
	  &generate_init("$class *", 1, "THIS");
	}
      }
      
      # do code
      if (/^\s*NOT_IMPLEMENTED_YET/) {
	print "\n\tPerl_croak(aTHX_ \"$pname: not implemented yet\");\n";
	$_ = '' ;
      } else {
	if ($ret_type ne "void") {
	  print "\t" . &map_type($ret_type, 'RETVAL') . ";\n"
	    if !$retvaldone;
	  $args_match{"RETVAL"} = 0;
	  $var_types{"RETVAL"} = $ret_type;
	  print "\tdXSTARG;\n"
	    if $WantOptimize and $targetable{$type_kind{$ret_type}};
	}
	
	if (@fake_INPUT or @fake_INPUT_pre) {
	  unshift @line, @fake_INPUT_pre, @fake_INPUT, $_;
	  $_ = "";
	  $processing_arg_with_types = 1;
	  INPUT_handler() ;
	}
	print $deferred;
	
        process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD") ;
	
	if (check_keyword("PPCODE")) {
	  print_section();
	  death ("PPCODE must be last thing") if @line;
	  print "\tLEAVE;\n" if $ScopeThisXSUB;
	  print "\tPUTBACK;\n\treturn;\n";
	} elsif (check_keyword("CODE")) {
	  print_section() ;
	} elsif (defined($class) and $func_name eq "DESTROY") {
	  print "\n\t";
	  print "delete THIS;\n";
	} else {
	  print "\n\t";
	  if ($ret_type ne "void") {
	    print "RETVAL = ";
	    $wantRETVAL = 1;
	  }
	  if (defined($static)) {
	    if ($func_name eq 'new') {
	      $func_name = "$class";
	    } else {
	      print "${class}::";
	    }
	  } elsif (defined($class)) {
	    if ($func_name eq 'new') {
	      $func_name .= " $class";
	    } else {
	      print "THIS->";
	    }
	  }
	  $func_name =~ s/^\Q$args{'s'}//
	    if exists $args{'s'};
	  $func_name = 'XSFUNCTION' if $interface;
	  print "$func_name($func_args);\n";
	}
      }
      
      # do output variables
      $gotRETVAL = 0;		# 1 if RETVAL seen in OUTPUT section;
      undef $RETVAL_code ;	# code to set RETVAL (from OUTPUT section);
      # $wantRETVAL set if 'RETVAL =' autogenerated
      ($wantRETVAL, $ret_type) = (0, 'void') if $RETVAL_no_return;
      undef %outargs ;
      process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
      
      &generate_output($var_types{$_}, $args_match{$_}, $_, $DoSetMagic)
	for grep $in_out{$_} =~ /OUT$/, keys %in_out;
      
      # all OUTPUT done, so now push the return value on the stack
      if ($gotRETVAL && $RETVAL_code) {
	print "\t$RETVAL_code\n";
      } elsif ($gotRETVAL || $wantRETVAL) {
	my $t = $WantOptimize && $targetable{$type_kind{$ret_type}};
	my $var = 'RETVAL';
	my $type = $ret_type;
	
	# 0: type, 1: with_size, 2: how, 3: how_size
	if ($t and not $t->[1] and $t->[0] eq 'p') {
	  # PUSHp corresponds to setpvn.  Treate setpv directly
	  my $what = eval qq("$t->[2]");
	  warn $@ if $@;
	  
	  print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n";
	  $prepush_done = 1;
	}
	elsif ($t) {
	  my $what = eval qq("$t->[2]");
	  warn $@ if $@;
	  
	  my $size = $t->[3];
	  $size = '' unless defined $size;
	  $size = eval qq("$size");
	  warn $@ if $@;
	  print "\tXSprePUSH; PUSH$t->[0]($what$size);\n";
	  $prepush_done = 1;
	}
	else {
	  # RETVAL almost never needs SvSETMAGIC()
	  &generate_output($ret_type, 0, 'RETVAL', 0);
	}
      }
      
      $xsreturn = 1 if $ret_type ne "void";
      my $num = $xsreturn;
      my $c = @outlist;
      print "\tXSprePUSH;" if $c and not $prepush_done;
      print "\tEXTEND(SP,$c);\n" if $c;
      $xsreturn += $c;
      generate_output($var_types{$_}, $num++, $_, 0, 1) for @outlist;
      
      # do cleanup
      process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD") ;
      
      print Q(<<"EOF") if $ScopeThisXSUB;
#   ]]
EOF
      print Q(<<"EOF") if $ScopeThisXSUB and not $PPCODE;
#   LEAVE;
EOF
      
      # print function trailer
      print Q(<<"EOF");
#    ]]
EOF
      print Q(<<"EOF") if $except;
#    BEGHANDLERS
#    CATCHALL
#	sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
#    ENDHANDLERS
EOF
      if (check_keyword("CASE")) {
	blurt ("Error: No `CASE:' at top of function")
	  unless $condnum;
	$_ = "CASE: $_";	# Restore CASE: label
	next;
      }
      last if $_ eq "$END:";
      death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function");
    }
    
    print Q(<<"EOF") if $except;
#    if (errbuf[0])
#	Perl_croak(aTHX_ errbuf);
EOF
    
    if ($xsreturn) {
      print Q(<<"EOF") unless $PPCODE;
#    XSRETURN($xsreturn);
EOF
    } else {
      print Q(<<"EOF") unless $PPCODE;
#    XSRETURN_EMPTY;
EOF
    }

    print Q(<<"EOF");
#]]
#
EOF

    my $newXS = "newXS" ;
    my $proto = "" ;
    
    # Build the prototype string for the xsub
    if ($ProtoThisXSUB) {
      $newXS = "newXSproto";
      
      if ($ProtoThisXSUB eq 2) {
	# User has specified empty prototype
      }
      elsif ($ProtoThisXSUB eq 1) {
	my $s = ';';
	if ($min_args < $num_args)  {
	  $s = '';
	  $proto_arg[$min_args] .= ";" ;
	}
	push @proto_arg, "$s\@"
	  if $ellipsis ;
	
	$proto = join ("", grep defined, @proto_arg);
      }
      else {
	# User has specified a prototype
	$proto = $ProtoThisXSUB;
      }
      $proto = qq{, "$proto"};
    }
    
    if (%XsubAliases) {
      $XsubAliases{$pname} = 0
	unless defined $XsubAliases{$pname} ;
      while ( ($name, $value) = each %XsubAliases) {
	push(@InitFileCode, Q(<<"EOF"));
#        cv = newXS(\"$name\", XS_$Full_func_name, file);
#        XSANY.any_i32 = $value ;
EOF
	push(@InitFileCode, Q(<<"EOF")) if $proto;
#        sv_setpv((SV*)cv$proto) ;
EOF
      }
    }
    elsif (@Attributes) {
      push(@InitFileCode, Q(<<"EOF"));
#        cv = newXS(\"$pname\", XS_$Full_func_name, file);
#        apply_attrs_string("$Package", cv, "@Attributes", 0);
EOF
    }
    elsif ($interface) {
      while ( ($name, $value) = each %Interfaces) {
	$name = "$Package\::$name" unless $name =~ /::/;
	push(@InitFileCode, Q(<<"EOF"));
#        cv = newXS(\"$name\", XS_$Full_func_name, file);
#        $interface_macro_set(cv,$value) ;
EOF
	push(@InitFileCode, Q(<<"EOF")) if $proto;
#        sv_setpv((SV*)cv$proto) ;
EOF
      }
    }
    else {
      push(@InitFileCode,
	   "        ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n");
    }
  }

  if ($Overload) # make it findable with fetchmethod
  {
    print Q(<<"EOF");
#XS(XS_${Packid}_nil); /* prototype to pass -Wmissing-prototypes */
#XS(XS_${Packid}_nil)
#{
#   XSRETURN_EMPTY;
#}
#
EOF
    unshift(@InitFileCode, <<"MAKE_FETCHMETHOD_WORK");
    /* Making a sub named "${Package}::()" allows the package */
    /* to be findable via fetchmethod(), and causes */
    /* overload::Overloaded("${Package}") to return true. */
    newXS("${Package}::()", XS_${Packid}_nil, file$proto);
MAKE_FETCHMETHOD_WORK
  }

  # print initialization routine

  print Q(<<"EOF");
##ifdef __cplusplus
#extern "C"
##endif
EOF

  print Q(<<"EOF");
#XS(boot_$Module_cname); /* prototype to pass -Wmissing-prototypes */
#XS(boot_$Module_cname)
EOF

  print Q(<<"EOF");
#[[
##ifdef dVAR
#    dVAR; dXSARGS;
##else
#    dXSARGS;
##endif
EOF

  #-Wall: if there is no $Full_func_name there are no xsubs in this .xs
  #so `file' is unused
  print Q(<<"EOF") if $Full_func_name;
#    char* file = __FILE__;
EOF

  print Q("#\n");

  print Q(<<"EOF");
#    PERL_UNUSED_VAR(cv); /* -W */
#    PERL_UNUSED_VAR(items); /* -W */
EOF
    
  print Q(<<"EOF") if $WantVersionChk ;
#    XS_VERSION_BOOTCHECK ;
#
EOF

  print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces ;
#    {
#        CV * cv ;
#
EOF

  print Q(<<"EOF") if ($Overload);
#    /* register the overloading (type 'A') magic */
#    PL_amagic_generation++;
#    /* The magic for overload gets a GV* via gv_fetchmeth as */
#    /* mentioned above, and looks in the SV* slot of it for */
#    /* the "fallback" status. */
#    sv_setsv(
#        get_sv( "${Package}::()", TRUE ),
#        $Fallback
#    );
EOF

  print @InitFileCode;

  print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces ;
#    }
EOF

  if (@BootCode)
  {
    print "\n    /* Initialisation Section */\n\n" ;
    @line = @BootCode;
    print_section();
    print "\n    /* End of Initialisation Section */\n\n" ;
  }

  if ($] >= 5.009) {
    print <<'EOF';
    if (PL_unitcheckav)
         call_list(PL_scopestack_ix, PL_unitcheckav);
EOF
  }

  print Q(<<"EOF");
#    XSRETURN_YES;
#]]
#
EOF

  warn("Please specify prototyping behavior for $filename (see perlxs manual)\n")
    unless $ProtoUsed ;

  chdir($orig_cwd);
  select($orig_fh);
  untie *PSEUDO_STDOUT if tied *PSEUDO_STDOUT;
  close $FH;

  return 1;
}

sub errors { $errors }

sub standard_typemap_locations {
  # Add all the default typemap locations to the search path
  my @tm = qw(typemap);
  
  my $updir = File::Spec->updir;
  foreach my $dir (File::Spec->catdir(($updir) x 1), File::Spec->catdir(($updir) x 2),
		   File::Spec->catdir(($updir) x 3), File::Spec->catdir(($updir) x 4)) {
    
    unshift @tm, File::Spec->catfile($dir, 'typemap');
    unshift @tm, File::Spec->catfile($dir, lib => ExtUtils => 'typemap');
  }
  foreach my $dir (@INC) {
    my $file = File::Spec->catfile($dir, ExtUtils => 'typemap');