[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.01';
@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;}',
     YES => '{const char *name; I32 namelen;}',
     NO => '{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' },
     YES => sub {},
     NO => sub {},
     '' => sub {},
    );

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

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

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

%type_is_a_problem =
    (
     # The documentation says *mortal SV*, but we now need a non-mortal copy.
     SV => 1,
     );

$type_temporary{SV} = 'SV *';
$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_name($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_name($item);
    ($name, $namelen, $value, $macro);
}

sub WriteConstants {
    my $self = shift;
    my $ARGS = shift;

    my ($c_fh, $xs_fh, $c_subname, $xs_subname, $default_type, $package)
	= @{$ARGS}{qw(c_fh xs_fh c_subname xs_subname default_type package)};

    $xs_subname ||= 'constant';

    croak("Package name '$package' contains % characters") if $package =~ /%/;

    # 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, @_);

    # 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";
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 %%%s::", name, "$package");
    }
    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);
    }
}

static HV *${c_subname}_missing = NULL;

EOADD

    print $xs_fh <<"EOBOOT";
BOOT:
  {
#ifdef dTHX
    dTHX;
#endif
    HV *symbol_table = get_hv("$symbol_table", TRUE);
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->{''};
    foreach my $type (sort keys %$found) {
	print $xs_fh $self->boottime_iterator($type, $iterator{$type}, 
					      'symbol_table',
					      "${c_subname}_add_symbol");
    }
    print $xs_fh <<"EOBOOT";

	${c_subname}_missing = newHV();
	while (value_for_notfound->name) {
	    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);
	    ++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 <<"EOBOOT";
        {
    	    $type_temporary{$type} temp;
EOBOOT
	print $xs_fh "        $item->{pre}\n" if $item->{pre};
	# 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
	printf $xs_fh <<"EOBOOT", &$type_to_value($value), $name, &$generator('temp');
	    temp = %s;
	    ${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 <<EOCONSTANT
  }

void
$xs_subname(sv)
    PREINIT:
	STRLEN		len;
    INPUT:
	SV *		sv;
        const char *	s = SvPV(sv, len);
    PPCODE:
	if (hv_exists(${c_subname}_missing, s, SvUTF8(sv) ? -len : len)) {
	    sv = newSVpvf("Your vendor has not defined $package macro %" SVf
			  ", used", sv);
	} else {
	    sv = newSVpvf("%" SVf " is not a valid $package macro", sv);
	}
        PUSHs(sv_2mortal(sv));
EOCONSTANT
}

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
	12	$VERSION = '0.01';
	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;}',
	19	UV => '{const char *name; I32 namelen; UV value;}',
	20	YES => '{const char *name; I32 namelen;}',
	21	NO => '{const char *name; I32 namelen;}',
6d7fb585	22	'' => '{const char *name; I32 namelen;} ',
	23	);
	24
64bb7586	25	%type_from_struct =
	26	(
	27	IV => sub { $_[0] . '->value' },
	28	NV => sub { $_[0] . '->value' },
	29	UV => sub { $_[0] . '->value' },
	30	YES => sub {},
	31	NO => sub {},
	32	'' => sub {},
	33	);
	34
6d7fb585	35	%type_to_sv =
6d7fb585	36	(
64bb7586	37	IV => sub { "newSViv($_[0])" },
	38	NV => sub { "newSVnv($_[0])" },
	39	UV => sub { "newSVuv($_[0])" },
	40	YES => sub { '&PL_sv_yes' },
	41	NO => sub { '&PL_sv_no' },
6d7fb585	42	'' => sub { '&PL_sv_yes' },
2ebbb0c3	43	SV => sub {"SvREFCNT_inc($_[0])"},
6d7fb585	44	);
	45
	46	%type_to_C_value =
	47	(
64bb7586	48	YES => sub {},
64bb7586	49	NO => sub {},
6d7fb585	50	'' => sub {},
	51	);
	52
