File Coverage

blib/lib/ExtUtils/Constant/ProxySubs.pm

Criterion	Covered	Total	%
statement	184	193	95.3
branch	80	100	80.0
condition	19	26	73.0
subroutine	11	11	100.0
pod	0	5	0.0
total	294	335	87.7

package ExtUtils::Constant::ProxySubs;
use strict;
use vars qw($VERSION @ISA %type_to_struct %type_from_struct %type_to_sv
	    %type_to_C_value %type_is_a_problem %type_num_args
	    %type_temporary);
$VERSION = '0.24_01';
@ISA = 'ExtUtils::Constant::XS';

=head1 NAME

ExtUtils::Constant::ProxySubs - generate XS ProxySubs code

=head1 SYNOPSIS

    use ExtUtils::Constant qw (WriteConstants);
    WriteConstants(
        NAME         => 'Package',
        NAMES        => [qw(FOO BAR BAZ)],
        PROXYSUBS    => { autoload => 1 },
        DEFAULT_TYPE => 'IV',
    );
    # Generates easier wrapper code, unusable with 5.6

=head1 DESCRIPTION

With the PROXYSUBS option to WriteConstants, this module generates
better XS code, with 4 optional variants.

Each symbol is added as CONSTSUB at BOOT time, as via C
{value}>.  Undefined names I<(#undef NAME)> will be stored in a
special C namespace, because
accessing an undefined name should throw a different error "Your
vendor has not defined MyPackage macro NAME", and not "Undefined
subroutine &MyPackage::NAME".

There's no run-time lookup for matching names in the constant
function, but there's still AUTOLOAD needed to catch unknown names and
a short dispatch for matching types.

NOTICE:

ExtUtils::Constant::ProxySubs versions older than 0.23_04 creates
code usable only >= 5.14. There is no official CPAN version which
creates usable code yet. The CPAN maintainers think p5p should sort it
out, which they didn't for the last 7 years.

=head1 OPTIONS

PROXYSUBS can be used with an optional hashref of 4 exclusive options.

'autoload', 'croak_on_error' and 'croak_on_read' can not be used together.
'push' and 'croak_on_read' cannot be used together.

=over 4

=item autoload

This option generates an XS AUTOLOAD function which dispatches to the
XS C function. Only auto-generated C and XS code is needed, no manual
addition of C as generated by L.

B
With 5.6 the error message for undefined macros is not
"Your vendor has not defined MyPackage macro NAME", but
"Undefined subroutine &MyPackage::NAME"

=item push

This option keeps a list of all added constants.

E.g.
        NAME         => 'MyPackage',
        PROXYSUBS    => { push => 'CONSTNAMES' },
will create C<@MyPackage::CONSTNAMES>.

=item croak_on_error

Errors in run-time name lookup via XS constant is normally handled by
AUTOLOAD.  With croak_on_error the AUTOLOAD function can be
simplified, errors with missing undefined names are thrown directly in
the XS Cfunction.

The XS caller context might be different to the pure-perl AUTOLOAD
context though, identifying the source location of the error.

=item croak_on_read

Similar to croak_on_error, but much more restrictive.  For each
variable which should report the "Your vendor has not defined
MyPackage macro NAME" error, a magic getter and setter hook is added
to throw this error.

This option creates code usable only since Perl 5.24, so don't
use it with any CPAN module!

=back

=cut

use Carp;
require ExtUtils::Constant::XS;
use ExtUtils::Constant::Utils qw(C_stringify);
use ExtUtils::Constant::XS qw(%XS_TypeSet);

%type_to_struct =
    (
     IV => '{const char *name; I32 namelen; IV value;}',
     NV => '{const char *name; I32 namelen; NV value;}',
     UV => '{const char *name; I32 namelen; UV value;}',
     PV => '{const char *name; I32 namelen; const char *value;}',
     PVN => '{const char *name; I32 namelen; const char *value; STRLEN len;}',
     YES => '{const char *name; I32 namelen;}',
     NO => '{const char *name; I32 namelen;}',
     UNDEF => '{const char *name; I32 namelen;}',
     '' => '{const char *name; I32 namelen;} ',
     );

%type_from_struct =
    (
     IV => sub { $_[0] . '->value' },
     NV => sub { $_[0] . '->value' },
     UV => sub { $_[0] . '->value' },
     PV => sub { $_[0] . '->value' },
     PVN => sub { $_[0] . '->value', $_[0] . '->len' },
     YES => sub {},
     NO => sub {},
     UNDEF => sub {},
     '' => sub {},
    );

%type_to_sv =
    (
     IV => sub { "newSViv($_[0])" },
     NV => sub { "newSVnv($_[0])" },
     UV => sub { "newSVuv($_[0])" },
     PV => sub { "newSVpv($_[0], 0)" },
     PVN => sub { "newSVpvn($_[0], $_[1])" },
     YES => sub { '&PL_sv_yes' },
     NO => sub { '&PL_sv_no' },
     UNDEF => sub { '&PL_sv_undef' },
     '' => sub { '&PL_sv_yes' },
     SV => sub {"SvREFCNT_inc($_[0])"},
     );

%type_to_C_value =
    (
     YES => sub {},
     NO => sub {},
     UNDEF => sub {},
     '' => sub {},
     );

sub type_to_C_value {
    my ($self, $type) = @_;
    return $type_to_C_value{$type} || sub {return map {ref $_ ? @$_ : $_} @_};
}

# TODO - figure out if there is a clean way for the type_to_sv code to
# attempt s/sv_2mortal// and if it succeeds tell type_to_sv not to add
# SvREFCNT_inc
%type_is_a_problem =
    (
     # The documentation says *mortal SV*, but we now need a non-mortal copy.
     SV => 1,
     );

%type_temporary =
    (
     SV => ['SV *'],
     PV => ['const char *'],
     PVN => ['const char *', 'STRLEN'],
     );
$type_temporary{$_} = [$_] foreach qw(IV UV NV);

while (my ($type, $value) = each %XS_TypeSet) {
    $type_num_args{$type}
	= defined $value ? ref $value ? scalar @$value : 1 : 0;
}
$type_num_args{''} = 0;

sub partition_names {
    my ($self, $default_type, @items) = @_;
    my (%found, @notfound, @trouble);

    while (my $item = shift @items) {
	my $default = delete $item->{default};
	if ($default) {
	    # If we find a default value, convert it into a regular item and
	    # append it to the queue of items to process
	    my $default_item = {%$item};
	    $default_item->{invert_macro} = 1;
	    $default_item->{pre} = delete $item->{def_pre};
	    $default_item->{post} = delete $item->{def_post};
	    $default_item->{type} = shift @$default;
	    $default_item->{value} = $default;
	    push @items, $default_item;
	} else {
	    # It can be "not found" unless it's the default (invert the macro)
	    # or the "macro" is an empty string (ie no macro)
	    push @notfound, $item unless $item->{invert_macro}
		or !$self->macro_to_ifdef($self->macro_from_item($item));
	}

	if ($item->{pre} or $item->{post} or $item->{not_constant}
	    or $type_is_a_problem{$item->{type}}) {
	    push @trouble, $item;
	} else {
	    push @{$found{$item->{type}}}, $item;
	}
    }
    # use Data::Dumper; print Dumper \%found;
    (\%found, \@notfound, \@trouble);
}

sub boottime_iterator {
    my ($self, $type, $iterator, $hash, $subname, $push) = @_;
    my $extractor = $type_from_struct{$type};
    die "Can't find extractor code for type $type"
	unless defined $extractor;
    my $generator = $type_to_sv{$type};
    die "Can't find generator code for type $type"
	unless defined $generator;

    my $athx = $self->C_constant_prefix_param();

    if ($push) {
	return sprintf <<"EOBOOT", &$generator(&$extractor($iterator));
        while ($iterator->name) {
	    he = $subname($athx $hash, $iterator->name,
                          $iterator->namelen, %s);
#if PERL_VERSION < 10
	    av_push(push, (SV*)he);
#else
	    av_push(push, newSVhek(HeKEY_hek(he)));
#endif
            ++$iterator;
	}
EOBOOT
    } else {
	return sprintf <<"EOBOOT", &$generator(&$extractor($iterator));
        while ($iterator->name) {
	    (void)$subname($athx $hash, $iterator->name,
                           $iterator->namelen, %s);
            ++$iterator;
	}
EOBOOT
    }
}

sub name_len_value_macro {
    my ($self, $item) = @_;
    my $name = $item->{name};
    my $value = $item->{value};
    $value = $item->{name} unless defined $value;

    my $namelen = length $name;
    if ($name =~ tr/\0-\377// != $namelen) {
	# the hash API signals UTF-8 by passing the length negated.
	utf8::encode($name);
	$namelen = -length $name;
    }
    $name = C_stringify($name);

    my $macro = $self->macro_from_item($item);
    ($name, $namelen, $value, $macro);
}

sub WriteConstants {
    my $self = shift;
    my $ARGS = {@_};

    my ($c_fh, $xs_fh, $c_subname, $default_type, $package)
	= @{$ARGS}{qw(C_FH XS_FH C_SUBNAME DEFAULT_TYPE NAME)};

    my $xs_subname
	= exists $ARGS->{XS_SUBNAME} ? $ARGS->{XS_SUBNAME} : 'constant';

    my $options = $ARGS->{PROXYSUBS};
    $options = {} unless ref $options;
    my $push = $options->{push};
    my $explosives = $options->{croak_on_read};
    my $croak_on_error = $options->{croak_on_error};
    my $autoload = $options->{autoload};
    {
	my $exclusive = 0;
	++$exclusive if $explosives;
	++$exclusive if $croak_on_error;
	++$exclusive if $autoload;

	# Until someone patches this (with test cases):
	carp ("PROXYSUBS options 'autoload', 'croak_on_read' and 'croak_on_error' cannot be used together")
	    if $exclusive > 1;
    }
    # Strictly this is actually 5.8.9, but it's not well tested there
    my $can_do_pcs = $] >= 5.009;
    # Until someone patches this (with test cases)
    carp ("PROXYSUBS options 'push' and 'croak_on_read' cannot be used together")
        if $explosives && $push;

    if ($explosives) {
        warn("Code created by PROXYSUBS croak_on_read can only be used with perl >= 5.24.\n",
             "It is NOT recommended for CPAN modules!\n");
    }

    # If anyone is insane enough to suggest a package name containing %
    my $package_sprintf_safe = $package;
    $package_sprintf_safe =~ s/%/%%/g;
    # People were actually more insane than thought
    $package_sprintf_safe =~ s/\x{0}/\\0/g if $] > 5.015006;

    # All the types we see
    my $what = {};
    # A hash to lookup items with.
    my $items = {};

    my @items = $self->normalise_items ({disable_utf8_duplication => 1},
					$default_type, $what, $items,
					@{$ARGS->{NAMES}});

    # Partition the values by type. Also include any defaults in here
    # Everything that doesn't have a default needs alternative code for
    # "I'm missing"
    # And everything that has pre or post code ends up in a private block
    my ($found, $notfound, $trouble)
	= $self->partition_names($default_type, @items);

    my $pthx = $self->C_constant_prefix_param_definition();
    my $athx = $self->C_constant_prefix_param();
    my $symbol_table = C_stringify($package) . '::';
    $push = C_stringify($package . '::' . $push) if $push;
    my $cast_CONSTSUB = $] < 5.010 ? '(char *)' : '';

    print $c_fh $self->header();
    print $c_fh <<'EOC';

