-sub emit_func {
- my ($addcontext, $rettype,$func,@args) = @_;
- my @aargs = @args;
- my $a;
- for $a (@aargs) { $a =~ s/^.*\b(\w+)$/$1/ }
- my $ctxarg = '';
- if (not $addcontext) {
- $ctxarg = 'pTHXo';
- $ctxarg .= '_ ' if @args;
- }
- my $decl = '';
- if ($addcontext) {
- $decl .= " dTHXo;\n";
- }
- local $" = ', ';
- my $return = ($rettype =~ /^\s*(void|Free_t|Signal_t)\s*$/
- ? '' : 'return ');
- my $emitval = '';
- if (@args and $args[$#args] =~ /\.\.\./) {
- pop @aargs;
- my $retarg = '';
- my $ctxfunc = $func;
- $ctxfunc =~ s/_nocontext$//;
- return $emitval unless exists $vfuncs{$ctxfunc};
- if (length $return) {
- $decl .= " $rettype retval;\n";
- $retarg .= "retval = ";
- $return = "\n ${return}retval;\n";
- }
- $emitval .= <<EOT
-$rettype
-$func($ctxarg@args)
-{
-$decl va_list args;
- va_start(args, $aargs[$#aargs]);
- $retarg((CPerlObj*)pPerl)->$vfuncs{$ctxfunc}(@aargs, &args);
- va_end(args);$return
-}
-EOT
- }
- else {
- $emitval .= <<EOT
-$rettype
-$func($ctxarg@args)
-{
-$decl $return((CPerlObj*)pPerl)->$func(@aargs);
-}
-EOT
- }
- $emitval;
-}
-
-# XXXX temporary hack
-my $sym;
-for $sym (qw(
- perl_construct
- perl_destruct
- perl_free
- perl_run
- perl_parse
- ))
-{
- $skipapi_funcs{$sym}++;
-}
-
-walk_table {
- my $ret = "";
- if (@_ == 1) {
- my $arg = shift;
- $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
- }
- else {
- my ($flags,$retval,$func,@args) = @_;
- return $ret if exists $skipapi_funcs{$func};
- if ($flags =~ /A/ && $flags !~ /j/) { # in public API, needed for XSUBS
- $ret .= "\n";
- my $addctx = 1 if $flags =~ /n/;
- if ($flags =~ /p/) {
- $ret .= undefine("Perl_$func");
- $ret .= emit_func($addctx,$retval,"Perl_$func",@args);
- }
- else {
- $ret .= undefine($func);
- $ret .= emit_func($addctx,$retval,$func,@args);
- }
- }
- }
- $ret;
-} \*CAPI;
-
-# NOTE: not part of the API
-#for $sym (sort keys %ppsym) {
-# $sym =~ s/^Perl_//;
-# print CAPI "\n";
-# print CAPI undefine("Perl_$sym");
-# if ($sym =~ /^ck_/) {
-# print CAPI emit_func(0, 'OP *',"Perl_$sym",'OP *o');
-# }
-# else { # pp_foo
-# print CAPI emit_func(0, 'OP *',"Perl_$sym");
-# }
-#}
-
-print CAPI <<'EOT';
-
-#undef Perl_fprintf_nocontext
-int
-Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...)
-{
- dTHXo;
- va_list(arglist);
- va_start(arglist, format);
- return (*PL_StdIO->pVprintf)(PL_StdIO, stream, format, arglist);
-}
-
-END_EXTERN_C
-
-#endif /* PERL_OBJECT */
-#endif /* PERL_OBJECT || MULTIPLICITY */
-EOT
-
-close(CAPI);
-