parsexs.pm

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

    unshift @tm, $file if -e $file;
  }
  return @tm;
}
  
sub TrimWhitespace
{
  $_[0] =~ s/^\s+|\s+$//go ;
}

sub TidyType
  {
    local ($_) = @_ ;

    # rationalise any '*' by joining them into bunches and removing whitespace
    s#\s*(\*+)\s*#$1#g;
    s#(\*+)# $1 #g ;

    # change multiple whitespace into a single space
    s/\s+/ /g ;

    # trim leading & trailing whitespace
    TrimWhitespace($_) ;

    $_ ;
}

# Input:  ($_, @line) == unparsed input.
# Output: ($_, @line) == (rest of line, following lines).
# Return: the matched keyword if found, otherwise 0
sub check_keyword {
	$_ = shift(@line) while !/\S/ && @line;
	s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
}

sub print_section {
    # the "do" is required for right semantics
    do { $_ = shift(@line) } while !/\S/ && @line;

    print("#line ", $line_no[@line_no - @line -1], " \"$filepathname\"\n")
	if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/;
    for (;  defined($_) && !/^$BLOCK_re/o;  $_ = shift(@line)) {
	print "$_\n";
    }
    print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
}

sub merge_section {
    my $in = '';

    while (!/\S/ && @line) {
      $_ = shift(@line);
    }

    for (;  defined($_) && !/^$BLOCK_re/o;  $_ = shift(@line)) {
      $in .= "$_\n";
    }
    chomp $in;
    return $in;
  }

sub process_keyword($)
  {
    my($pattern) = @_ ;
    my $kwd ;

    &{"${kwd}_handler"}()
      while $kwd = check_keyword($pattern) ;
  }

sub CASE_handler {
  blurt ("Error: `CASE:' after unconditional `CASE:'")
    if $condnum && $cond eq '';
  $cond = $_;
  TrimWhitespace($cond);
  print "   ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n");
  $_ = '' ;
}

sub INPUT_handler {
  for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
    last if /^\s*NOT_IMPLEMENTED_YET/;
    next unless /\S/;		# skip blank lines

    TrimWhitespace($_) ;
    my $line = $_ ;

    # remove trailing semicolon if no initialisation
    s/\s*;$//g unless /[=;+].*\S/ ;

    # Process the length(foo) declarations
    if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) {
      print "\tSTRLEN\tSTRLEN_length_of_$2;\n";
      $lengthof{$2} = $name;
      # $islengthof{$name} = $1;
      $deferred .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;";
    }

    # check for optional initialisation code
    my $var_init = '' ;
    $var_init = $1 if s/\s*([=;+].*)$//s ;
    $var_init =~ s/"/\\"/g;

    s/\s+/ /g;
    my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s
      or blurt("Error: invalid argument declaration '$line'"), next;

    # Check for duplicate definitions
    blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
      if $arg_list{$var_name}++
	or defined $argtype_seen{$var_name} and not $processing_arg_with_types;

    $thisdone |= $var_name eq "THIS";
    $retvaldone |= $var_name eq "RETVAL";
    $var_types{$var_name} = $var_type;
    # XXXX This check is a safeguard against the unfinished conversion of
    # generate_init().  When generate_init() is fixed,
    # one can use 2-args map_type() unconditionally.
    if ($var_type =~ / \( \s* \* \s* \) /x) {
      # Function pointers are not yet supported with &output_init!
      print "\t" . &map_type($var_type, $var_name);
      $name_printed = 1;
    } else {
      print "\t" . &map_type($var_type);
      $name_printed = 0;
    }
    $var_num = $args_match{$var_name};

    $proto_arg[$var_num] = ProtoString($var_type)
      if $var_num ;
    $func_args =~ s/\b($var_name)\b/&$1/ if $var_addr;
    if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/
	or $in_out{$var_name} and $in_out{$var_name} =~ /^OUT/
	and $var_init !~ /\S/) {
      if ($name_printed) {
	print ";\n";
      } else {
	print "\t$var_name;\n";
      }
    } elsif ($var_init =~ /\S/) {
      &output_init($var_type, $var_num, $var_name, $var_init, $name_printed);
    } elsif ($var_num) {
      # generate initialization code
      &generate_init($var_type, $var_num, $var_name, $name_printed);
    } else {
      print ";\n";
    }
  }
}