/* 5.6 */
#ifndef C_ARRAY_LENGTH
#define C_ARRAY_LENGTH(x) (sizeof(x)/sizeof((x)[0]))
#endif
EOC
    if ($explosives) {
        print $c_fh <<'EOC';
/* 5.8 */
#ifndef PERL_UNUSED_ARG
#define PERL_UNUSED_ARG(x)
#endif
#ifndef NORETURN_FUNCTION_END
#define NORETURN_FUNCTION_END
#endif
EOC
    }
    if ($autoload || $croak_on_error) {
	print $c_fh <<'EOC';

/* This allows slightly more efficient code on !USE_ITHREADS: */
#ifdef USE_ITHREADS
#  define COP_FILE(c)	CopFILE(c)
#  define COP_FILE_F	"s"
#else
#  define COP_FILE(c)	CopFILESV(c)
#  define COP_FILE_F	SVf
#endif
EOC
    }

    my $return_type = $push ? 'HE *' : 'void';

    print $c_fh <<"EOADD";

static $return_type
${c_subname}_add_symbol($pthx HV *hash, const char *name, I32 namelen, SV *value) {
EOADD
    if (!$can_do_pcs) {
	print $c_fh <<'EO_NOPCS';
    HE *he = NULL;
    if (namelen) {
EO_NOPCS
    } else {
	print $c_fh <<"EO_PCS";
#if PERL_VERSION < 10
    SV **he = hv_fetch(hash, name, namelen, TRUE);
#else
    HE *he = (HE*) hv_common_key_len(hash, name, namelen, HV_FETCH_LVALUE, NULL,
				     0);
#endif
    SV *sv;

    if (!he) {
        croak("Couldn't add key '%s' to %%$package_sprintf_safe\::",
	      name);
    }
#if PERL_VERSION < 10
    sv = *he;
#else
    sv = HeVAL(he);
#endif
    if (SvOK(sv) || SvTYPE(sv) == SVt_PVGV) {
	/* Someone has been here before us - have to make a real sub.  */
EO_PCS
    }
    # This piece of code is common to both
    print $c_fh <<"EOADD";
	newCONSTSUB(hash, ${cast_CONSTSUB}name, value);
EOADD
    if ($can_do_pcs) {
	print $c_fh <<'EO_PCS';
    } else {
	SvUPGRADE(sv, SVt_RV);
	SvRV_set(sv, value);
	SvROK_on(sv);
	SvREADONLY_on(value);
    }
EO_PCS
    } else {
	print $c_fh <<'EO_NOPCS';
    }
EO_NOPCS
    }
    print $c_fh "    return (HE *)he;\n" if $push;
    print $c_fh <<'EOADD';
}

