parsexs.pm

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

  }

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

    $string =~ s[\\][\\\\]g ;
    $string ;
  }

sub ProtoString ($)
  {
    my ($type) = @_ ;

    $proto_letter{$type} or "\$" ;
  }

sub check_cpp {
  my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line);
  if (@cpp) {
    my ($cpp, $cpplevel);
    for $cpp (@cpp) {
      if ($cpp =~ /^\#\s*if/) {
	$cpplevel++;
      } elsif (!$cpplevel) {
	Warn("Warning: #else/elif/endif without #if in this function");
	print STDERR "    (precede it with a blank line if the matching #if is outside the function)\n"
	  if $XSStack[-1]{type} eq 'if';
	return;
      } elsif ($cpp =~ /^\#\s*endif/) {
	$cpplevel--;
      }
    }
    Warn("Warning: #if without #endif in this function") if $cpplevel;
  }
}


sub Q {
  my($text) = @_;
  $text =~ s/^#//gm;
  $text =~ s/\[\[/{/g;
  $text =~ s/\]\]/}/g;
  $text;
}

# Read next xsub into @line from ($lastline, <$FH>).
sub fetch_para {
  # parse paragraph
  death ("Error: Unterminated `#if/#ifdef/#ifndef'")
    if !defined $lastline && $XSStack[-1]{type} eq 'if';
  @line = ();
  @line_no = () ;
  return PopFile() if !defined $lastline;

  if ($lastline =~
      /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
    $Module = $1;
    $Package = defined($2) ? $2 : ''; # keep -w happy
    $Prefix  = defined($3) ? $3 : ''; # keep -w happy
    $Prefix = quotemeta $Prefix ;
    ($Module_cname = $Module) =~ s/\W/_/g;
    ($Packid = $Package) =~ tr/:/_/;
    $Packprefix = $Package;
    $Packprefix .= "::" if $Packprefix ne "";
    $lastline = "";
  }

  for (;;) {
    # Skip embedded PODs
    while ($lastline =~ /^=/) {
      while ($lastline = <$FH>) {
	last if ($lastline =~ /^=cut\s*$/);
      }
      death ("Error: Unterminated pod") unless $lastline;
      $lastline = <$FH>;
      chomp $lastline;
      $lastline =~ s/^\s+$//;
    }
    if ($lastline !~ /^\s*#/ ||
	# CPP directives:
	#	ANSI:	if ifdef ifndef elif else endif define undef
	#		line error pragma
	#	gcc:	warning include_next
	#   obj-c:	import
	#   others:	ident (gcc notes that some cpps have this one)
	$lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) {
      last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
      push(@line, $lastline);
      push(@line_no, $lastline_no) ;
    }

    # Read next line and continuation lines
    last unless defined($lastline = <$FH>);
    $lastline_no = $.;
    my $tmp_line;
    $lastline .= $tmp_line
      while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>));

    chomp $lastline;
    $lastline =~ s/^\s+$//;
  }
  pop(@line), pop(@line_no) while @line && $line[-1] eq "";
  1;
}

sub output_init {
  local($type, $num, $var, $init, $name_printed) = @_;
  local($arg) = "ST(" . ($num - 1) . ")";

  if (  $init =~ /^=/  ) {
    if ($name_printed) {
      eval qq/print " $init\\n"/;
    } else {
      eval qq/print "\\t$var $init\\n"/;
    }
    warn $@   if  $@;
  } else {
    if (  $init =~ s/^\+//  &&  $num  ) {
      &generate_init($type, $num, $var, $name_printed);
    } elsif ($name_printed) {
      print ";\n";
      $init =~ s/^;//;
    } else {
      eval qq/print "\\t$var;\\n"/;
      warn $@   if  $@;
      $init =~ s/^;//;
    }
    $deferred .= eval qq/"\\n\\t$init\\n"/;
    warn $@   if  $@;
  }
}

sub Warn
  {
    # work out the line number
    my $line_no = $line_no[@line_no - @line -1] ;

    print STDERR "@_ in $filename, line $line_no\n" ;
  }

sub blurt
  {
    Warn @_ ;
    $errors ++
  }

sub death
  {
    Warn @_ ;
    exit 1 ;
  }