sub OUTPUT_handler {
  for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
    next unless /\S/;
    if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) {
      $DoSetMagic = ($1 eq "ENABLE" ? 1 : 0);
      next;
    }
    my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ;
    blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
      if $outargs{$outarg} ++ ;
    if (!$gotRETVAL and $outarg eq 'RETVAL') {
      # deal with RETVAL last
      $RETVAL_code = $outcode ;
      $gotRETVAL = 1 ;
      next ;
    }
    blurt ("Error: OUTPUT $outarg not an argument"), next
      unless defined($args_match{$outarg});
    blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
      unless defined $var_types{$outarg} ;
    $var_num = $args_match{$outarg};
    if ($outcode) {
      print "\t$outcode\n";
      print "\tSvSETMAGIC(ST(" , $var_num-1 , "));\n" if $DoSetMagic;
    } else {
      &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic);
    }
    delete $in_out{$outarg} 	# No need to auto-OUTPUT
      if exists $in_out{$outarg} and $in_out{$outarg} =~ /OUT$/;
  }
}

sub C_ARGS_handler() {
  my $in = merge_section();

  TrimWhitespace($in);
  $func_args = $in;
}

sub INTERFACE_MACRO_handler() {
  my $in = merge_section();

  TrimWhitespace($in);
  if ($in =~ /\s/) {		# two
    ($interface_macro, $interface_macro_set) = split ' ', $in;
  } else {
    $interface_macro = $in;
    $interface_macro_set = 'UNKNOWN_CVT'; # catch later
  }
  $interface = 1;		# local
  $Interfaces = 1;		# global
}

sub INTERFACE_handler() {
  my $in = merge_section();

  TrimWhitespace($in);

  foreach (split /[\s,]+/, $in) {
    my $name = $_;
    $name =~ s/^$Prefix//;
    $Interfaces{$name} = $_;
  }
  print Q(<<"EOF");
#	XSFUNCTION = $interface_macro($ret_type,cv,XSANY.any_dptr);
EOF
  $interface = 1;		# local
  $Interfaces = 1;		# global
}

sub CLEANUP_handler() { print_section() }
sub PREINIT_handler() { print_section() }
sub POSTCALL_handler() { print_section() }
sub INIT_handler()    { print_section() }

sub GetAliases
  {
    my ($line) = @_ ;
    my ($orig) = $line ;
    my ($alias) ;
    my ($value) ;

    # Parse alias definitions
    # format is
    #    alias = value alias = value ...

    while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
      $alias = $1 ;
      $orig_alias = $alias ;
      $value = $2 ;

      # check for optional package definition in the alias
      $alias = $Packprefix . $alias if $alias !~ /::/ ;

      # check for duplicate alias name & duplicate value
      Warn("Warning: Ignoring duplicate alias '$orig_alias'")
	if defined $XsubAliases{$alias} ;

      Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values")
	if $XsubAliasValues{$value} ;

      $XsubAliases = 1;
      $XsubAliases{$alias} = $value ;
      $XsubAliasValues{$value} = $orig_alias ;
    }

    blurt("Error: Cannot parse ALIAS definitions from '$orig'")
      if $line ;
  }

sub ATTRS_handler ()
  {
    for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
      next unless /\S/;
      TrimWhitespace($_) ;
      push @Attributes, $_;
    }
  }

sub ALIAS_handler ()
  {
    for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
      next unless /\S/;
      TrimWhitespace($_) ;
      GetAliases($_) if $_ ;
    }
  }

sub OVERLOAD_handler()
{
  for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
    next unless /\S/;
    TrimWhitespace($_) ;
    while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) {
      $Overload = 1 unless $Overload;
      my $overload = "$Package\::(".$1 ;
      push(@InitFileCode,
	   "        newXS(\"$overload\", XS_$Full_func_name, file$proto);\n");
    }
  }  
}

sub FALLBACK_handler()
{
  # the rest of the current line should contain either TRUE, 
  # FALSE or UNDEF
  
  TrimWhitespace($_) ;
  my %map = (
	     TRUE => "PL_sv_yes", 1 => "PL_sv_yes",
	     FALSE => "PL_sv_no", 0 => "PL_sv_no",
	     UNDEF => "PL_sv_undef",
	    ) ;
  
  # check for valid FALLBACK value
  death ("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{uc $_} ;
  
  $Fallback = $map{uc $_} ;
}


sub REQUIRE_handler ()
  {
    # the rest of the current line should contain a version number
    my ($Ver) = $_ ;

    TrimWhitespace($Ver) ;

    death ("Error: REQUIRE expects a version number")
      unless $Ver ;

    # check that the version number is of the form n.n
    death ("Error: REQUIRE: expected a number, got '$Ver'")
      unless $Ver =~ /^\d+(\.\d*)?/ ;

    death ("Error: xsubpp $Ver (or better) required--this is only $VERSION.")
      unless $VERSION >= $Ver ;
  }

sub VERSIONCHECK_handler ()
  {
    # the rest of the current line should contain either ENABLE or
    # DISABLE

    TrimWhitespace($_) ;

    # check for ENABLE/DISABLE
    death ("Error: VERSIONCHECK: ENABLE/DISABLE")
      unless /^(ENABLE|DISABLE)/i ;

    $WantVersionChk = 1 if $1 eq 'ENABLE' ;
    $WantVersionChk = 0 if $1 eq 'DISABLE' ;

  }

sub PROTOTYPE_handler ()
  {
    my $specified ;

    death("Error: Only 1 PROTOTYPE definition allowed per xsub")
      if $proto_in_this_xsub ++ ;

    for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
      next unless /\S/;
      $specified = 1 ;
      TrimWhitespace($_) ;
      if ($_ eq 'DISABLE') {
	$ProtoThisXSUB = 0
      } elsif ($_ eq 'ENABLE') {
	$ProtoThisXSUB = 1
      } else {
	# remove any whitespace
	s/\s+//g ;
	death("Error: Invalid prototype '$_'")
	  unless ValidProtoString($_) ;
	$ProtoThisXSUB = C_string($_) ;
      }
    }

    # If no prototype specified, then assume empty prototype ""
    $ProtoThisXSUB = 2 unless $specified ;

    $ProtoUsed = 1 ;

  }