EOADD

    print $c_fh $explosives ? <<"EXPLODE" : "\n";

static int
Im_sorry_Dave(pTHX_ SV *sv, MAGIC *mg)
{
    PERL_UNUSED_ARG(mg);
    croak("Your vendor has not defined $package_sprintf_safe macro %" SVf
          " used", sv);
    NORETURN_FUNCTION_END;
}

static MGVTBL not_defined_vtbl = {
 Im_sorry_Dave, /* get - I'm afraid I can't do that */
 Im_sorry_Dave, /* set */
 0, /* len */
 0, /* clear */
 0, /* free */
#if PERL_VERSION > 6
 0, /* copy */
 0, /* dup */
#if (PERL_VERSION > 8) || (PERL_VERSION == 8 && PERL_SUBVERSION == 9)
 0, /* local */
#endif
#endif
};

EXPLODE

{
    my $key = $symbol_table;
    # Just seems tidier (and slightly more space efficient) not to have keys
    # such as Fcntl::
    $key =~ s/::$//;
    my $key_len = length $key;

    print $c_fh <<"MISSING" unless $explosives;

#ifndef SYMBIAN

/* Store a hash of all symbols missing from the package. To avoid trampling on
   the package namespace (uninvited) put each package's hash in our namespace.
   To avoid creating lots of typeblogs and symbol tables for sub-packages, put
   each package's hash into one hash in our namespace.  */

static HV *
get_missing_hash(pTHX) {
    HV *const parent
	= get_hv("ExtUtils::Constant::ProxySubs::Missing", GVf_MULTI);
    /* We could make a hash of hashes directly, but this would confuse anything
	at Perl space that looks at us, and as we're visible in Perl space,
	best to play nice. */
    SV *const *const ref = hv_fetch(parent, "$key", $key_len, TRUE);
    HV *new_hv;

    if (!ref)
	return NULL;

    if (SvROK(*ref))
	return (HV*) SvRV(*ref);

    new_hv = newHV();
    SvUPGRADE(*ref, SVt_RV);
    SvRV_set(*ref, (SV *)new_hv);
    SvROK_on(*ref);
    return new_hv;
}

#endif

MISSING

}

    print $xs_fh <<"EOBOOT";
