[p5sagit/p5-mst-13.2.git] / lib / ExtUtils / Constant / ProxySubs.pm

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);
use Carp;
require ExtUtils::Constant::XS;
use ExtUtils::Constant::Utils qw(C_stringify);
use ExtUtils::Constant::XS qw(%XS_TypeSet);

$VERSION = '0.04';
@ISA = 'ExtUtils::Constant::XS';

%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) = @_;
    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();

    return sprintf <<"EOBOOT", &$generator(&$extractor($iterator));
        while ($iterator->name) {
	    $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, $xs_subname, $default_type, $package)
	= @{$ARGS}{qw(C_FH XS_FH C_SUBNAME XS_SUBNAME DEFAULT_TYPE NAME)};

    my $options = $ARGS->{PROXYSUBS};
    $options = {} unless ref $options;
    my $explosives = $options->{croak_on_read};

    $xs_subname ||= 'constant';

    # If anyone is insane enough to suggest a package name containing %
    my $package_sprintf_safe = $package;
    $package_sprintf_safe =~ s/%/%%/g;

    # 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_defintion();
    my $athx = $self->C_constant_prefix_param();
    my $symbol_table = C_stringify($package) . '::';

    print $c_fh $self->header(), <<"EOADD";
static void
${c_subname}_add_symbol($pthx HV *hash, const char *name, I32 namelen, SV *value) {
    SV **sv = hv_fetch(hash, name, namelen, TRUE);
    if (!sv) {
        Perl_croak($athx "Couldn't add key '%s' to %%$package_sprintf_safe\::",
		   name);
    }
    if (SvOK(*sv) || SvTYPE(*sv) == SVt_PVGV) {
	/* Someone has been here before us - have to make a real sub.  */
	newCONSTSUB(hash, name, value);
    } else {
	SvUPGRADE(*sv, SVt_RV);
	SvRV_set(*sv, value);
	SvROK_on(*sv);
	SvREADONLY_on(value);
    }
}

EOADD

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

static int
Im_sorry_Dave(pTHX_ SV *sv, MAGIC *mg)
{
    PERL_UNUSED_ARG(mg);
    Perl_croak(aTHX_
	       "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 */
 0, /* copy */
 0, /* dup */
};

EXPLODE

    print $xs_fh <<"EOBOOT";
BOOT:
  {
#ifdef dTHX
    dTHX;
#endif
    HV *symbol_table = get_hv("$symbol_table", TRUE);
#ifndef SYMBIAN
    /* When we create the 'missing' hash, it generates a 'used only once'
     * warning.  Therefore, turn off warnings while we do this.
     */
    HV *${c_subname}_missing;
    {
        const bool warn_tmp = PL_dowarn;
        PL_dowarn = 0;
        ${c_subname}_missing = get_hv("${symbol_table}${c_subname}_M!55!NG", TRUE);
        PL_dowarn = warn_tmp;
    }
#endif
EOBOOT

    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 $struct_type = $type ? lc($type) . '_s' : 'notfound_s';
	print $c_fh "struct $struct_type $struct;\n";

	my $array_name = 'values_for_' . ($type ? lc $type : 'notfound');
	print $xs_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;
	    }
	    print $xs_fh $ifdef;
	    if ($item->{invert_macro}) {
		print $xs_fh
		    "        /* This is the default value: */\n" if $type;
		print $xs_fh "#else\n";
	    }
	    print $xs_fh "        { ", join (', ', "\"$name\"", $namelen,
					     &$type_to_value($value)), " },\n",
						 $self->macro_to_endif($macro);
	}


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

	$iterator{$type} = "value_for_" . ($type ? lc $type : 'notfound');

	print $xs_fh <<"EOBOOT";
	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);
    }

    print $xs_fh <<"EOBOOT";
	while (value_for_notfound->name) {
EOBOOT

    print $xs_fh $explosives ? <<"EXPLODE" : << "DONT";
	    SV *tripwire = newSV(0);
	    
	    sv_magicext(tripwire, 0, PERL_MAGIC_ext, &not_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

	    /* Need to add prototypes, else parsing will vary by platform.  */
	    SV **sv = hv_fetch(symbol_table, value_for_notfound->name,
			       value_for_notfound->namelen, TRUE);
	    if (!sv) {
		Perl_croak($athx
			   "Couldn't add key '%s' to %%$package_sprintf_safe\::",
			   value_for_notfound->name);
	    }
	    if (!SvOK(*sv) && SvTYPE(*sv) != SVt_PVGV) {
		/* Nothing was here before, so mark a prototype of ""  */
		sv_setpvn(*sv, "", 0);
	    } 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 = newCONSTSUB(symbol_table, value_for_notfound->name,
				     &PL_sv_yes);
		/* and then turn it into a non constant declaration only.  */
		SvREFCNT_dec(CvXSUBANY(cv).any_ptr);
		CvCONST_off(cv);
		CvXSUB(cv) = NULL;
		CvXSUBANY(cv).any_ptr = NULL;
	    }
#ifndef SYMBIAN
	    if (!hv_store(${c_subname}_missing, value_for_notfound->name,
			  value_for_notfound->namelen, &PL_sv_yes, 0))
		Perl_croak($athx "Couldn't add key '%s' to missing_hash",
			   value_for_notfound->name);
#endif
DONT

    print $xs_fh <<"EOBOOT";

	    ++value_for_notfound;
	}
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);
    }

    print $xs_fh <<EOBOOT;
    /* As we've been creating subroutines, we better invalidate any cached
       methods  */
    ++PL_sub_generation;
  }