64bb7586	53	sub type_to_C_value {
	54	my ($self, $type) = @_;
	55	return $type_to_C_value{$type} \|\| sub {return map {ref $_ ? @$_ : $_} @_};
	56	}
	57
6d7fb585	58	%type_is_a_problem =
6d7fb585	59	(
2ebbb0c3	60	# The documentation says mortal SV, but we now need a non-mortal copy.
6d7fb585	61	SV => 1,
	62	);
	63
0998eade	64	$type_temporary{SV} = 'SV *';
0998eade	65	$type_temporary{$_} = $_ foreach qw(IV UV NV);
6800c0cf	66
6d7fb585	67	while (my ($type, $value) = each %XS_TypeSet) {
64bb7586	68	$type_num_args{$type}
64bb7586	69	= defined $value ? ref $value ? scalar @$value : 1 : 0;
6d7fb585	70	}
	71	$type_num_args{''} = 0;
	72
	73	sub partition_names {
	74	my ($self, $default_type, @items) = @_;
	75	my (%found, @notfound, @trouble);
	76
	77	while (my $item = shift @items) {
	78	my $default = delete $item->{default};
	79	if ($default) {
	80	# If we find a default value, convert it into a regular item and
	81	# append it to the queue of items to process
	82	my $default_item = {%$item};
	83	$default_item->{invert_macro} = 1;
	84	$default_item->{pre} = delete $item->{def_pre};
	85	$default_item->{post} = delete $item->{def_post};
	86	$default_item->{type} = shift @$default;
	87	$default_item->{value} = $default;
	88	push @items, $default_item;
	89	} else {
	90	# It can be "not found" unless it's the default (invert the macro)
	91	# or the "macro" is an empty string (ie no macro)
	92	push @notfound, $item unless $item->{invert_macro}
	93	or !$self->macro_to_ifdef($self->macro_from_name($item));
	94	}
	95
64bb7586	96	if ($item->{pre} or $item->{post} or $item->{not_constant}
64bb7586	97	or $type_is_a_problem{$item->{type}}) {
6d7fb585	98	push @trouble, $item;
	99	} else {
	100	push @{$found{$item->{type}}}, $item;
	101	}
	102	}
	103	# use Data::Dumper; print Dumper \%found;
	104	(\%found, \@notfound, \@trouble);
	105	}
	106
	107	sub boottime_iterator {
	108	my ($self, $type, $iterator, $hash, $subname) = @_;
64bb7586	109	my $extractor = $type_from_struct{$type};
	110	die "Can't find extractor code for type $type"
	111	unless defined $extractor;
6d7fb585	112	my $generator = $type_to_sv{$type};
	113	die "Can't find generator code for type $type"
	114	unless defined $generator;
	115
	116	my $athx = $self->C_constant_prefix_param();
	117
64bb7586	118	return sprintf <<"EOBOOT", &$generator(&$extractor($iterator));
6d7fb585	119	while ($iterator->name) {
	120	$subname($athx $hash, $iterator->name,
	121	$iterator->namelen, %s);
	122	++$iterator;
	123	}
	124	EOBOOT
	125	}
	126
64bb7586	127	sub name_len_value_macro {
	128	my ($self, $item) = @_;
	129	my $name = $item->{name};
	130	my $value = $item->{value};
	131	$value = $item->{name} unless defined $value;
	132
	133	my $namelen = length $name;
	134	if ($name =~ tr/\0-\377// != $namelen) {
	135	# the hash API signals UTF-8 by passing the length negated.
	136	utf8::encode($name);
	137	$namelen = -length $name;
	138	}
	139	$name = C_stringify($name);
	140
	141	my $macro = $self->macro_from_name($item);
	142	($name, $namelen, $value, $macro);
	143	}
	144
