[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.05';
@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

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

#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:
  {
#ifdef dTHX
    dTHX;
#endif
    HV *symbol_table = get_hv("$symbol_table", TRUE);
#ifndef SYMBIAN
    HV *${c_subname}_missing;
#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->{''};

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

    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_missing_hash(aTHX);
	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
53e0272f	12	$VERSION = '0.05';
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
26eb7f2f	245	{
	246	my $key = $symbol_table;
	247	# Just seems tidier (and slightly more space efficient) not to have keys
	248	# such as Fcntl::
	249	$key =~ s/::$//;
	250	my $key_len = length $key;
	251
	252	print $c_fh <<"MISSING";
	253
	254	#ifndef SYMBIAN
	255
	256	/* Store a hash of all symbols missing from the package. To avoid trampling on
	257	the package namespace (uninvited) put each package's hash in our namespace.
	258	To avoid creating lots of typeblogs and symbol tables for sub-packages, put
	259	each package's hash into one hash in our namespace. */
	260
	261	static HV *
	262	get_missing_hash(pTHX) {
	263	HV *const parent
	264	= get_hv("ExtUtils::Constant::ProxySubs::Missing", GVf_MULTI);
	265	/* We could make a hash of hashes directly, but this would confuse anything
	266	at Perl space that looks at us, and as we're visible in Perl space,
	267	best to play nice. */
	268	SV const const ref
	269	= hv_fetch(parent, "$key", $key_len, TRUE);
	270	HV *new_hv;
	271
	272	if (!ref)
	273	return NULL;
	274
	275	if (SvROK(*ref))
	276	return (HV) SvRV(ref);
	277
	278	new_hv = newHV();
	279	SvUPGRADE(*ref, SVt_RV);
	280	SvRV_set(ref, (SV )new_hv);
	281	SvROK_on(*ref);
	282	return new_hv;
	283	}
	284
	285	#endif
	286
	287	MISSING
	288
	289	}
	290
6d7fb585	291	print $xs_fh <<"EOBOOT";
	292	BOOT:
	293	{
	294	#ifdef dTHX
	295	dTHX;
	296	#endif
	297	HV *symbol_table = get_hv("$symbol_table", TRUE);
67a86ef3	298	#ifndef SYMBIAN
67a86ef3	299	HV *${c_subname}_missing;
67a86ef3	300	#endif
6d7fb585	301	EOBOOT
	302
	303	my %iterator;
	304
	305	$found->{''}
	306	= [map {{%$_, type=>'', invert_macro => 1}} @$notfound];
	307
	308	foreach my $type (sort keys %$found) {
	309	my $struct = $type_to_struct{$type};
64bb7586	310	my $type_to_value = $self->type_to_C_value($type);
6d7fb585	311	my $number_of_args = $type_num_args{$type};
	312	die "Can't find structure definition for type $type"
	313	unless defined $struct;
	314
	315	my $struct_type = $type ? lc($type) . '_s' : 'notfound_s';
	316	print $c_fh "struct $struct_type $struct;\n";
	317
	318	my $array_name = 'values_for_' . ($type ? lc $type : 'notfound');
	319	print $xs_fh <<"EOBOOT";
	320
	321	static const struct $struct_type $array_name\[] =
	322	{
	323	EOBOOT
	324
	325
	326	foreach my $item (@{$found->{$type}}) {
64bb7586	327	my ($name, $namelen, $value, $macro)
64bb7586	328	= $self->name_len_value_macro($item);
6d7fb585	329
6d7fb585	330	my $ifdef = $self->macro_to_ifdef($macro);
	331	if (!$ifdef && $item->{invert_macro}) {
	332	carp("Attempting to supply a default for '$name' which has no conditional macro");
	333	next;
	334	}
	335	print $xs_fh $ifdef;
	336	if ($item->{invert_macro}) {
	337	print $xs_fh
	338	" /* This is the default value: */\n" if $type;
	339	print $xs_fh "#else\n";
	340	}
	341	print $xs_fh " { ", join (', ', "\"$name\"", $namelen,
	342	&$type_to_value($value)), " },\n",
	343	$self->macro_to_endif($macro);
	344	}
	345
	346
	347	# Terminate the list with a NULL
	348	print $xs_fh " { NULL, 0", (", 0" x $number_of_args), " } };\n";
	349
	350	$iterator{$type} = "value_for_" . ($type ? lc $type : 'notfound');
	351
	352	print $xs_fh <<"EOBOOT";
	353	const struct $struct_type *$iterator{$type} = $array_name;
6d7fb585	354	EOBOOT
	355	}
	356
	357	delete $found->{''};
6b43b341	358
53e0272f	359	print $xs_fh <<"EOBOOT";
53e0272f	360	#ifndef SYMBIAN
26eb7f2f	361	${c_subname}_missing = get_missing_hash(aTHX);
53e0272f	362	#endif
	363	EOBOOT
	364
6b43b341	365	my $add_symbol_subname = $c_subname . '_add_symbol';
6d7fb585	366	foreach my $type (sort keys %$found) {
	367	print $xs_fh $self->boottime_iterator($type, $iterator{$type},
	368	'symbol_table',
6b43b341	369	$add_symbol_subname);
6d7fb585	370	}
6b43b341	371
6b43b341	372	print $xs_fh <<"EOBOOT";
6d7fb585	373	while (value_for_notfound->name) {
6b43b341	374	EOBOOT
	375
	376	print $xs_fh $explosives ? <<"EXPLODE" : << "DONT";
	377	SV *tripwire = newSV(0);
	378
	379	sv_magicext(tripwire, 0, PERL_MAGIC_ext, &not_defined_vtbl, 0, 0);
	380	SvPV_set(tripwire, (char *)value_for_notfound->name);
	381	if(value_for_notfound->namelen >= 0) {
	382	SvCUR_set(tripwire, value_for_notfound->namelen);
	383	} else {
	384	SvCUR_set(tripwire, -value_for_notfound->namelen);
	385	SvUTF8_on(tripwire);
	386	}
	387	SvPOKp_on(tripwire);
	388	SvREADONLY_on(tripwire);
	389	assert(SvLEN(tripwire) == 0);
	390
	391	$add_symbol_subname($athx symbol_table, value_for_notfound->name,
	392	value_for_notfound->namelen, tripwire);
	393	EXPLODE
	394
	395	/* Need to add prototypes, else parsing will vary by platform. */
	396	SV **sv = hv_fetch(symbol_table, value_for_notfound->name,
	397	value_for_notfound->namelen, TRUE);
	398	if (!sv) {
fa6eee5a	399	Perl_croak($athx
	400	"Couldn't add key '%s' to %%$package_sprintf_safe\::",
	401	value_for_notfound->name);
6b43b341	402	}
	403	if (!SvOK(sv) && SvTYPE(sv) != SVt_PVGV) {
	404	/* Nothing was here before, so mark a prototype of "" */
	405	sv_setpvn(*sv, "", 0);
	406	} else if (SvPOK(sv) && SvCUR(sv) == 0) {
	407	/* There is already a prototype of "" - do nothing */
	408	} else {
	409	/* Someone has been here before us - have to make a real
	410	typeglob. */
	411	/* It turns out to be incredibly hard to deal with all the
	412	corner cases of sub foo (); and reporting errors correctly,
	413	so lets cheat a bit. Start with a constant subroutine */
	414	CV *cv = newCONSTSUB(symbol_table, value_for_notfound->name,
	415	&PL_sv_yes);
	416	/* and then turn it into a non constant declaration only. */
aa092aa3	417	SvREFCNT_dec(CvXSUBANY(cv).any_ptr);
6b43b341	418	CvCONST_off(cv);
6b43b341	419	CvXSUB(cv) = NULL;
aa092aa3	420	CvXSUBANY(cv).any_ptr = NULL;
6b43b341	421	}
53d44271	422	#ifndef SYMBIAN
6d7fb585	423	if (!hv_store(${c_subname}_missing, value_for_notfound->name,
0998eade	424	value_for_notfound->namelen, &PL_sv_yes, 0))
64bb7586	425	Perl_croak($athx "Couldn't add key '%s' to missing_hash",
6d7fb585	426	value_for_notfound->name);
53d44271	427	#endif
6b43b341	428	DONT
	429
	430	print $xs_fh <<"EOBOOT";
	431
6d7fb585	432	++value_for_notfound;
6d7fb585	433	}
6d7fb585	434	EOBOOT
6d7fb585	435
64bb7586	436	foreach my $item (@$trouble) {
	437	my ($name, $namelen, $value, $macro)
	438	= $self->name_len_value_macro($item);
	439	my $ifdef = $self->macro_to_ifdef($macro);
	440	my $type = $item->{type};
	441	my $type_to_value = $self->type_to_C_value($type);
	442
	443	print $xs_fh $ifdef;
	444	if ($item->{invert_macro}) {
	445	print $xs_fh
	446	" /* This is the default value: */\n" if $type;
	447	print $xs_fh "#else\n";
	448	}
	449	my $generator = $type_to_sv{$type};
	450	die "Can't find generator code for type $type"
	451	unless defined $generator;
	452
6f226cd7	453	print $xs_fh " {\n";
6800c0cf	454	# We need to use a temporary value because some really troublesome
	455	# items use C pre processor directives in their values, and in turn
	456	# these don't fit nicely in the macro-ised generator functions
6f226cd7	457	my $counter = 0;
	458	printf $xs_fh " %s temp%d;\n", $_, $counter++
	459	foreach @{$type_temporary{$type}};
	460
	461	print $xs_fh " $item->{pre}\n" if $item->{pre};
	462
	463	# And because the code in pre might be both declarations and
	464	# statements, we can't declare and assign to the temporaries in one.
	465	$counter = 0;
	466	printf $xs_fh " temp%d = %s;\n", $counter++, $_
	467	foreach &$type_to_value($value);
	468
	469	my @tempvarnames = map {sprintf 'temp%d', $_} 0 .. $counter - 1;
	470	printf $xs_fh <<"EOBOOT", $name, &$generator(@tempvarnames);
2ebbb0c3	471	${c_subname}_add_symbol($athx symbol_table, "%s",
2ebbb0c3	472	$namelen, %s);
64bb7586	473	EOBOOT
2ebbb0c3	474	print $xs_fh " $item->{post}\n" if $item->{post};
2ebbb0c3	475	print $xs_fh " }\n";
64bb7586	476
	477	print $xs_fh $self->macro_to_endif($macro);
	478	}
	479
6b43b341	480	print $xs_fh <<EOBOOT;
e1234d8e	481	/* As we've been creating subroutines, we better invalidate any cached
	482	methods */
	483	++PL_sub_generation;
64bb7586	484	}
6b43b341	485	EOBOOT
	486
	487	print $xs_fh $explosives ? <<"EXPLODE" : <<"DONT";
	488
	489	void
	490	$xs_subname(sv)
	491	INPUT:
	492	SV * sv;
	493	PPCODE:
fa6eee5a	494	sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf
6b43b341	495	", used", sv);
	496	PUSHs(sv_2mortal(sv));
	497	EXPLODE
6d7fb585	498
	499	void
	500	$xs_subname(sv)
	501	PREINIT:
	502	STRLEN len;
	503	INPUT:
	504	SV * sv;
	505	const char * s = SvPV(sv, len);
	506	PPCODE:
53d44271	507	#ifdef SYMBIAN
	508	sv = newSVpvf("%"SVf" is not a valid $package_sprintf_safe macro", sv);
	509	#else
26eb7f2f	510	HV *${c_subname}_missing = get_missing_hash(aTHX);
bb7a0f54	511	if (hv_exists(${c_subname}_missing, s, SvUTF8(sv) ? -(I32)len : (I32)len)) {
fa6eee5a	512	sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf
6d7fb585	513	", used", sv);
6d7fb585	514	} else {
fa6eee5a	515	sv = newSVpvf("%"SVf" is not a valid $package_sprintf_safe macro",
fa6eee5a	516	sv);
6d7fb585	517	}
53d44271	518	#endif
53d44271	519	PUSHs(sv_2mortal(sv));
6b43b341	520	DONT
6b43b341	521
6d7fb585	522	}
	523
	524	1;