EOBOOT

    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)
    PREINIT:
	STRLEN		len;
    INPUT:
	SV *		sv;
        const char *	s = SvPV(sv, len);
    PPCODE:
#ifdef SYMBIAN
	sv = newSVpvf("%"SVf" is not a valid $package_sprintf_safe macro", sv);
#else
	HV *${c_subname}_missing = get_hv("${c_subname}_M!55!NG", FALSE);
	if (hv_exists(${c_subname}_missing, s, SvUTF8(sv) ? -(I32)len : (I32)len)) {
	    sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf
			  ", used", sv);
	} else {
	    sv = newSVpvf("%"SVf" is not a valid $package_sprintf_safe macro",
			  sv);
	}
#endif
	PUSHs(sv_2mortal(sv));
DONT

}

1;
Commit	Line	Data
6d7fb585	1	package ExtUtils::Constant::ProxySubs;
	2
	3	use strict;
64bb7586	4	use vars qw($VERSION @ISA %type_to_struct %type_from_struct %type_to_sv
6800c0cf	5	%type_to_C_value %type_is_a_problem %type_num_args
6800c0cf	6	%type_temporary);
6d7fb585	7	use Carp;
	8	require ExtUtils::Constant::XS;
	9	use ExtUtils::Constant::Utils qw(C_stringify);
	10	use ExtUtils::Constant::XS qw(%XS_TypeSet);
	11
67a86ef3	12	$VERSION = '0.04';
6d7fb585	13	@ISA = 'ExtUtils::Constant::XS';
	14
	15	%type_to_struct =
	16	(
	17	IV => '{const char *name; I32 namelen; IV value;}',
64bb7586	18	NV => '{const char *name; I32 namelen; NV value;}',
64bb7586	19	UV => '{const char *name; I32 namelen; UV value;}',
49657794	20	PV => '{const char name; I32 namelen; const char value;}',
6f226cd7	21	PVN => '{const char name; I32 namelen; const char value; STRLEN len;}',
64bb7586	22	YES => '{const char *name; I32 namelen;}',
64bb7586	23	NO => '{const char *name; I32 namelen;}',
6f226cd7	24	UNDEF => '{const char *name; I32 namelen;}',
6d7fb585	25	'' => '{const char *name; I32 namelen;} ',
	26	);
	27
