Initial Commit
This commit is contained in:
Riley Schneider
1019
database/perl/lib/ExtUtils/Constant/Base.pm
Normal file
1019
database/perl/lib/ExtUtils/Constant/Base.pm
Normal file
File diff suppressed because it is too large
Load Diff
682
database/perl/lib/ExtUtils/Constant/ProxySubs.pm
Normal file
682
database/perl/lib/ExtUtils/Constant/ProxySubs.pm
Normal file
@@ -0,0 +1,682 @@
|
||||
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.09';
|
||||
@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, $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);
|
||||
av_push(push, newSVhek(HeKEY_hek(he)));
|
||||
++$iterator;
|
||||
}
|
||||
EOBOOT
|
||||
} else {
|
||||
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, $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 it requires Perl_caller_cx
|
||||
carp ("PROXYSUBS option 'croak_on_error' requires v5.13.5 or later")
|
||||
if $croak_on_error && $^V < v5.13.5;
|
||||
# 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 option 'push' requires v5.10 or later")
|
||||
if $push && !$can_do_pcs;
|
||||
# Until someone patches this (with test cases)
|
||||
carp ("PROXYSUBS options 'push' and 'croak_on_read' cannot be used together")
|
||||
if $explosives && $push;
|
||||
|
||||
# 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) . '::';
|
||||
$push = C_stringify($package . '::' . $push) if $push;
|
||||
my $cast_CONSTSUB = $] < 5.010 ? '(char *)' : '';
|
||||
|
||||
print $c_fh $self->header();
|
||||
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';
|
||||
if (namelen == namelen) {
|
||||
EO_NOPCS
|
||||
} else {
|
||||
print $c_fh <<"EO_PCS";
|
||||
HE *he = (HE*) hv_common_key_len(hash, name, namelen, HV_FETCH_LVALUE, NULL,
|
||||
0);
|
||||
SV *sv;
|
||||
|
||||
if (!he) {
|
||||
croak("Couldn't add key '%s' to %%$package_sprintf_safe\::",
|
||||
name);
|
||||
}
|
||||
sv = HeVAL(he);
|
||||
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;\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 */
|
||||
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:
|
||||
{
|
||||
#if defined(dTHX) && !defined(PERL_NO_GET_CONTEXT)
|
||||
dTHX;
|
||||
#endif
|
||||
HV *symbol_table = get_hv("$symbol_table", GV_ADD);
|
||||
EOBOOT
|
||||
if ($push) {
|
||||
print $xs_fh <<"EOC";
|
||||
AV *push = get_av(\"$push\", GV_ADD);
|
||||
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;\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;
|
||||
}
|
||||
print $struct_fh " { ", join (', ', "\"$name\"", $namelen,
|
||||
&$type_to_value($value)),
|
||||
" },\n",
|
||||
$self->macro_to_endif($macro);
|
||||
}
|
||||
|
||||
# Terminate the list with a NULL
|
||||
print $struct_fh " { NULL, 0", (", 0" x $number_of_args), " } };\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) {
|
||||
#ifndef SYMBIAN
|
||||
HV *const ${c_subname}_missing = get_missing_hash(aTHX);
|
||||
#endif
|
||||
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
|
||||
|
||||
/* Need to add prototypes, else parsing will vary by platform. */
|
||||
HE *he = (HE*) hv_common_key_len(symbol_table,
|
||||
value_for_notfound->name,
|
||||
value_for_notfound->namelen,
|
||||
HV_FETCH_LVALUE, NULL, 0);
|
||||
SV *sv;
|
||||
#ifndef SYMBIAN
|
||||
HEK *hek;
|
||||
#endif
|
||||
if (!he) {
|
||||
croak("Couldn't add key '%s' to %%$package_sprintf_safe\::",
|
||||
value_for_notfound->name);
|
||||
}
|
||||
sv = HeVAL(he);
|
||||
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,
|
||||
${cast_CONSTSUB}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
|
||||
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)))
|
||||
croak("Couldn't add key '%s' to missing_hash",
|
||||
value_for_notfound->name);
|
||||
#endif
|
||||
DONT
|
||||
|
||||
print $xs_fh " av_push(push, newSVhek(hek));\n"
|
||||
if $push;
|
||||
|
||||
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 <<EOBOOT;
|
||||
/* As we've been creating subroutines, we better invalidate any cached
|
||||
methods */
|
||||
mro_method_changed_in(symbol_table);
|
||||
}
|
||||
EOBOOT
|
||||
} else {
|
||||
print $xs_fh <<EOBOOT;
|
||||
/* 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:
|
||||
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;
|
||||
EOC
|
||||
|
||||
void
|
||||
AUTOLOAD()
|
||||
PROTOTYPE: DISABLE
|
||||
PREINIT:
|
||||
SV *sv = newSVpvn_flags(SvPVX(cv), SvCUR(cv), SVs_TEMP | SvUTF8(cv));
|
||||
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) {
|
||||
sv = newSVpvf("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
|
||||
{
|
||||
sv = newSVpvf("%" SVf
|
||||
" is not a valid $package_sprintf_safe macro at %"
|
||||
COP_FILE_F " line %" UVuf "\\n",
|
||||
sv, COP_FILE(cop), (UV)CopLINE(cop));
|
||||
}
|
||||
croak_sv(sv_2mortal(sv));
|
||||
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;
|
||||
135
database/perl/lib/ExtUtils/Constant/Utils.pm
Normal file
135
database/perl/lib/ExtUtils/Constant/Utils.pm
Normal file
@@ -0,0 +1,135 @@
|
||||
package ExtUtils::Constant::Utils;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION @EXPORT_OK @ISA);
|
||||
use Carp;
|
||||
|
||||
@ISA = 'Exporter';
|
||||
@EXPORT_OK = qw(C_stringify perl_stringify);
|
||||
$VERSION = '0.04';
|
||||
|
||||
use constant is_perl55 => ($] < 5.005_50);
|
||||
use constant is_perl56 => ($] < 5.007 && $] > 5.005_50);
|
||||
use constant is_sane_perl => $] > 5.007;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
ExtUtils::Constant::Utils - helper functions for ExtUtils::Constant
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use ExtUtils::Constant::Utils qw (C_stringify);
|
||||
$C_code = C_stringify $stuff;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
ExtUtils::Constant::Utils packages up utility subroutines used by
|
||||
ExtUtils::Constant, ExtUtils::Constant::Base and derived classes. All its
|
||||
functions are explicitly exportable.
|
||||
|
||||
=head1 USAGE
|
||||
|
||||
=over 4
|
||||
|
||||
=item C_stringify NAME
|
||||
|
||||
A function which returns a 7 bit ASCII correctly \ escaped version of the
|
||||
string passed suitable for C's "" or ''. It will die if passed Unicode
|
||||
characters.
|
||||
|
||||
=cut
|
||||
|
||||
# Hopefully make a happy C identifier.
|
||||
sub C_stringify {
|
||||
local $_ = shift;
|
||||
return unless defined $_;
|
||||
# grr 5.6.1
|
||||
confess "Wide character in '$_' intended as a C identifier"
|
||||
if tr/\0-\377// != length;
|
||||
# grr 5.6.1 more so because its regexps will break on data that happens to
|
||||
# be utf8, which includes my 8 bit test cases.
|
||||
$_ = pack 'C*', unpack 'U*', $_ . pack 'U*' if is_perl56;
|
||||
s/\\/\\\\/g;
|
||||
s/([\"\'])/\\$1/g; # Grr. fix perl mode.
|
||||
s/\n/\\n/g; # Ensure newlines don't end up in octal
|
||||
s/\r/\\r/g;
|
||||
s/\t/\\t/g;
|
||||
s/\f/\\f/g;
|
||||
s/\a/\\a/g;
|
||||
unless (is_perl55) {
|
||||
# This will elicit a warning on 5.005_03 about [: :] being reserved unless
|
||||
# I cheat
|
||||
my $cheat = '([[:^print:]])';
|
||||
|
||||
if (ord('A') == 193) { # EBCDIC has no ^\0-\177 workalike.
|
||||
s/$cheat/sprintf "\\%03o", ord $1/ge;
|
||||
} else {
|
||||
s/([^\0-\177])/sprintf "\\%03o", ord $1/ge;
|
||||
}
|
||||
|
||||
s/$cheat/sprintf "\\%03o", ord $1/ge;
|
||||
} else {
|
||||
require POSIX;
|
||||
s/([^A-Za-z0-9_])/POSIX::isprint($1) ? $1 : sprintf "\\%03o", ord $1/ge;
|
||||
}
|
||||
$_;
|
||||
}
|
||||
|
||||
=item perl_stringify NAME
|
||||
|
||||
A function which returns a 7 bit ASCII correctly \ escaped version of the
|
||||
string passed suitable for a perl "" string.
|
||||
|
||||
=cut
|
||||
|
||||
# Hopefully make a happy perl identifier.
|
||||
sub perl_stringify {
|
||||
local $_ = shift;
|
||||
return unless defined $_;
|
||||
s/\\/\\\\/g;
|
||||
s/([\"\'])/\\$1/g; # Grr. fix perl mode.
|
||||
s/\n/\\n/g; # Ensure newlines don't end up in octal
|
||||
s/\r/\\r/g;
|
||||
s/\t/\\t/g;
|
||||
s/\f/\\f/g;
|
||||
s/\a/\\a/g;
|
||||
unless (is_perl55) {
|
||||
# This will elicit a warning on 5.005_03 about [: :] being reserved unless
|
||||
# I cheat
|
||||
my $cheat = '([[:^print:]])';
|
||||
if (is_sane_perl) {
|
||||
if (ord('A') == 193) { # EBCDIC has no ^\0-\177 workalike.
|
||||
s/$cheat/sprintf "\\x{%X}", ord $1/ge;
|
||||
} else {
|
||||
s/([^\0-\177])/sprintf "\\x{%X}", ord $1/ge;
|
||||
}
|
||||
} else {
|
||||
# Grr 5.6.1. And I don't think I can use utf8; to force the regexp
|
||||
# because 5.005_03 will fail.
|
||||
# This is grim, but I also can't split on //
|
||||
my $copy;
|
||||
foreach my $index (0 .. length ($_) - 1) {
|
||||
my $char = substr ($_, $index, 1);
|
||||
$copy .= ($char le "\177") ? $char : sprintf "\\x{%X}", ord $char;
|
||||
}
|
||||
$_ = $copy;
|
||||
}
|
||||
s/$cheat/sprintf "\\%03o", ord $1/ge;
|
||||
} else {
|
||||
# Turns out "\x{}" notation only arrived with 5.6
|
||||
s/([^\0-\177])/sprintf "\\x%02X", ord $1/ge;
|
||||
require POSIX;
|
||||
s/([^A-Za-z0-9_])/POSIX::isprint($1) ? $1 : sprintf "\\%03o", ord $1/ge;
|
||||
}
|
||||
$_;
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and
|
||||
others
|
||||
259
database/perl/lib/ExtUtils/Constant/XS.pm
Normal file
259
database/perl/lib/ExtUtils/Constant/XS.pm
Normal file
@@ -0,0 +1,259 @@
|
||||
package ExtUtils::Constant::XS;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION %XS_Constant %XS_TypeSet @ISA @EXPORT_OK $is_perl56);
|
||||
use Carp;
|
||||
use ExtUtils::Constant::Utils 'perl_stringify';
|
||||
require ExtUtils::Constant::Base;
|
||||
|
||||
|
||||
@ISA = qw(ExtUtils::Constant::Base Exporter);
|
||||
@EXPORT_OK = qw(%XS_Constant %XS_TypeSet);
|
||||
|
||||
$VERSION = '0.03';
|
||||
|
||||
$is_perl56 = ($] < 5.007 && $] > 5.005_50);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
ExtUtils::Constant::XS - generate C code for XS modules' constants.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
require ExtUtils::Constant::XS;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
ExtUtils::Constant::XS overrides ExtUtils::Constant::Base to generate C
|
||||
code for XS modules' constants.
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
Nothing is documented.
|
||||
|
||||
Probably others.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and
|
||||
others
|
||||
|
||||
=cut
|
||||
|
||||
# '' is used as a flag to indicate non-ascii macro names, and hence the need
|
||||
# to pass in the utf8 on/off flag.
|
||||
%XS_Constant = (
|
||||
'' => '',
|
||||
IV => 'PUSHi(iv)',
|
||||
UV => 'PUSHu((UV)iv)',
|
||||
NV => 'PUSHn(nv)',
|
||||
PV => 'PUSHp(pv, strlen(pv))',
|
||||
PVN => 'PUSHp(pv, iv)',
|
||||
SV => 'PUSHs(sv)',
|
||||
YES => 'PUSHs(&PL_sv_yes)',
|
||||
NO => 'PUSHs(&PL_sv_no)',
|
||||
UNDEF => '', # implicit undef
|
||||
);
|
||||
|
||||
%XS_TypeSet = (
|
||||
IV => '*iv_return = ',
|
||||
UV => '*iv_return = (IV)',
|
||||
NV => '*nv_return = ',
|
||||
PV => '*pv_return = ',
|
||||
PVN => ['*pv_return = ', '*iv_return = (IV)'],
|
||||
SV => '*sv_return = ',
|
||||
YES => undef,
|
||||
NO => undef,
|
||||
UNDEF => undef,
|
||||
);
|
||||
|
||||
sub header {
|
||||
my $start = 1;
|
||||
my @lines;
|
||||
push @lines, "#define PERL_constant_NOTFOUND\t$start\n"; $start++;
|
||||
push @lines, "#define PERL_constant_NOTDEF\t$start\n"; $start++;
|
||||
foreach (sort keys %XS_Constant) {
|
||||
next if $_ eq '';
|
||||
push @lines, "#define PERL_constant_IS$_\t$start\n"; $start++;
|
||||
}
|
||||
push @lines, << 'EOT';
|
||||
|
||||
#ifndef NVTYPE
|
||||
typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */
|
||||
#endif
|
||||
#ifndef aTHX_
|
||||
#define aTHX_ /* 5.6 or later define this for threading support. */
|
||||
#endif
|
||||
#ifndef pTHX_
|
||||
#define pTHX_ /* 5.6 or later define this for threading support. */
|
||||
#endif
|
||||
EOT
|
||||
|
||||
return join '', @lines;
|
||||
}
|
||||
|
||||
sub valid_type {
|
||||
my ($self, $type) = @_;
|
||||
return exists $XS_TypeSet{$type};
|
||||
}
|
||||
|
||||
# This might actually be a return statement
|
||||
sub assignment_clause_for_type {
|
||||
my $self = shift;
|
||||
my $args = shift;
|
||||
my $type = $args->{type};
|
||||
my $typeset = $XS_TypeSet{$type};
|
||||
if (ref $typeset) {
|
||||
die "Type $type is aggregate, but only single value given"
|
||||
if @_ == 1;
|
||||
return map {"$typeset->[$_]$_[$_];"} 0 .. $#$typeset;
|
||||
} elsif (defined $typeset) {
|
||||
confess "Aggregate value given for type $type"
|
||||
if @_ > 1;
|
||||
return "$typeset$_[0];";
|
||||
}
|
||||
return ();
|
||||
}
|
||||
|
||||
sub return_statement_for_type {
|
||||
my ($self, $type) = @_;
|
||||
# In the future may pass in an options hash
|
||||
$type = $type->{type} if ref $type;
|
||||
"return PERL_constant_IS$type;";
|
||||
}
|
||||
|
||||
sub return_statement_for_notdef {
|
||||
# my ($self) = @_;
|
||||
"return PERL_constant_NOTDEF;";
|
||||
}
|
||||
|
||||
sub return_statement_for_notfound {
|
||||
# my ($self) = @_;
|
||||
"return PERL_constant_NOTFOUND;";
|
||||
}
|
||||
|
||||
sub default_type {
|
||||
'IV';
|
||||
}
|
||||
|
||||
sub macro_from_name {
|
||||
my ($self, $item) = @_;
|
||||
my $macro = $item->{name};
|
||||
$macro = $item->{value} unless defined $macro;
|
||||
$macro;
|
||||
}
|
||||
|
||||
sub macro_from_item {
|
||||
my ($self, $item) = @_;
|
||||
my $macro = $item->{macro};
|
||||
$macro = $self->macro_from_name($item) unless defined $macro;
|
||||
$macro;
|
||||
}
|
||||
|
||||
# Keep to the traditional perl source macro
|
||||
sub memEQ {
|
||||
"memEQ";
|
||||
}
|
||||
|
||||
sub params {
|
||||
my ($self, $what) = @_;
|
||||
foreach (sort keys %$what) {
|
||||
warn "ExtUtils::Constant doesn't know how to handle values of type $_" unless defined $XS_Constant{$_};
|
||||
}
|
||||
my $params = {};
|
||||
$params->{''} = 1 if $what->{''};
|
||||
$params->{IV} = 1 if $what->{IV} || $what->{UV} || $what->{PVN};
|
||||
$params->{NV} = 1 if $what->{NV};
|
||||
$params->{PV} = 1 if $what->{PV} || $what->{PVN};
|
||||
$params->{SV} = 1 if $what->{SV};
|
||||
return $params;
|
||||
}
|
||||
|
||||
|
||||
sub C_constant_prefix_param {
|
||||
"aTHX_ ";
|
||||
}
|
||||
|
||||
sub C_constant_prefix_param_defintion {
|
||||
"pTHX_ ";
|
||||
}
|
||||
|
||||
sub namelen_param_definition {
|
||||
'STRLEN ' . $_[0] -> namelen_param;
|
||||
}
|
||||
|
||||
sub C_constant_other_params_defintion {
|
||||
my ($self, $params) = @_;
|
||||
my $body = '';
|
||||
$body .= ", int utf8" if $params->{''};
|
||||
$body .= ", IV *iv_return" if $params->{IV};
|
||||
$body .= ", NV *nv_return" if $params->{NV};
|
||||
$body .= ", const char **pv_return" if $params->{PV};
|
||||
$body .= ", SV **sv_return" if $params->{SV};
|
||||
$body;
|
||||
}
|
||||
|
||||
sub C_constant_other_params {
|
||||
my ($self, $params) = @_;
|
||||
my $body = '';
|
||||
$body .= ", utf8" if $params->{''};
|
||||
$body .= ", iv_return" if $params->{IV};
|
||||
$body .= ", nv_return" if $params->{NV};
|
||||
$body .= ", pv_return" if $params->{PV};
|
||||
$body .= ", sv_return" if $params->{SV};
|
||||
$body;
|
||||
}
|
||||
|
||||
sub dogfood {
|
||||
my ($self, $args, @items) = @_;
|
||||
my ($package, $subname, $default_type, $what, $indent, $breakout) =
|
||||
@{$args}{qw(package subname default_type what indent breakout)};
|
||||
my $result = <<"EOT";
|
||||
/* When generated this function returned values for the list of names given
|
||||
in this section of perl code. Rather than manually editing these functions
|
||||
to add or remove constants, which would result in this comment and section
|
||||
of code becoming inaccurate, we recommend that you edit this section of
|
||||
code, and use it to regenerate a new set of constant functions which you
|
||||
then use to replace the originals.
|
||||
|
||||
Regenerate these constant functions by feeding this entire source file to
|
||||
perl -x
|
||||
|
||||
#!$^X -w
|
||||
use ExtUtils::Constant qw (constant_types C_constant XS_constant);
|
||||
|
||||
EOT
|
||||
$result .= $self->dump_names ({default_type=>$default_type, what=>$what,
|
||||
indent=>0, declare_types=>1},
|
||||
@items);
|
||||
$result .= <<'EOT';
|
||||
|
||||
print constant_types(), "\n"; # macro defs
|
||||
EOT
|
||||
$package = perl_stringify($package);
|
||||
$result .=
|
||||
"foreach (C_constant (\"$package\", '$subname', '$default_type', \$types, ";
|
||||
# The form of the indent parameter isn't defined. (Yet)
|
||||
if (defined $indent) {
|
||||
require Data::Dumper;
|
||||
$Data::Dumper::Terse=1;
|
||||
$Data::Dumper::Terse=1; # Not used once. :-)
|
||||
chomp ($indent = Data::Dumper::Dumper ($indent));
|
||||
$result .= $indent;
|
||||
} else {
|
||||
$result .= 'undef';
|
||||
}
|
||||
$result .= ", $breakout" . ', @names) ) {
|
||||
print $_, "\n"; # C constant subs
|
||||
}
|
||||
print "\n#### XS Section:\n";
|
||||
print XS_constant ("' . $package . '", $types);
|
||||
__END__
|
||||
*/
|
||||
|
||||
';
|
||||
|
||||
$result;
|
||||
}
|
||||
|
||||
1;
|
||||
Reference in New Issue
Block a user