BOOT:
  {
#if defined(dTHX) && !defined(PERL_NO_GET_CONTEXT)
    dTHX;
#endif
    HV *symbol_table = get_hv("$symbol_table", GV_ADD);
EOBOOT
    if ($push) {
        # silence cperl-only Used once warnings
	print $xs_fh <<"EOC";
#ifndef USE_CPERL
    AV *push = get_av(\"$push\", GV_ADD);
#else
    AV *push = get_av(\"$push\", GV_ADD|GV_ADDMULTI);
#endif
    HE *he;
EOC
    }

    my %iterator;

    $found->{''}
        = [map {{%$_, type=>'', invert_macro => 1}} @$notfound];

    foreach my $type (sort keys %$found) {
	my $struct = $type_to_struct{$type};
	my $type_to_value = $self->type_to_C_value($type);
	my $number_of_args = $type_num_args{$type};
	die "Can't find structure definition for type $type"
	    unless defined $struct;

	my $lc_type = $type ? lc($type) : 'notfound';
	my $struct_type = $lc_type . '_s';
	my $array_name = 'values_for_' . $lc_type;
	$iterator{$type} = 'value_for_' . $lc_type;
	# Give the notfound struct file scope. The others are scoped within the
	# BOOT block
	my $struct_fh = $type ? $xs_fh : $c_fh;

	print $c_fh "struct $struct_type $struct; /* $type */\n";

	print $struct_fh <<"EOBOOT";

    static const struct $struct_type $array_name\[] =
      {
EOBOOT


	foreach my $item (@{$found->{$type}}) {
            my ($name, $namelen, $value, $macro)
                 = $self->name_len_value_macro($item);

	    my $ifdef = $self->macro_to_ifdef($macro);
	    if (!$ifdef && $item->{invert_macro}) {
		carp("Attempting to supply a default for '$name' which has no conditional macro");
		next;
	    }
	    if ($item->{invert_macro}) {
		print $struct_fh $self->macro_to_ifndef($macro);
		print $struct_fh
			"        /* This is the default value: */\n" if $type;
	    } else {
		print $struct_fh $ifdef;
	    }
            # skip undef type ''
            print $struct_fh "        { ";
            if (defined &$type_to_value($value)) {
                print $struct_fh join (', ', "\"$name\"", $namelen,
                                       &$type_to_value($value));
            } else {
                print $struct_fh join (', ', "\"$name\"", $namelen);
            }
            print $struct_fh " },\n",
              $self->macro_to_endif($macro);
	}

    # Terminate the list with a NULL
	print $struct_fh "        { NULL, 0", (", 0" x $number_of_args),
                         " }\n      };\n";

	print $xs_fh <<"EOBOOT" if $type;
    const struct $struct_type *$iterator{$type} = $array_name;
EOBOOT
    }

    delete $found->{''};

    my $add_symbol_subname = $c_subname . '_add_symbol';
    foreach my $type (sort keys %$found) {
	print $xs_fh $self->boottime_iterator($type, $iterator{$type},
					      'symbol_table',
					      $add_symbol_subname, $push);
    }

    print $xs_fh <<'EOBOOT';
	if (C_ARRAY_LENGTH(values_for_notfound) > 1) {
EOBOOT

    print $xs_fh <<"EOBOOT" unless $explosives;
#ifndef SYMBIAN
	    HV *const ${c_subname}_missing = get_missing_hash(aTHX);
#endif
EOBOOT

    print $xs_fh <<'EOBOOT';
	    const struct notfound_s *value_for_notfound = values_for_notfound;
	    do {
EOBOOT

    print $xs_fh $explosives ? <<"EXPLODE" : << "DONT";
		SV *tripwire = newSV(0);

		sv_magicext(tripwire, 0, PERL_MAGIC_ext, ¬_defined_vtbl, 0, 0);
		SvPV_set(tripwire, (char *)value_for_notfound->name);
		if (value_for_notfound->namelen >= 0) {
		    SvCUR_set(tripwire, value_for_notfound->namelen);
	    	} else {
		    SvCUR_set(tripwire, -value_for_notfound->namelen);
		    SvUTF8_on(tripwire);
		}
		SvPOKp_on(tripwire);
		SvREADONLY_on(tripwire);
		assert(SvLEN(tripwire) == 0);

		$add_symbol_subname($athx symbol_table, value_for_notfound->name,
				    value_for_notfound->namelen, tripwire);
EXPLODE

		SV *sv;
#ifndef SYMBIAN
		HEK *hek;
#endif
		/* Need to add prototypes, else parsing will vary by platform.  */
#if PERL_VERSION < 10
		SV **he = hv_fetch(symbol_table,
                                   value_for_notfound->name,
                                   value_for_notfound->namelen,
                                   TRUE);
#else
		HE *he = (HE*) hv_common_key_len(symbol_table,
						 value_for_notfound->name,
						 value_for_notfound->namelen,
						 HV_FETCH_LVALUE, NULL, 0);
#endif
		if (!he) {
		    croak("Couldn't add key '%s' to %%$package_sprintf_safe\::",
			  value_for_notfound->name);
		}
#if PERL_VERSION < 10
		sv = *he;
#else
		sv = HeVAL(he);
#endif
		if (!SvOK(sv) && SvTYPE(sv) != SVt_PVGV) {
#if 0
                    CV *cv;
		    /* 5.6 needs a proper const sub? */
                    newCONSTSUB(symbol_table, (char *)value_for_notfound->name,
                                &PL_sv_undef);
                    cv = GvCV(sv);
#elif PERL_VERSION < 8
                    /* empty typeglob as NULL sv? */
#elif PERL_VERSION < 10
                    sv_upgrade(sv, SVt_PV);
		    sv_setpvn(sv, "", 0);
#else
		    /* Nothing was here before, so mark a prototype of ""  */
		    sv_setpvn(sv, "", 0);
#endif
		} else if (SvPOK(sv) && SvCUR(sv) == 0) {
		    /* There is already a prototype of "" - do nothing  */
		} else {
		    /* Someone has been here before us - have to make a real
		       typeglob.  */
		    /* It turns out to be incredibly hard to deal with all the
		       corner cases of sub foo (); and reporting errors correctly,
		       so lets cheat a bit.  Start with a constant subroutine  */
                    CV *cv;
#if PERL_VERSION > 6
                    cv =
#endif
                        newCONSTSUB(symbol_table,
                                     (char *)value_for_notfound->name,
                                     &PL_sv_yes);
#if PERL_VERSION < 8
                    cv = GvCV(sv);
#endif
		    /* and then turn it into a non constant declaration only.  */
#if PERL_VERSION > 6
		    SvREFCNT_dec(CvXSUBANY(cv).any_ptr);
		    CvCONST_off(cv);
#endif
		    CvXSUB(cv) = NULL;
		    CvXSUBANY(cv).any_ptr = NULL;
		}
#ifndef SYMBIAN
# if PERL_VERSION < 10
		if (!hv_store(${c_subname}_missing,
                    value_for_notfound->name,
                    value_for_notfound->namelen,
                    &PL_sv_yes, 0))
# else
		hek = HeKEY_hek(he);
		if (!hv_common(${c_subname}_missing, NULL, HEK_KEY(hek),
 			       HEK_LEN(hek), HEK_FLAGS(hek), HV_FETCH_ISSTORE,
			       &PL_sv_yes, HEK_HASH(hek)))
# endif
		    croak("Couldn't add key '%s' to missing_hash",
			  value_for_notfound->name);
#endif
DONT

    if ($push) {
        print $xs_fh <<'EOC';
#if PERL_VERSION < 10
	    av_push(push, sv);
#else
	    av_push(push, newSVhek(hek));
#endif
EOC
    }
    print $xs_fh <<"EOBOOT";
	    } while ((++value_for_notfound)->name);
	}
EOBOOT

    foreach my $item (@$trouble) {
        my ($name, $namelen, $value, $macro)
	    = $self->name_len_value_macro($item);
        my $ifdef = $self->macro_to_ifdef($macro);
        my $type = $item->{type};
	my $type_to_value = $self->type_to_C_value($type);

        print $xs_fh $ifdef;
	if ($item->{invert_macro}) {
	    print $xs_fh
		 "        /* This is the default value: */\n" if $type;
	    print $xs_fh "#else\n";
	}
	my $generator = $type_to_sv{$type};
	die "Can't find generator code for type $type"
	    unless defined $generator;

	print $xs_fh "        {\n";
	# We need to use a temporary value because some really troublesome
	# items use C pre processor directives in their values, and in turn
	# these don't fit nicely in the macro-ised generator functions
	my $counter = 0;
	printf $xs_fh "            %s temp%d;\n", $_, $counter++
	    foreach @{$type_temporary{$type}};

	print $xs_fh "            $item->{pre}\n" if $item->{pre};

	# And because the code in pre might be both declarations and
	# statements, we can't declare and assign to the temporaries in one.
	$counter = 0;
	printf $xs_fh "            temp%d = %s;\n", $counter++, $_
	    foreach &$type_to_value($value);

	my @tempvarnames = map {sprintf 'temp%d', $_} 0 .. $counter - 1;
	printf $xs_fh <<"EOBOOT", $name, &$generator(@tempvarnames);
	    ${c_subname}_add_symbol($athx symbol_table, "%s",
				    $namelen, %s);
EOBOOT
	print $xs_fh "        $item->{post}\n" if $item->{post};
	print $xs_fh "        }\n";

        print $xs_fh $self->macro_to_endif($macro);
    }

    if ($] >= 5.009) {
	print $xs_fh <
    /* As we've been creating subroutines, we better invalidate any cached
       methods  */
    mro_method_changed_in(symbol_table);
  }
EOBOOT
    } else {
	print $xs_fh <
    /* As we've been creating subroutines, we better invalidate any cached
       methods  */
    ++PL_sub_generation;
  }
EOBOOT
    }

    return if !defined $xs_subname;

    if ($croak_on_error || $autoload) {
        print $xs_fh $croak_on_error ? <<"EOC" : <<"EOA";

void
$xs_subname(sv)
    INPUT:
	SV *		sv;
    PREINIT:
#ifdef caller_cx
	const PERL_CONTEXT *cx = caller_cx(0, NULL);
	/* cx is NULL if we've been called from the top level. PL_curcop isn't
	   ideal, but it's much cheaper than other ways of not going SEGV.  */
	const COP *cop = cx ? cx->blk_oldcop : PL_curcop;
#else
	const COP *cop = PL_curcop;
#endif
EOC

void
AUTOLOAD()
    PROTOTYPE: DISABLE
    PREINIT:
#if PERL_VERSION < 10
        SV *sv = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
#else
        SV *sv = newSVpvn_flags(SvPVX(cv), SvCUR(cv), SVs_TEMP | SvUTF8(cv));
#endif
	const COP *cop = PL_curcop;
EOA
        print $xs_fh <<"EOC";
    PPCODE:
#ifndef SYMBIAN
	/* It's not obvious how to calculate this at C pre-processor time.
	   However, any compiler optimiser worth its salt should be able to
	   remove the dead code, and hopefully the now-obviously-unused static
	   function too.  */
	HV *${c_subname}_missing = (C_ARRAY_LENGTH(values_for_notfound) > 1)
	    ? get_missing_hash(aTHX) : NULL;
	if ((C_ARRAY_LENGTH(values_for_notfound) > 1)
	    ? hv_exists_ent(${c_subname}_missing, sv, 0) : 0) {
            croak("Your vendor has not defined $package_sprintf_safe macro %" SVf
                  ", used at %" COP_FILE_F " line %" UVuf "\\n",
                  sv, COP_FILE(cop), (UV)CopLINE(cop));
	} else
#endif
	{
	    croak("%" SVf " is not a valid $package_sprintf_safe macro at %"
                  COP_FILE_F " line %" UVuf "\\n",
                  sv, COP_FILE(cop), (UV)CopLINE(cop));
	}
EOC
    } else {
        print $xs_fh $explosives ? <<"EXPLODE" : <<"DONT";

void
$xs_subname(sv)
    INPUT:
	SV *		sv;
    PPCODE:
	sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf
                      ", used", sv);
        PUSHs(sv_2mortal(sv));
EXPLODE

void
$xs_subname(sv)
    INPUT:
	SV *		sv;
    PPCODE:
#ifndef SYMBIAN
	/* It's not obvious how to calculate this at C pre-processor time.
	   However, any compiler optimiser worth its salt should be able to
	   remove the dead code, and hopefully the now-obviously-unused static
	   function too.  */
	HV *${c_subname}_missing = (C_ARRAY_LENGTH(values_for_notfound) > 1)
	    ? get_missing_hash(aTHX) : NULL;
	if ((C_ARRAY_LENGTH(values_for_notfound) > 1)
	    ? hv_exists_ent(${c_subname}_missing, sv, 0) : 0) {
	    sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf
			  ", used", sv);
	} else
#endif
	{
	    sv = newSVpvf("%" SVf " is not a valid $package_sprintf_safe macro",
			  sv);
	}
	PUSHs(sv_2mortal(sv));
DONT
    }
}

1;
__END__