=head1 SYNOPSIS
-B<xsubpp> [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-typemap typemap>] [B<-object_capi>]... file.xs
+B<xsubpp> [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-typemap typemap>] ... file.xs
=head1 DESCRIPTION
Prevents the inclusion of `#line' directives in the output.
-=item B<-object_capi>
-
-Compile code as C in a PERL_OBJECT environment.
-
-back
+=back
=head1 ENVIRONMENT
$WantPrototypes = 1, next SWITCH if $flag eq 'prototypes';
$WantVersionChk = 0, next SWITCH if $flag eq 'noversioncheck';
$WantVersionChk = 1, next SWITCH if $flag eq 'versioncheck';
+ # XXX left this in for compat
$WantCAPI = 1, next SWITCH if $flag eq 'object_capi';
$except = " TRY", next SWITCH if $flag eq 'except';
push(@tm,shift), next SWITCH if $flag eq 'typemap';
$thisdone |= $var_name eq "THIS";
$retvaldone |= $var_name eq "RETVAL";
$var_types{$var_name} = $var_type;
- print "\t" . &map_type($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)
$func_args =~ s/\b($var_name)\b/&$1/;
}
if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\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);
+ &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);
+ &generate_init($var_type, $var_num, $var_name, $name_printed);
} else {
print ";\n";
}
if ($ALIAS)
{ print Q<<"EOF" if $cond }
# if ($cond)
-# croak("Usage: %s($orig_args)", GvNAME(CvGV(cv)));
+# Perl_croak(aTHX_ "Usage: %s($orig_args)", GvNAME(CvGV(cv)));
EOF
else
{ print Q<<"EOF" if $cond }
# if ($cond)
-# croak("Usage: $pname($orig_args)");
+# Perl_croak(aTHX_ "Usage: $pname($orig_args)");
EOF
print Q<<"EOF" if $PPCODE;
# do code
if (/^\s*NOT_IMPLEMENTED_YET/) {
- print "\n\tcroak(\"$pname: not implemented yet\");\n";
+ print "\n\tPerl_croak(aTHX_ \"$pname: not implemented yet\");\n";
$_ = '' ;
} else {
if ($ret_type ne "void") {
- print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
+ print "\t" . &map_type($ret_type, 'RETVAL') . ";\n"
if !$retvaldone;
$args_match{"RETVAL"} = 0;
$var_types{"RETVAL"} = $ret_type;
print Q<<EOF if $except;
# if (errbuf[0])
-# croak(errbuf);
+# Perl_croak(aTHX_ errbuf);
EOF
if ($ret_type ne "void" or $EXPLICIT_RETURN) {
##endif
EOF
-if ($WantCAPI) {
-print Q<<"EOF";
-##ifdef PERL_CAPI
-#XS(boot__CAPI_entry)
-##else
-EOF
-}
-
print Q<<"EOF";
#XS(boot_$Module_cname)
EOF
-if ($WantCAPI) {
-print Q<<"EOF";
-##endif /* PERL_CAPI */
-EOF
-}
-
print Q<<"EOF";
#[[
# dXSARGS;
#
EOF
-if ($WantCAPI) {
-print Q<<"EOF";
-##ifdef PERL_CAPI
-##define XSCAPI(name) void name(CV* cv, void* pPerl)
-#
-##ifdef __cplusplus
-#extern "C"
-##endif
-#XSCAPI(boot_$Module_cname)
-#[[
-# SetCPerlObj(pPerl);
-# boot__CAPI_entry(cv);
-#]]
-##endif /* PERL_CAPI */
-EOF
-}
-
warn("Please specify prototyping behavior for $filename (see perlxs manual)\n")
unless $ProtoUsed ;
&Exit;
sub output_init {
- local($type, $num, $var, $init) = @_;
+ local($type, $num, $var, $init, $name_printed) = @_;
local($arg) = "ST(" . ($num - 1) . ")";
if( $init =~ /^=/ ) {
- eval qq/print "\\t$var $init\\n"/;
+ 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);
+ &generate_init($type, $num, $var, $name_printed);
+ } elsif ($name_printed) {
+ print ";\n";
+ $init =~ s/^;//;
} else {
eval qq/print "\\t$var;\\n"/;
warn $@ if $@;
if (defined($defaults{$var})) {
$expr =~ s/(\t+)/$1 /g;
$expr =~ s/ /\t/g;
- eval qq/print "\\t$var;\\n"/;
- warn $@ if $@;
+ if ($name_printed) {
+ print ";\n";
+ } else {
+ eval qq/print "\\t$var;\\n"/;
+ warn $@ if $@;
+ }
$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 !~ /^\t\$var =/) {
- eval qq/print "\\t$var;\\n"/;
- warn $@ if $@;
+ 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 $@;
}
$type = TidyType($type) ;
if ($type =~ /^array\(([^,]*),(.*)\)/) {
- print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\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
}
sub map_type {
- my($type) = @_;
+ my($type, $varname) = @_;
$type =~ tr/:/_/;
$type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
+ if ($varname) {
+ if ($varname && $type =~ / \( \s* \* (?= \s* \) ) /xg) {
+ (substr $type, pos $type, 0) = " $varname ";
+ } else {
+ $type .= "\t$varname";
+ }
+ }
$type;
}