sub SCOPE_handler ()
  {
    death("Error: Only 1 SCOPE declaration allowed per xsub")
      if $scope_in_this_xsub ++ ;

    for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
      next unless /\S/;
      TrimWhitespace($_) ;
      if ($_ =~ /^DISABLE/i) {
	$ScopeThisXSUB = 0
      } elsif ($_ =~ /^ENABLE/i) {
	$ScopeThisXSUB = 1
      }
    }

  }

sub PROTOTYPES_handler ()
  {
    # the rest of the current line should contain either ENABLE or
    # DISABLE

    TrimWhitespace($_) ;

    # check for ENABLE/DISABLE
    death ("Error: PROTOTYPES: ENABLE/DISABLE")
      unless /^(ENABLE|DISABLE)/i ;

    $WantPrototypes = 1 if $1 eq 'ENABLE' ;
    $WantPrototypes = 0 if $1 eq 'DISABLE' ;
    $ProtoUsed = 1 ;

  }

sub INCLUDE_handler ()
  {
    # the rest of the current line should contain a valid filename

    TrimWhitespace($_) ;

    death("INCLUDE: filename missing")
      unless $_ ;

    death("INCLUDE: output pipe is illegal")
      if /^\s*\|/ ;

    # simple minded recursion detector
    death("INCLUDE loop detected")
      if $IncludedFiles{$_} ;

    ++ $IncludedFiles{$_} unless /\|\s*$/ ;

    # Save the current file context.
    push(@XSStack, {
		    type		=> 'file',
		    LastLine        => $lastline,
		    LastLineNo      => $lastline_no,
		    Line            => \@line,
		    LineNo          => \@line_no,
		    Filename        => $filename,
		    Filepathname    => $filepathname,
		    Handle          => $FH,
		   }) ;

    $FH = Symbol::gensym();

    # open the new file
    open ($FH, "$_") or death("Cannot open '$_': $!") ;

    print Q(<<"EOF");
#
#/* INCLUDE:  Including '$_' from '$filename' */
#
EOF

    $filepathname = $filename = $_ ;

    # Prime the pump by reading the first
    # non-blank line

    # skip leading blank lines
    while (<$FH>) {
      last unless /^\s*$/ ;
    }

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

  }

sub PopFile()
  {
    return 0 unless $XSStack[-1]{type} eq 'file' ;

    my $data     = pop @XSStack ;
    my $ThisFile = $filename ;
    my $isPipe   = ($filename =~ /\|\s*$/) ;

    -- $IncludedFiles{$filename}
      unless $isPipe ;

    close $FH ;

    $FH         = $data->{Handle} ;
    # $filename is the leafname, which for some reason isused for diagnostic
    # messages, whereas $filepathname is the full pathname, and is used for
    # #line directives.
    $filename   = $data->{Filename} ;
    $filepathname = $data->{Filepathname} ;
    $lastline   = $data->{LastLine} ;
    $lastline_no = $data->{LastLineNo} ;
    @line       = @{ $data->{Line} } ;
    @line_no    = @{ $data->{LineNo} } ;

    if ($isPipe and $? ) {
      -- $lastline_no ;
      print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n"  ;
      exit 1 ;
    }

    print Q(<<"EOF");
#
#/* INCLUDE: Returning to '$filename' from '$ThisFile' */
#
EOF

    return 1 ;
  }

sub ValidProtoString ($)
  {
    my($string) = @_ ;

    if ( $string =~ /^$proto_re+$/ ) {
      return $string ;
    }

    return 0 ;