64bb7586	28	%type_from_struct =
	29	(
	30	IV => sub { $_[0] . '->value' },
	31	NV => sub { $_[0] . '->value' },
	32	UV => sub { $_[0] . '->value' },
49657794	33	PV => sub { $_[0] . '->value' },
6f226cd7	34	PVN => sub { $_[0] . '->value', $_[0] . '->len' },
64bb7586	35	YES => sub {},
64bb7586	36	NO => sub {},
6f226cd7	37	UNDEF => sub {},
64bb7586	38	'' => sub {},
	39	);
	40
6d7fb585	41	%type_to_sv =
6d7fb585	42	(
64bb7586	43	IV => sub { "newSViv($_[0])" },
	44	NV => sub { "newSVnv($_[0])" },
	45	UV => sub { "newSVuv($_[0])" },
49657794	46	PV => sub { "newSVpv($_[0], 0)" },
6f226cd7	47	PVN => sub { "newSVpvn($_[0], $_[1])" },
64bb7586	48	YES => sub { '&PL_sv_yes' },
64bb7586	49	NO => sub { '&PL_sv_no' },
0fcb9a02	50	UNDEF => sub { '&PL_sv_undef' },
6d7fb585	51	'' => sub { '&PL_sv_yes' },
2ebbb0c3	52	SV => sub {"SvREFCNT_inc($_[0])"},
6d7fb585	53	);
	54
	55	%type_to_C_value =
	56	(
64bb7586	57	YES => sub {},
64bb7586	58	NO => sub {},
0fcb9a02	59	UNDEF => sub {},
6d7fb585	60	'' => sub {},
	61	);
	62
64bb7586	63	sub type_to_C_value {
	64	my ($self, $type) = @_;
	65	return $type_to_C_value{$type} \|\| sub {return map {ref $_ ? @$_ : $_} @_};
	66	}
	67
49657794	68	# TODO - figure out if there is a clean way for the type_to_sv code to
	69	# attempt s/sv_2mortal// and if it succeeds tell type_to_sv not to add
	70	# SvREFCNT_inc
6d7fb585	71	%type_is_a_problem =
6d7fb585	72	(
2ebbb0c3	73	# The documentation says mortal SV, but we now need a non-mortal copy.
6d7fb585	74	SV => 1,
	75	);
	76
49657794	77	%type_temporary =
49657794	78	(
6f226cd7	79	SV => ['SV *'],
	80	PV => ['const char *'],
	81	PVN => ['const char *', 'STRLEN'],
49657794	82	);
6f226cd7	83	$type_temporary{$_} = [$_] foreach qw(IV UV NV);
6800c0cf	84
6d7fb585	85	while (my ($type, $value) = each %XS_TypeSet) {
64bb7586	86	$type_num_args{$type}
64bb7586	87	= defined $value ? ref $value ? scalar @$value : 1 : 0;
6d7fb585	88	}
	89	$type_num_args{''} = 0;
	90
	91	sub partition_names {
	92	my ($self, $default_type, @items) = @_;
	93	my (%found, @notfound, @trouble);
	94
	95	while (my $item = shift @items) {
	96	my $default = delete $item->{default};
	97	if ($default) {
	98	# If we find a default value, convert it into a regular item and
	99	# append it to the queue of items to process
	100	my $default_item = {%$item};
	101	$default_item->{invert_macro} = 1;
	102	$default_item->{pre} = delete $item->{def_pre};
	103	$default_item->{post} = delete $item->{def_post};
	104	$default_item->{type} = shift @$default;
	105	$default_item->{value} = $default;
	106	push @items, $default_item;
	107	} else {
	108	# It can be "not found" unless it's the default (invert the macro)
	109	# or the "macro" is an empty string (ie no macro)
	110	push @notfound, $item unless $item->{invert_macro}
0fcb9a02	111	or !$self->macro_to_ifdef($self->macro_from_item($item));
6d7fb585	112	}
6d7fb585	113
64bb7586	114	if ($item->{pre} or $item->{post} or $item->{not_constant}
64bb7586	115	or $type_is_a_problem{$item->{type}}) {
6d7fb585	116	push @trouble, $item;
	117	} else {
	118	push @{$found{$item->{type}}}, $item;
	119	}
	120	}
	121	# use Data::Dumper; print Dumper \%found;
	122	(\%found, \@notfound, \@trouble);
	123	}
	124
	125	sub boottime_iterator {
	126	my ($self, $type, $iterator, $hash, $subname) = @_;
64bb7586	127	my $extractor = $type_from_struct{$type};
	128	die "Can't find extractor code for type $type"
	129	unless defined $extractor;
6d7fb585	130	my $generator = $type_to_sv{$type};
	131	die "Can't find generator code for type $type"
	132	unless defined $generator;
	133
	134	my $athx = $self->C_constant_prefix_param();
	135
64bb7586	136	return sprintf <<"EOBOOT", &$generator(&$extractor($iterator));
6d7fb585	137	while ($iterator->name) {
	138	$subname($athx $hash, $iterator->name,
	139	$iterator->namelen, %s);
	140	++$iterator;
	141	}
	142	EOBOOT
	143	}
	144