sub generate_init {
  local($type, $num, $var) = @_;
  local($arg) = "ST(" . ($num - 1) . ")";
  local($argoff) = $num - 1;
  local($ntype);
  local($tk);

  $type = TidyType($type) ;
  blurt("Error: '$type' not in typemap"), return
    unless defined($type_kind{$type});

  ($ntype = $type) =~ s/\s*\*/Ptr/g;
  ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
  $tk = $type_kind{$type};
  $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
  if ($tk eq 'T_PV' and exists $lengthof{$var}) {
    print "\t$var" unless $name_printed;
    print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n";
    die "default value not supported with length(NAME) supplied"
      if defined $defaults{$var};
    return;
  }
  $type =~ tr/:/_/ unless $hiertype;
  blurt("Error: No INPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
    unless defined $input_expr{$tk} ;
  $expr = $input_expr{$tk};
  if ($expr =~ /DO_ARRAY_ELEM/) {
    blurt("Error: '$subtype' not in typemap"), return
      unless defined($type_kind{$subtype});
    blurt("Error: No INPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
      unless defined $input_expr{$type_kind{$subtype}} ;
    $subexpr = $input_expr{$type_kind{$subtype}};
    $subexpr =~ s/\$type/\$subtype/g;
    $subexpr =~ s/ntype/subtype/g;
    $subexpr =~ s/\$arg/ST(ix_$var)/g;
    $subexpr =~ s/\n\t/\n\t\t/g;
    $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g;
    $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
    $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
  }
  if ($expr =~ m#/\*.*scope.*\*/#i) {  # "scope" in C comments
    $ScopeThisXSUB = 1;
  }
  if (defined($defaults{$var})) {
    $expr =~ s/(\t+)/$1    /g;
    $expr =~ s/        /\t/g;
    if ($name_printed) {
      print ";\n";
    } else {
      eval qq/print "\\t$var;\\n"/;
      warn $@   if  $@;
    }
    if ($defaults{$var} eq 'NO_INIT') {
      $deferred .= eval qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/;
    } else {
      $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t    $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
    }
    warn $@   if  $@;
  } elsif ($ScopeThisXSUB or $expr !~ /^\s*\$var =/) {
    if ($name_printed) {
      print ";\n";
    } else {
      eval qq/print "\\t$var;\\n"/;
      warn $@   if  $@;
    }
    $deferred .= eval qq/"\\n$expr;\\n"/;
    warn $@   if  $@;
  } else {
    die "panic: do not know how to handle this branch for function pointers"
      if $name_printed;
    eval qq/print "$expr;\\n"/;
    warn $@   if  $@;
  }
}

sub generate_output {
  local($type, $num, $var, $do_setmagic, $do_push) = @_;
  local($arg) = "ST(" . ($num - ($num != 0)) . ")";
  local($argoff) = $num - 1;
  local($ntype);

  $type = TidyType($type) ;
  if ($type =~ /^array\(([^,]*),(.*)\)/) {
    print "\t$arg = sv_newmortal();\n";
    print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n";
    print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
  } else {
    blurt("Error: '$type' not in typemap"), return
      unless defined($type_kind{$type});
    blurt("Error: No OUTPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
      unless defined $output_expr{$type_kind{$type}} ;
    ($ntype = $type) =~ s/\s*\*/Ptr/g;
    $ntype =~ s/\(\)//g;
    ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
    $expr = $output_expr{$type_kind{$type}};
    if ($expr =~ /DO_ARRAY_ELEM/) {
      blurt("Error: '$subtype' not in typemap"), return
	unless defined($type_kind{$subtype});
      blurt("Error: No OUTPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
	unless defined $output_expr{$type_kind{$subtype}} ;
      $subexpr = $output_expr{$type_kind{$subtype}};
      $subexpr =~ s/ntype/subtype/g;
      $subexpr =~ s/\$arg/ST(ix_$var)/g;
      $subexpr =~ s/\$var/${var}[ix_$var]/g;
      $subexpr =~ s/\n\t/\n\t\t/g;
      $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
      eval "print qq\a$expr\a";
      warn $@   if  $@;
      print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic;
    } elsif ($var eq 'RETVAL') {
      if ($expr =~ /^\t\$arg = new/) {
	# We expect that $arg has refcnt 1, so we need to
	# mortalize it.
	eval "print qq\a$expr\a";
	warn $@   if  $@;
	print "\tsv_2mortal(ST($num));\n";
	print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic;
      } elsif ($expr =~ /^\s*\$arg\s*=/) {
	# We expect that $arg has refcnt >=1, so we need
	# to mortalize it!
	eval "print qq\a$expr\a";
	warn $@   if  $@;
	print "\tsv_2mortal(ST(0));\n";
	print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
      } else {
	# Just hope that the entry would safely write it
	# over an already mortalized value. By
	# coincidence, something like $arg = &sv_undef
	# works too.
	print "\tST(0) = sv_newmortal();\n";
	eval "print qq\a$expr\a";
	warn $@   if  $@;
	# new mortals don't have set magic
      }
    } elsif ($do_push) {
      print "\tPUSHs(sv_newmortal());\n";
      $arg = "ST($num)";
      eval "print qq\a$expr\a";
      warn $@   if  $@;
      print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
    } elsif ($arg =~ /^ST\(\d+\)$/) {
      eval "print qq\a$expr\a";
      warn $@   if  $@;
      print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
    }
  }
}

sub map_type {
  my($type, $varname) = @_;
  
  # C++ has :: in types too so skip this
  $type =~ tr/:/_/ unless $hiertype;
  $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
  if ($varname) {
    if ($varname && $type =~ / \( \s* \* (?= \s* \) ) /xg) {
      (substr $type, pos $type, 0) = " $varname ";
    } else {
      $type .= "\t$varname";
    }
  }
  $type;
}


#########################################################
package
  ExtUtils::ParseXS::CountLines;
use strict;
use vars qw($SECTION_END_MARKER);

sub TIEHANDLE {
  my ($class, $cfile, $fh) = @_;
  $cfile =~ s/\\/\\\\/g;
  $SECTION_END_MARKER = qq{#line --- "$cfile"};
  
  return bless {buffer => '',
		fh => $fh,
		line_no => 1,
	       }, $class;
}

sub PRINT {
  my $self = shift;
  for (@_) {
    $self->{buffer} .= $_;
    while ($self->{buffer} =~ s/^([^\n]*\n)//) {
      my $line = $1;
      ++ $self->{line_no};
      $line =~ s|^\#line\s+---(?=\s)|#line $self->{line_no}|;
      print {$self->{fh}} $line;
    }
  }
}

sub PRINTF {
  my $self = shift;
  my $fmt = shift;
  $self->PRINT(sprintf($fmt, @_));
}

sub DESTROY {
  # Not necessary if we're careful to end with a "\n"
  my $self = shift;
  print {$self->{fh}} $self->{buffer};
}

sub UNTIE {
  # This sub does nothing, but is neccessary for references to be released.
}

sub end_marker {
  return $SECTION_END_MARKER;
}


1;
__END__

=head1 NAME

ExtUtils::ParseXS - converts Perl XS code into C code

=head1 SYNOPSIS

  use ExtUtils::ParseXS qw(process_file);
  
  process_file( filename => 'foo.xs' );

  process_file( filename => 'foo.xs',
                output => 'bar.c',
                'C++' => 1,
                typemap => 'path/to/typemap',
                hiertype => 1,
                except => 1,
                prototypes => 1,
                versioncheck => 1,
                linenumbers => 1,
                optimize => 1,
                prototypes => 1,
              );
=head1 DESCRIPTION

C<ExtUtils::ParseXS> will compile XS code into C code by embedding the constructs
necessary to let C functions manipulate Perl values and creates the glue
necessary to let Perl access those functions.  The compiler uses typemaps to
determine how to map C function parameters and variables to Perl values.

The compiler will search for typemap files called I<typemap>.  It will use
the following search path to find default typemaps, with the rightmost
typemap taking precedence.

	../../../typemap:../../typemap:../typemap:typemap

=head1 EXPORT

None by default.  C<process_file()> may be exported upon request.


=head1 FUNCTIONS

=over 4

=item process_xs()

This function processes an XS file and sends output to a C file.
Named parameters control how the processing is done.  The following
parameters are accepted:

=over 4

=item B<C++>

Adds C<extern "C"> to the C code.  Default is false.

=item B<hiertype>

Retains C<::> in type names so that C++ hierachical types can be
mapped.  Default is false.

=item B<except>

Adds exception handling stubs to the C code.  Default is false.

=item B<typemap>

Indicates that a user-supplied typemap should take precedence over the
default typemaps.  A single typemap may be specified as a string, or
multiple typemaps can be specified in an array reference, with the
last typemap having the highest precedence.

=item B<prototypes>

Generates prototype code for all xsubs.  Default is false.

=item B<versioncheck>

Makes sure at run time that the object file (derived from the C<.xs>
file) and the C<.pm> files have the same version number.  Default is
true.

=item B<linenumbers>

Adds C<#line> directives to the C output so error messages will look
like they came from the original XS file.  Default is true.

=item B<optimize>

Enables certain optimizations.  The only optimization that is currently
affected is the use of I<target>s by the output C code (see L<perlguts>).
Not optimizing may significantly slow down the generated code, but this is the way
B<xsubpp> of 5.005 and earlier operated.  Default is to optimize.

=item B<inout>

Enable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST>
declarations.  Default is true.

=item B<argtypes>

Enable recognition of ANSI-like descriptions of function signature.
Default is true.

=item B<s>

I have no clue what this does.  Strips function prefixes?

=back

=item errors()

This function returns the number of [a certain kind of] errors
encountered during processing of the XS file.

=back

=head1 AUTHOR

Based on xsubpp code, written by Larry Wall.

Maintained by Ken Williams, <[e-mail]>

=head1 COPYRIGHT

Copyright 2002-2003 Ken Williams.  All rights reserved.

This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

Based on the ExtUtils::xsubpp code by Larry Wall and the Perl 5
Porters, which was released under the same license terms.

=head1 SEE ALSO

L<perl>, ExtUtils::xsubpp, ExtUtils::MakeMaker, L<perlxs>, L<perlxstut>.

=cut