6d7fb585	145	sub WriteConstants {
	146	my $self = shift;
	147	my $ARGS = shift;
	148
	149	my ($c_fh, $xs_fh, $c_subname, $xs_subname, $default_type, $package)
	150	= @{$ARGS}{qw(c_fh xs_fh c_subname xs_subname default_type package)};
	151
	152	$xs_subname \|\|= 'constant';
	153
	154	croak("Package name '$package' contains % characters") if $package =~ /%/;
	155
	156	# All the types we see
	157	my $what = {};
	158	# A hash to lookup items with.
	159	my $items = {};
	160
	161	my @items = $self->normalise_items ({disable_utf8_duplication => 1},
	162	$default_type, $what, $items, @_);
	163
	164	# Partition the values by type. Also include any defaults in here
	165	# Everything that doesn't have a default needs alternative code for
	166	# "I'm missing"
	167	# And everything that has pre or post code ends up in a private block
	168	my ($found, $notfound, $trouble)
	169	= $self->partition_names($default_type, @items);
	170
6d7fb585	171	my $pthx = $self->C_constant_prefix_param_defintion();
	172	my $athx = $self->C_constant_prefix_param();
	173	my $symbol_table = C_stringify($package) . '::';
	174
64bb7586	175	print $c_fh $self->header(), <<"EOADD";
6d7fb585	176	void ${c_subname}_add_symbol($pthx HV hash, const char name, I32 namelen, SV *value) {
0998eade	177	SV **sv = hv_fetch(hash, name, namelen, TRUE);
	178	if (!sv) {
	179	Perl_croak($athx "Couldn't add key '%s' to %%%s::", name, "$package");
	180	}
	181	if (SvOK(sv) \|\| SvTYPE(sv) == SVt_PVGV) {
	182	/* Someone has been here before us - have to make a real sub. */
	183	newCONSTSUB(hash, name, value);
	184	} else {
	185	SvUPGRADE(*sv, SVt_RV);
	186	SvRV_set(*sv, value);
	187	SvROK_on(*sv);
6d7fb585	188	}
	189	}
	190
	191	static HV *${c_subname}_missing = NULL;
	192
	193	EOADD
	194
	195	print $xs_fh <<"EOBOOT";
	196	BOOT:
	197	{
	198	#ifdef dTHX
	199	dTHX;
	200	#endif
	201	HV *symbol_table = get_hv("$symbol_table", TRUE);
	202	EOBOOT
	203
	204	my %iterator;
	205
	206	$found->{''}
	207	= [map {{%$_, type=>'', invert_macro => 1}} @$notfound];
	208
	209	foreach my $type (sort keys %$found) {
	210	my $struct = $type_to_struct{$type};
64bb7586	211	my $type_to_value = $self->type_to_C_value($type);
6d7fb585	212	my $number_of_args = $type_num_args{$type};
	213	die "Can't find structure definition for type $type"
	214	unless defined $struct;
	215
	216	my $struct_type = $type ? lc($type) . '_s' : 'notfound_s';
	217	print $c_fh "struct $struct_type $struct;\n";
	218
	219	my $array_name = 'values_for_' . ($type ? lc $type : 'notfound');
	220	print $xs_fh <<"EOBOOT";
	221
	222	static const struct $struct_type $array_name\[] =
	223	{
	224	EOBOOT
	225
	226
	227	foreach my $item (@{$found->{$type}}) {
64bb7586	228	my ($name, $namelen, $value, $macro)
64bb7586	229	= $self->name_len_value_macro($item);
6d7fb585	230
6d7fb585	231	my $ifdef = $self->macro_to_ifdef($macro);
	232	if (!$ifdef && $item->{invert_macro}) {
	233	carp("Attempting to supply a default for '$name' which has no conditional macro");
	234	next;
	235	}
	236	print $xs_fh $ifdef;
	237	if ($item->{invert_macro}) {
	238	print $xs_fh
	239	" /* This is the default value: */\n" if $type;
	240	print $xs_fh "#else\n";
	241	}
	242	print $xs_fh " { ", join (', ', "\"$name\"", $namelen,
	243	&$type_to_value($value)), " },\n",
	244	$self->macro_to_endif($macro);
	245	}
	246
	247
	248	# Terminate the list with a NULL
	249	print $xs_fh " { NULL, 0", (", 0" x $number_of_args), " } };\n";
	250
	251	$iterator{$type} = "value_for_" . ($type ? lc $type : 'notfound');
	252
	253	print $xs_fh <<"EOBOOT";
	254	const struct $struct_type *$iterator{$type} = $array_name;
	255
	256	EOBOOT
	257	}
	258
	259	delete $found->{''};
	260	foreach my $type (sort keys %$found) {
	261	print $xs_fh $self->boottime_iterator($type, $iterator{$type},
	262	'symbol_table',
	263	"${c_subname}_add_symbol");
	264	}
	265	print $xs_fh <<"EOBOOT";
	266
	267	${c_subname}_missing = newHV();
	268	while (value_for_notfound->name) {
	269	if (!hv_store(${c_subname}_missing, value_for_notfound->name,
0998eade	270	value_for_notfound->namelen, &PL_sv_yes, 0))
64bb7586	271	Perl_croak($athx "Couldn't add key '%s' to missing_hash",
6d7fb585	272	value_for_notfound->name);
	273	++value_for_notfound;
	274	}
6d7fb585	275	EOBOOT
6d7fb585	276
64bb7586	277	foreach my $item (@$trouble) {
	278	my ($name, $namelen, $value, $macro)
	279	= $self->name_len_value_macro($item);
	280	my $ifdef = $self->macro_to_ifdef($macro);
	281	my $type = $item->{type};
	282	my $type_to_value = $self->type_to_C_value($type);
	283
	284	print $xs_fh $ifdef;
	285	if ($item->{invert_macro}) {
	286	print $xs_fh
	287	" /* This is the default value: */\n" if $type;
	288	print $xs_fh "#else\n";
	289	}
	290	my $generator = $type_to_sv{$type};
	291	die "Can't find generator code for type $type"
	292	unless defined $generator;
	293
6800c0cf	294	print $xs_fh <<"EOBOOT";
	295	{
	296	$type_temporary{$type} temp;
	297	EOBOOT
2ebbb0c3	298	print $xs_fh " $item->{pre}\n" if $item->{pre};
6800c0cf	299	# We need to use a temporary value because some really troublesome
	300	# items use C pre processor directives in their values, and in turn
	301	# these don't fit nicely in the macro-ised generator functions
	302	printf $xs_fh <<"EOBOOT", &$type_to_value($value), $name, &$generator('temp');
	303	temp = %s;
2ebbb0c3	304	${c_subname}_add_symbol($athx symbol_table, "%s",
2ebbb0c3	305	$namelen, %s);
64bb7586	306	EOBOOT
2ebbb0c3	307	print $xs_fh " $item->{post}\n" if $item->{post};
2ebbb0c3	308	print $xs_fh " }\n";
64bb7586	309
	310	print $xs_fh $self->macro_to_endif($macro);
	311	}
	312
	313	print $xs_fh <<EOCONSTANT
	314	}
6d7fb585	315
	316	void
	317	$xs_subname(sv)
	318	PREINIT:
	319	STRLEN len;
	320	INPUT:
	321	SV * sv;
	322	const char * s = SvPV(sv, len);
	323	PPCODE:
	324	if (hv_exists(${c_subname}_missing, s, SvUTF8(sv) ? -len : len)) {
	325	sv = newSVpvf("Your vendor has not defined $package macro %" SVf
	326	", used", sv);
	327	} else {
	328	sv = newSVpvf("%" SVf " is not a valid $package macro", sv);
	329	}
	330	PUSHs(sv_2mortal(sv));
	331	EOCONSTANT
	332	}
	333
	334	1;