64bb7586	145	sub name_len_value_macro {
	146	my ($self, $item) = @_;
	147	my $name = $item->{name};
	148	my $value = $item->{value};
	149	$value = $item->{name} unless defined $value;
	150
	151	my $namelen = length $name;
	152	if ($name =~ tr/\0-\377// != $namelen) {
	153	# the hash API signals UTF-8 by passing the length negated.
	154	utf8::encode($name);
	155	$namelen = -length $name;
	156	}
	157	$name = C_stringify($name);
	158
0fcb9a02	159	my $macro = $self->macro_from_item($item);
64bb7586	160	($name, $namelen, $value, $macro);
	161	}
	162
6d7fb585	163	sub WriteConstants {
6d7fb585	164	my $self = shift;
6b43b341	165	my $ARGS = {@_};
6d7fb585	166
6d7fb585	167	my ($c_fh, $xs_fh, $c_subname, $xs_subname, $default_type, $package)
6b43b341	168	= @{$ARGS}{qw(C_FH XS_FH C_SUBNAME XS_SUBNAME DEFAULT_TYPE NAME)};
	169
	170	my $options = $ARGS->{PROXYSUBS};
	171	$options = {} unless ref $options;
	172	my $explosives = $options->{croak_on_read};
6d7fb585	173
	174	$xs_subname \|\|= 'constant';
	175
fa6eee5a	176	# If anyone is insane enough to suggest a package name containing %
	177	my $package_sprintf_safe = $package;
	178	$package_sprintf_safe =~ s/%/%%/g;
6d7fb585	179
	180	# All the types we see
	181	my $what = {};
	182	# A hash to lookup items with.
	183	my $items = {};
	184
	185	my @items = $self->normalise_items ({disable_utf8_duplication => 1},
6b43b341	186	$default_type, $what, $items,
6b43b341	187	@{$ARGS->{NAMES}});
6d7fb585	188
	189	# Partition the values by type. Also include any defaults in here
	190	# Everything that doesn't have a default needs alternative code for
	191	# "I'm missing"
	192	# And everything that has pre or post code ends up in a private block
	193	my ($found, $notfound, $trouble)
	194	= $self->partition_names($default_type, @items);
	195
6d7fb585	196	my $pthx = $self->C_constant_prefix_param_defintion();
	197	my $athx = $self->C_constant_prefix_param();
	198	my $symbol_table = C_stringify($package) . '::';
	199
64bb7586	200	print $c_fh $self->header(), <<"EOADD";
9fb41657	201	static void
9fb41657	202	${c_subname}_add_symbol($pthx HV hash, const char name, I32 namelen, SV *value) {
0998eade	203	SV **sv = hv_fetch(hash, name, namelen, TRUE);
0998eade	204	if (!sv) {
fa6eee5a	205	Perl_croak($athx "Couldn't add key '%s' to %%$package_sprintf_safe\::",
fa6eee5a	206	name);
0998eade	207	}
	208	if (SvOK(sv) \|\| SvTYPE(sv) == SVt_PVGV) {
	209	/* Someone has been here before us - have to make a real sub. */
	210	newCONSTSUB(hash, name, value);
	211	} else {
	212	SvUPGRADE(*sv, SVt_RV);
	213	SvRV_set(*sv, value);
	214	SvROK_on(*sv);
abe8a887	215	SvREADONLY_on(value);
6d7fb585	216	}
	217	}
	218
6b43b341	219	EOADD
6b43b341	220
67a86ef3	221	print $c_fh $explosives ? <<"EXPLODE" : "\n";
6b43b341	222
	223	static int
	224	Im_sorry_Dave(pTHX_ SV sv, MAGIC mg)
	225	{
	226	PERL_UNUSED_ARG(mg);
fa6eee5a	227	Perl_croak(aTHX_
	228	"Your vendor has not defined $package_sprintf_safe macro %"SVf
	229	" used", sv);
6b43b341	230	NORETURN_FUNCTION_END;
	231	}
	232
	233	static MGVTBL not_defined_vtbl = {
	234	Im_sorry_Dave, /* get - I'm afraid I can't do that */
	235	Im_sorry_Dave, /* set */
	236	0, /* len */
	237	0, /* clear */
	238	0, /* free */
	239	0, /* copy */
	240	0, /* dup */
	241	};
	242
	243	EXPLODE
	244
6d7fb585	245	print $xs_fh <<"EOBOOT";
	246	BOOT:
	247	{
	248	#ifdef dTHX
	249	dTHX;
	250	#endif
	251	HV *symbol_table = get_hv("$symbol_table", TRUE);
67a86ef3	252	#ifndef SYMBIAN
	253	/* When we create the 'missing' hash, it generates a 'used only once'
	254	* warning. Therefore, turn off warnings while we do this.
	255	*/
	256	HV *${c_subname}_missing;
	257	{
	258	const bool warn_tmp = PL_dowarn;
	259	PL_dowarn = 0;
	260	${c_subname}_missing = get_hv("${symbol_table}${c_subname}_M!55!NG", TRUE);
	261	PL_dowarn = warn_tmp;
	262	}
	263	#endif
6d7fb585	264	EOBOOT
	265
	266	my %iterator;
	267
	268	$found->{''}
	269	= [map {{%$_, type=>'', invert_macro => 1}} @$notfound];
	270
	271	foreach my $type (sort keys %$found) {
	272	my $struct = $type_to_struct{$type};
64bb7586	273	my $type_to_value = $self->type_to_C_value($type);
6d7fb585	274	my $number_of_args = $type_num_args{$type};
	275	die "Can't find structure definition for type $type"
	276	unless defined $struct;
	277
	278	my $struct_type = $type ? lc($type) . '_s' : 'notfound_s';
	279	print $c_fh "struct $struct_type $struct;\n";
	280
	281	my $array_name = 'values_for_' . ($type ? lc $type : 'notfound');
	282	print $xs_fh <<"EOBOOT";
	283
	284	static const struct $struct_type $array_name\[] =
	285	{
	286	EOBOOT
	287
	288
	289	foreach my $item (@{$found->{$type}}) {
64bb7586	290	my ($name, $namelen, $value, $macro)
64bb7586	291	= $self->name_len_value_macro($item);
6d7fb585	292
6d7fb585	293	my $ifdef = $self->macro_to_ifdef($macro);
	294	if (!$ifdef && $item->{invert_macro}) {
	295	carp("Attempting to supply a default for '$name' which has no conditional macro");
	296	next;
	297	}
	298	print $xs_fh $ifdef;
	299	if ($item->{invert_macro}) {
	300	print $xs_fh
	301	" /* This is the default value: */\n" if $type;
	302	print $xs_fh "#else\n";
	303	}
	304	print $xs_fh " { ", join (', ', "\"$name\"", $namelen,
	305	&$type_to_value($value)), " },\n",
	306	$self->macro_to_endif($macro);
	307	}
	308
	309
	310	# Terminate the list with a NULL
	311	print $xs_fh " { NULL, 0", (", 0" x $number_of_args), " } };\n";
	312
	313	$iterator{$type} = "value_for_" . ($type ? lc $type : 'notfound');
	314
	315	print $xs_fh <<"EOBOOT";
	316	const struct $struct_type *$iterator{$type} = $array_name;
	317
	318	EOBOOT
	319	}
	320
	321	delete $found->{''};
6b43b341	322
6b43b341	323	my $add_symbol_subname = $c_subname . '_add_symbol';
6d7fb585	324	foreach my $type (sort keys %$found) {
	325	print $xs_fh $self->boottime_iterator($type, $iterator{$type},
	326	'symbol_table',
6b43b341	327	$add_symbol_subname);
6d7fb585	328	}
6b43b341	329
6b43b341	330	print $xs_fh <<"EOBOOT";
6d7fb585	331	while (value_for_notfound->name) {
6b43b341	332	EOBOOT
	333
	334	print $xs_fh $explosives ? <<"EXPLODE" : << "DONT";
	335	SV *tripwire = newSV(0);
	336
	337	sv_magicext(tripwire, 0, PERL_MAGIC_ext, &not_defined_vtbl, 0, 0);
	338	SvPV_set(tripwire, (char *)value_for_notfound->name);
	339	if(value_for_notfound->namelen >= 0) {
	340	SvCUR_set(tripwire, value_for_notfound->namelen);
	341	} else {
	342	SvCUR_set(tripwire, -value_for_notfound->namelen);
	343	SvUTF8_on(tripwire);
	344	}
	345	SvPOKp_on(tripwire);
	346	SvREADONLY_on(tripwire);
	347	assert(SvLEN(tripwire) == 0);
	348
	349	$add_symbol_subname($athx symbol_table, value_for_notfound->name,
	350	value_for_notfound->namelen, tripwire);
	351	EXPLODE
	352
	353	/* Need to add prototypes, else parsing will vary by platform. */
	354	SV **sv = hv_fetch(symbol_table, value_for_notfound->name,
	355	value_for_notfound->namelen, TRUE);
	356	if (!sv) {
fa6eee5a	357	Perl_croak($athx
	358	"Couldn't add key '%s' to %%$package_sprintf_safe\::",
	359	value_for_notfound->name);
6b43b341	360	}
	361	if (!SvOK(sv) && SvTYPE(sv) != SVt_PVGV) {
	362	/* Nothing was here before, so mark a prototype of "" */
	363	sv_setpvn(*sv, "", 0);
	364	} else if (SvPOK(sv) && SvCUR(sv) == 0) {
	365	/* There is already a prototype of "" - do nothing */
	366	} else {
	367	/* Someone has been here before us - have to make a real
	368	typeglob. */
	369	/* It turns out to be incredibly hard to deal with all the
	370	corner cases of sub foo (); and reporting errors correctly,
	371	so lets cheat a bit. Start with a constant subroutine */
	372	CV *cv = newCONSTSUB(symbol_table, value_for_notfound->name,
	373	&PL_sv_yes);
	374	/* and then turn it into a non constant declaration only. */
aa092aa3	375	SvREFCNT_dec(CvXSUBANY(cv).any_ptr);
6b43b341	376	CvCONST_off(cv);
6b43b341	377	CvXSUB(cv) = NULL;
aa092aa3	378	CvXSUBANY(cv).any_ptr = NULL;
6b43b341	379	}
53d44271	380	#ifndef SYMBIAN
6d7fb585	381	if (!hv_store(${c_subname}_missing, value_for_notfound->name,
0998eade	382	value_for_notfound->namelen, &PL_sv_yes, 0))
64bb7586	383	Perl_croak($athx "Couldn't add key '%s' to missing_hash",
6d7fb585	384	value_for_notfound->name);
53d44271	385	#endif
6b43b341	386	DONT
	387
	388	print $xs_fh <<"EOBOOT";
	389
6d7fb585	390	++value_for_notfound;
6d7fb585	391	}
6d7fb585	392	EOBOOT
6d7fb585	393
64bb7586	394	foreach my $item (@$trouble) {
	395	my ($name, $namelen, $value, $macro)
	396	= $self->name_len_value_macro($item);
	397	my $ifdef = $self->macro_to_ifdef($macro);
	398	my $type = $item->{type};
	399	my $type_to_value = $self->type_to_C_value($type);
	400
	401	print $xs_fh $ifdef;
	402	if ($item->{invert_macro}) {
	403	print $xs_fh
	404	" /* This is the default value: */\n" if $type;
	405	print $xs_fh "#else\n";
	406	}
	407	my $generator = $type_to_sv{$type};
	408	die "Can't find generator code for type $type"
	409	unless defined $generator;
	410
6f226cd7	411	print $xs_fh " {\n";
6800c0cf	412	# We need to use a temporary value because some really troublesome
	413	# items use C pre processor directives in their values, and in turn
	414	# these don't fit nicely in the macro-ised generator functions
6f226cd7	415	my $counter = 0;
	416	printf $xs_fh " %s temp%d;\n", $_, $counter++
	417	foreach @{$type_temporary{$type}};
	418
	419	print $xs_fh " $item->{pre}\n" if $item->{pre};
	420
	421	# And because the code in pre might be both declarations and
	422	# statements, we can't declare and assign to the temporaries in one.
	423	$counter = 0;
	424	printf $xs_fh " temp%d = %s;\n", $counter++, $_
	425	foreach &$type_to_value($value);
	426
	427	my @tempvarnames = map {sprintf 'temp%d', $_} 0 .. $counter - 1;
	428	printf $xs_fh <<"EOBOOT", $name, &$generator(@tempvarnames);
2ebbb0c3	429	${c_subname}_add_symbol($athx symbol_table, "%s",
2ebbb0c3	430	$namelen, %s);
64bb7586	431	EOBOOT
2ebbb0c3	432	print $xs_fh " $item->{post}\n" if $item->{post};
2ebbb0c3	433	print $xs_fh " }\n";
64bb7586	434
	435	print $xs_fh $self->macro_to_endif($macro);
	436	}
	437
6b43b341	438	print $xs_fh <<EOBOOT;
e1234d8e	439	/* As we've been creating subroutines, we better invalidate any cached
	440	methods */
	441	++PL_sub_generation;
64bb7586	442	}
6b43b341	443	EOBOOT
	444
	445	print $xs_fh $explosives ? <<"EXPLODE" : <<"DONT";
	446
	447	void
	448	$xs_subname(sv)
	449	INPUT:
	450	SV * sv;
	451	PPCODE:
fa6eee5a	452	sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf
6b43b341	453	", used", sv);
	454	PUSHs(sv_2mortal(sv));
	455	EXPLODE
6d7fb585	456
	457	void
	458	$xs_subname(sv)
	459	PREINIT:
	460	STRLEN len;
	461	INPUT:
	462	SV * sv;
	463	const char * s = SvPV(sv, len);
	464	PPCODE:
53d44271	465	#ifdef SYMBIAN
	466	sv = newSVpvf("%"SVf" is not a valid $package_sprintf_safe macro", sv);
	467	#else
67a86ef3	468	HV *${c_subname}_missing = get_hv("${c_subname}_M!55!NG", FALSE);
bb7a0f54	469	if (hv_exists(${c_subname}_missing, s, SvUTF8(sv) ? -(I32)len : (I32)len)) {
fa6eee5a	470	sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf
6d7fb585	471	", used", sv);
6d7fb585	472	} else {
fa6eee5a	473	sv = newSVpvf("%"SVf" is not a valid $package_sprintf_safe macro",
fa6eee5a	474	sv);
6d7fb585	475	}
53d44271	476	#endif
53d44271	477	PUSHs(sv_2mortal(sv));
6b43b341	478	DONT
6b43b341	479
6d7fb585	480	}
	481
	482	1;