static long sv_to_dimension(pTHX_ SV *sv, const char *member)
{
SV *warning;
const char *value = NULL;
assert(sv != NULL);
SvGETMAGIC(sv);
if (SvOK(sv) && !SvROK(sv))
{
if (looks_like_number(sv))
{
return SvIV(sv);
}
value = SvPV_nolen(sv);
}
warning = newSVpvn("", 0);
if (value) sv_catpvf(warning, " ('%s')", value);
if (member) sv_catpvf(warning, " in '%s'", member);
WARN((aTHX_ "Cannot use %s%s as dimension", identify_sv(sv), SvPV_nolen(warning)));
SvREFCNT_dec(warning);
return 0;
}
static int check_integer_option(pTHX_ const IV *options, int count, SV *sv,
IV *value, const char *name)
{
const IV *opt = options;
int n = count;
if (SvROK(sv))
{
Perl_croak(aTHX_ "%s must be an integer value, not a reference", name);
return 0;
}
*value = SvIV(sv);
while (n--)
if (*value == *opt++)
return 1;
if (name)
{
SV *str = sv_2mortal(newSVpvn("", 0));
for (n = 0; n < count; n++)
sv_catpvf(str, "%" IVdf "%s", *options++,
n < count-2 ? ", " : n == count-2 ? " or " : "");
Perl_croak(aTHX_ "%s must be %s, not %" IVdf, name, SvPV_nolen(str), *value);
}
return 0;
}
void get_basic_type_spec_string(pTHX_ SV **sv, u_32 flags)
{
struct { u_32 flag; const char *str; } *pSpec, spec[] = {
{T_SIGNED, "signed" },
{T_UNSIGNED, "unsigned"},
{T_SHORT, "short" },
{T_LONGLONG, "long" },
{T_LONG, "long" },
{T_VOID, "void" },
{T_CHAR, "char" },
{T_INT , "int" },
{T_FLOAT , "float" },
{T_DOUBLE , "double" },
{0, NULL }
};
int first = 1;
CT_DEBUG(MAIN, (XSCLASS "::get_basic_type_spec_string( sv=%p, flags=0x%08lX )",
sv, (unsigned long) flags));
for (pSpec = spec; pSpec->flag; ++pSpec)
{
if (pSpec->flag & flags)
{
if (*sv)
sv_catpvf(*sv, first ? "%s" : " %s", pSpec->str);
else
*sv = newSVpv(CONST_CHAR(pSpec->str), 0);
first = 0;
}
}
}
void decode_decimal(pTHX_ unsigned char *input, STRLEN len, struct cc_type *type, SV *output)
{
union {
unsigned char bytes[4];
int32_t scale;
} bytes_or_scale;
if (UNLIKELY(len < 5))
croak("decode_decimal: len < 5");
memcpy(bytes_or_scale.bytes, input, 4);
bswap4(bytes_or_scale.bytes);
bytes_or_scale.scale *= -1;
decode_varint(aTHX_ input+4, len-4, type, output);
if (bytes_or_scale.scale != 0) {
char *sign;
if (bytes_or_scale.scale > 0) {
sign = "+";
} else {
sign = "";
}
sv_catpvf(output, "e%s%d", sign, bytes_or_scale.scale);
}
}
SRL_STATIC_INLINE void
srl_parse_next_int(pTHX_ srl_path_t *path, int expr_idx, SV *route, IV n)
{
STRLEN route_len = SvCUR(route);
sv_catpvf(route, ";[%"UVuf"]", n); // append parsed object to route
srl_parse_next(aTHX_ path, expr_idx, route);
SvCUR_set(route, route_len); // restore original value
}
SRL_STATIC_INLINE void
srl_parse_next_str(pTHX_ srl_path_t *path, int expr_idx, SV *route,
const char *str, STRLEN len)
{
STRLEN route_len = SvCUR(route);
sv_catpvf(route, ";%.*s", (int) len, str); // append parsed object to route
srl_parse_next(aTHX_ path, expr_idx, route);
SvCUR_set(route, route_len); // restore original value
}
static AV*
S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level)
{
AV* retval;
GV** gvp;
GV* gv;
AV* isa;
const HEK* stashhek;
struct mro_meta* meta;
PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_C3;
assert(HvAUX(stash));
stashhek = HvNAME_HEK(stash);
if (!stashhek)
Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
if (level > 100)
Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
HEK_KEY(stashhek));
meta = HvMROMETA(stash);
/* return cache if valid */
if((retval = meta->mro_linear_c3)) {
return retval;
}
/* not in cache, make a new one */
gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
if ( isa && ! SvAVOK(isa) ) {
Perl_croak(aTHX_ "@ISA is not an array but %s", Ddesc((SV*)isa));
}
/* For a better idea how the rest of this works, see the much clearer
pure perl version in Algorithm::C3 0.01:
http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
(later versions go about it differently than this code for speed reasons)
*/
if(isa && AvFILLp(isa) >= 0) {
SV** seqs_ptr;
I32 seqs_items;
HV* const tails = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
AV *const seqs = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
I32* heads;
/* This builds @seqs, which is an array of arrays.
The members of @seqs are the MROs of
the members of @ISA, followed by @ISA itself.
*/
I32 items = AvFILLp(isa) + 1;
SV** isa_ptr = AvARRAY(isa);
while(items--) {
SV* const isa_item = *isa_ptr++;
if ( ! SvPVOK(isa_item) ) {
Perl_croak(aTHX_ "@ISA element which is not an plain value");
}
{
HV* const isa_item_stash = gv_stashsv(isa_item, 0);
if(!isa_item_stash) {
/* if no stash, make a temporary fake MRO
containing just itself */
AV* const isa_lin = newAV();
av_push(isa_lin, newSVsv(isa_item));
av_push(seqs, (SV*)isa_lin);
}
else {
/* recursion */
AV* const isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1);
av_push(seqs, SvREFCNT_inc_NN((SV*)isa_lin));
}
}
}
av_push(seqs, SvREFCNT_inc_NN((SV*)isa));
/* This builds "heads", which as an array of integer array
indices, one per seq, which point at the virtual "head"
of the seq (initially zero) */
Newxz(heads, AvFILLp(seqs)+1, I32);
/* This builds %tails, which has one key for every class
mentioned in the tail of any sequence in @seqs (tail meaning
everything after the first class, the "head"). The value
is how many times this key appears in the tails of @seqs.
*/
seqs_ptr = AvARRAY(seqs);
seqs_items = AvFILLp(seqs) + 1;
while(seqs_items--) {
AV *const seq = MUTABLE_AV(*seqs_ptr++);
I32 seq_items = AvFILLp(seq);
if(seq_items > 0) {
SV** seq_ptr = AvARRAY(seq) + 1;
while(seq_items--) {
SV* const seqitem = *seq_ptr++;
/* LVALUE fetch will create a new undefined SV if necessary
*/
HE* const he = hv_fetch_ent(tails, seqitem, 1, 0);
if(he) {
SV* const val = HeVAL(he);
/* This will increment undef to 1, which is what we
want for a newly created entry. */
sv_inc(val);
}
}
}
}
/* Initialize retval to build the return value in */
retval = newAV();
av_push(retval, newSVhek(stashhek)); /* us first */
/* This loop won't terminate until we either finish building
the MRO, or get an exception. */
while(1) {
SV* cand = NULL;
SV* winner = NULL;
int s;
/* "foreach $seq (@seqs)" */
SV** const avptr = AvARRAY(seqs);
for(s = 0; s <= AvFILLp(seqs); s++) {
SV** svp;
AV * const seq = MUTABLE_AV(avptr[s]);
SV* seqhead;
if(!seq) continue; /* skip empty seqs */
svp = av_fetch(seq, heads[s], 0);
seqhead = *svp; /* seqhead = head of this seq */
if(!winner) {
HE* tail_entry;
SV* val;
/* if we haven't found a winner for this round yet,
and this seqhead is not in tails (or the count
for it in tails has dropped to zero), then this
seqhead is our new winner, and is added to the
final MRO immediately */
cand = seqhead;
if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
&& (val = HeVAL(tail_entry))
&& (SvIV(val) > 0))
continue;
winner = newSVsv(cand);
av_push(retval, winner);
/* note however that even when we find a winner,
we continue looping over @seqs to do housekeeping */
}
if(!sv_cmp(seqhead, winner)) {
/* Once we have a winner (including the iteration
where we first found him), inc the head ptr
for any seq which had the winner as a head,
NULL out any seq which is now empty,
and adjust tails for consistency */
const int new_head = ++heads[s];
if(new_head > AvFILLp(seq)) {
SvREFCNT_dec(avptr[s]);
avptr[s] = NULL;
}
else {
HE* tail_entry;
SV* val;
/* Because we know this new seqhead used to be
a tail, we can assume it is in tails and has
a positive value, which we need to dec */
svp = av_fetch(seq, new_head, 0);
seqhead = *svp;
tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
val = HeVAL(tail_entry);
sv_dec(val);
}
}
}
/* if we found no candidates, we are done building the MRO.
!cand means no seqs have any entries left to check */
if(!cand) {
Safefree(heads);
break;
}
/* If we had candidates, but nobody won, then the @ISA
hierarchy is not C3-incompatible */
if(!winner) {
SV *errmsg;
I32 i;
errmsg = newSVpvf(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s':\n\t"
"current merge results [\n", HEK_KEY(stashhek));
for (i = 0; i <= av_len(retval); i++) {
SV **elem = av_fetch(retval, i, 0);
sv_catpvf(aTHX_ errmsg, "\t\t%"SVf",\n", SVfARG(*elem));
}
sv_catpvf(aTHX_ errmsg, "\t]\n\tmerging failed on '%"SVf"'", SVfARG(cand));
/* we have to do some cleanup before we croak */
AvREFCNT_dec(retval);
Safefree(heads);
croak(aTHX_ "%"SVf, SVfARG(errmsg));
}
}
}
else { /* @ISA was undefined or empty */
/* build a retval containing only ourselves */
retval = newAV();
av_push(retval, newSVhek(stashhek));
}
/* we don't want anyone modifying the cache entry but us,
and we do so by replacing it completely */
SvREADONLY_on(retval);
meta->mro_linear_c3 = retval;
return retval;
}
