PPCODE results from the CPAN

PPCODE

Mac-Carbon

view release on metacpan or search on metacpan

	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 $key (keys %input_expr) {
    $input_expr{$key} =~ s/;*\s+\z//;
}

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

foreach $key (keys %output_expr) {
    use re 'eval';

    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;
}

$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
	)) . "|$END)\\s*:";

# 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;
}

my ($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;

if ($WantLineNumbers) {
    {
	package xsubpp::counter;
	sub TIEHANDLE {
	    my ($class, $cfile) = @_;
	    my $buf = "";
	    $SECTION_END_MARKER = "#line --- \"$cfile\"";
	    $line_no = 1;
	    bless \$buf;
	}

	sub PRINT {
	    my $self = shift;
	    for (@_) {
		$$self .= $_;
		while ($$self =~ s/^([^\n]*\n)//) {
		    my $line = $1;
		    ++ $line_no;
		    $line =~ s|^\#line\s+---(?=\s)|#line $line_no|;
		    print STDOUT $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 STDOUT $$self;

xsubpps/xsubpp-5.8.0 view on Meta::CPAN

	    @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);
	($report_args = "$arg0, $report_args") =~ s/^\w+, $/$arg0/;
    }
    my $extra_args = 0;
    @args_num = ();
    $num_args = 0;
    my $report_args = '';
    foreach $i (0 .. $#args) {
	    if ($args[$i] =~ s/\.\.\.//) {
		    $elipsis = 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;

    # print function header
    print Q<<"EOF";
#XS(XS_${Full_func_name}); /* prototype to pass -Wmissing-prototypes */
#XS(XS_${Full_func_name})
#[[
#    dXSARGS;
EOF
    print Q<<"EOF" if $ALIAS ;
#    dXSI32;
EOF
    print Q<<"EOF" if $INTERFACE ;
#    dXSFUNCTION($ret_type);
EOF
    if ($elipsis) {
	$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($report_args)", GvNAME(CvGV(cv)));
EOF
    else
      { print Q<<"EOF" if $cond }
#    if ($cond)
#	Perl_croak(aTHX_ "Usage: $pname($report_args)");
EOF

    #gcc -Wall: if an xsub has no arguments and PPCODE is used
    #it is likely 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 and $num_args == 0;
#   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() ;
		}
		XS_process($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/^($spat)//
			    if defined($spat);
			$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) {
	    XS_process("\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
	    $proto = ', ""' ;
	}
        elsif ($ProtoThisXSUB ne 1) {
            # User has specified a prototype
            $proto = ', "' . $ProtoThisXSUB . '"';
        }
        else {
	    my $s = ';';
            if ($min_args < $num_args)  {
                $s = '';
		$proto_arg[$min_args] .= ";" ;
	    }
            push @proto_arg, "$s\@"
                if $elipsis ;

            $proto = ', "' . join ("", @proto_arg) . '"';
        }
    }

    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");

( run in 1.107 second using v1.01-cache-2.11-cpan-5511b514fd6 )