/* Builds the C-level configuration and state struct.
* Automatically freed at scope boundary. */
ddl_encoder_t *
build_encoder_struct(pTHX_ HV *opt)
{
ddl_encoder_t *enc;
SV **svp;
Newx(enc, 1, ddl_encoder_t);
/* Register our structure for destruction on scope exit */
SAVEDESTRUCTOR(&ddl_destructor_hook, (void *)enc);
/* Init struct */
Newx(enc->buf_start, INITIALIZATION_SIZE, char);
enc->buf_end = enc->buf_start + INITIALIZATION_SIZE;
enc->pos = enc->buf_start;
enc->depth = 0;
enc->flags = 0;
/* TODO: We could do this lazily: Only if there's references with high refcount/weakrefs */
enc->seenhash = PTABLE_new();
/* load options */
if (opt != NULL) {
if ( (svp = hv_fetchs(opt, "undef_blessed", 0)) && SvTRUE(*svp))
enc->flags |= F_UNDEF_BLESSED;
if ( (svp = hv_fetchs(opt, "disallow_multi", 0)) && SvTRUE(*svp))
enc->flags |= F_DISALLOW_MULTI_OCCURRENCE;
if ( (svp = hv_fetchs(opt, "objects_as_unblessed", 0)) && SvTRUE(*svp))
enc->flags |= F_DUMP_OBJECTS_AS_UNBLESSED;
if ( (svp = hv_fetchs(opt, "dump_objects", 0)) && SvTRUE(*svp))
enc->flags |= F_DUMP_OBJECTS_AS_BLESSED;
}
/* option vlaidation */
/* FIXME my bit field fu is weak, apparently. Needs replacing with proper idiom */
if ( (enc->flags & F_UNDEF_BLESSED ? 1 : 0)
+ (enc->flags & F_DUMP_OBJECTS_AS_UNBLESSED ? 1 : 0)
+ (enc->flags & F_DUMP_OBJECTS_AS_BLESSED ? 1 : 0)
> 1)
{
croak("Can only have one of 'undef_blessed', "
"'objects_as_unblessed', and 'dump_objects' options at a time.");
}
return enc;
}
void tmh_cb_hrule(hoedown_buffer *ob, const hoedown_renderer_data *data) {
dTHX; dSP; bool is_null = 0;
SV** rcb = hv_fetchs((HV*)data->opaque, "hrule", 0);
if (!rcb) { return; }
CB_HEADER("hrule");
CB_FOOTER;
}
int tmh_cb_linebreak(hoedown_buffer *ob, const hoedown_renderer_data *data) {
dTHX; dSP; bool is_null = 0;
SV** rcb = hv_fetchs((HV*)data->opaque, "linebreak", 0);
if (!rcb) { return 0; }
CB_HEADER("linebreak");
CB_FOOTER;
return is_null ? 0 : 1;
}
void tmh_cb_doc_footer(hoedown_buffer *ob, int inline_render, const hoedown_renderer_data *data) {
dTHX; dSP; bool is_null = 0;
SV** rcb = hv_fetchs((HV*)data->opaque, "doc_footer", 0);
if (!rcb) { return; }
CB_HEADER("doc_footer");
mXPUSHi(inline_render);
CB_FOOTER;
}
void tmh_cb_footnotes(hoedown_buffer *ob, const hoedown_buffer *content, const hoedown_renderer_data *data) {
dTHX; dSP; bool is_null = 0;
SV** rcb = hv_fetchs((HV*)data->opaque, "footnotes", 0);
if (!rcb) { return; }
CB_HEADER("footnotes");
PUSHBUF(content);
CB_FOOTER;
}
void tmh_cb_paragraph(hoedown_buffer *ob, const hoedown_buffer *text, const hoedown_renderer_data *data) {
dTHX; dSP; bool is_null = 0;
SV** rcb = hv_fetchs((HV*)data->opaque, "paragraph", 0);
if (!rcb) { return; }
CB_HEADER("paragraph");
PUSHBUF(text);
CB_FOOTER;
}
int p5_free_perl6_hash(pTHX_ SV* obj, MAGIC *mg)
{
if (mg) {
_perl6_hash_magic* const p6mg = (_perl6_hash_magic*) mg->mg_ptr;
/* need to be extra careful here as PL_modglobal could have been cleaned already */
SV **cbs_entry = hv_fetchs(PL_modglobal, "Inline::Perl5 callbacks", 0);
if (cbs_entry) {
perl6_callbacks *cbs = (perl6_callbacks*)SvIV(*cbs_entry);
cbs->free_p6_object(p6mg->index);
}
}
return 0;
}
void tmh_cb_entity(hoedown_buffer *ob, const hoedown_buffer *entity, const hoedown_renderer_data *data) {
dTHX; dSP; bool is_null = 0;
SV** rcb = hv_fetchs((HV*)data->opaque, "entity", 0);
if (!rcb) { return; }
CB_HEADER("entity");
PUSHBUF(entity);
CB_FOOTER;
}
void tmh_cb_table_cell(hoedown_buffer *ob, const hoedown_buffer *content, hoedown_table_flags flags, const hoedown_renderer_data *data) {
dTHX; dSP; bool is_null = 0;
SV** rcb = hv_fetchs((HV*)data->opaque, "table_cell", 0);
if (!rcb) { return; }
CB_HEADER("table_cell");
PUSHBUF(content);
mXPUSHi(flags);
CB_FOOTER;
}
void tmh_cb_blockcode(hoedown_buffer *ob, const hoedown_buffer *text, const hoedown_buffer *lang, const hoedown_renderer_data *data) {
dTHX; dSP; bool is_null = 0;
SV** rcb = hv_fetchs((HV*)data->opaque, "blockcode", 0);
if (!rcb) { return; }
CB_HEADER("blockcode");
PUSHBUF(text);
PUSHBUF(lang);
CB_FOOTER;
}
int tmh_cb_footnote_ref(hoedown_buffer *ob, unsigned int num, const hoedown_renderer_data *data) {
dTHX; dSP; bool is_null = 0;
SV** rcb = hv_fetchs((HV*)data->opaque, "footnote_ref", 0);
if (!rcb) { return 0; }
CB_HEADER("footnote_ref");
mXPUSHu(num);
CB_FOOTER;
return is_null ? 0 : 1;
}
void tmh_cb_header(hoedown_buffer *ob, const hoedown_buffer *text, int level, const hoedown_renderer_data *data) {
dTHX; dSP; bool is_null = 0;
SV** rcb = hv_fetchs((HV*)data->opaque, "header", 0);
if (!rcb) { return; }
CB_HEADER("header");
PUSHBUF(text);
mXPUSHi(level);
CB_FOOTER;
}
int tmh_cb_superscript(hoedown_buffer *ob, const hoedown_buffer *text, const hoedown_renderer_data *data) {
dTHX; dSP; bool is_null = 0;
SV** rcb = hv_fetchs((HV*)data->opaque, "superscript", 0);
if (!rcb) { return 0; }
CB_HEADER("superscript");
PUSHBUF(text);
CB_FOOTER;
return is_null ? 0 : 1;
}
void tmh_cb_listitem(hoedown_buffer *ob, const hoedown_buffer *text, hoedown_list_flags flags, const hoedown_renderer_data *data) {
dTHX; dSP; bool is_null = 0;
SV** rcb = hv_fetchs((HV*)data->opaque, "listitem", 0);
if (!rcb) { return; }
CB_HEADER("listitem");
PUSHBUF(text);
mXPUSHi(flags);
CB_FOOTER;
}
int tmh_cb_autolink(hoedown_buffer *ob, const hoedown_buffer *link, hoedown_autolink_type type, const hoedown_renderer_data *data) {
dTHX; dSP; bool is_null = 0;
SV** rcb = hv_fetchs((HV*)data->opaque, "autolink", 0);
if (!rcb) { return 0; }
CB_HEADER("autolink");
PUSHBUF(link);
mXPUSHi(type);
CB_FOOTER;
return is_null ? 0 : 1;
}
int tmh_cb_math(hoedown_buffer *ob, const hoedown_buffer *text, int displaymode, const hoedown_renderer_data *data) {
dTHX; dSP; bool is_null = 0;
SV** rcb = hv_fetchs((HV*)data->opaque, "math", 0);
if (!rcb) { return 0; }
CB_HEADER("math");
PUSHBUF(text);
mXPUSHi(displaymode);
CB_FOOTER;
return is_null ? 0 : 1;
}
int tmh_cb_link(hoedown_buffer *ob, const hoedown_buffer *content, const hoedown_buffer *link, const hoedown_buffer *title, const hoedown_renderer_data *data) {
dTHX; dSP; bool is_null = 0;
SV** rcb = hv_fetchs((HV*)data->opaque, "link", 0);
if (!rcb) { return 0; }
CB_HEADER("link");
PUSHBUF(content);
PUSHBUF(link);
PUSHBUF(title);
CB_FOOTER;
return is_null ? 0 : 1;
}
void
math_int64_boot(pTHX_ int version) {
dSP;
SV **svp;
eval_pv("require Math::Int64", TRUE);
if (SvTRUE(ERRSV))
Perl_croak(aTHX_ "Unable to load Math::Int64: %s", SvPV_nolen(ERRSV));
math_int64_capi_hash = get_hv("Math::Int64::C_API", 0);
if (!math_int64_capi_hash) Perl_croak(aTHX_ "Unable to load Math::Int64 C API");
math_int64_capi_version = SvIV(*hv_fetchs(math_int64_capi_hash, "version", 1));
if (math_int64_capi_version < version)
Perl_croak(aTHX_ "Math::Int64 C API version mismatch, expected %d, found %d",
version, math_int64_capi_version);
fetch_ptr(math_int64_capi_newSVi64, "newSVi64");
fetch_ptr(math_int64_capi_newSVu64, "newSVu64");
fetch_ptr(math_int64_capi_SvI64, "SvI64");
fetch_ptr(math_int64_capi_SvU64, "SvU64");
fetch_ptr(math_int64_capi_SvI64OK, "SvI64OK");
fetch_ptr(math_int64_capi_SvU64OK, "SvU64OK");
}
/* Builds the C-level configuration and state struct.
* Automatically freed at scope boundary. */
srl_decoder_t *
srl_build_decoder_struct(pTHX_ HV *opt)
{
srl_decoder_t *dec;
SV **svp;
Newxz(dec, 1, srl_decoder_t);
dec->ref_seenhash = PTABLE_new();
dec->max_recursion_depth = DEFAULT_MAX_RECUR_DEPTH;
dec->max_num_hash_entries = 0; /* 0 == any number */
/* load options */
if (opt != NULL) {
if ( (svp = hv_fetchs(opt, "refuse_snappy", 0)) && SvTRUE(*svp))
SRL_DEC_SET_OPTION(dec, SRL_F_DECODER_REFUSE_SNAPPY);
if ( (svp = hv_fetchs(opt, "refuse_objects", 0)) && SvTRUE(*svp))
SRL_DEC_SET_OPTION(dec, SRL_F_DECODER_REFUSE_OBJECTS);
if ( (svp = hv_fetchs(opt, "no_bless_objects", 0)) && SvTRUE(*svp))
SRL_DEC_SET_OPTION(dec, SRL_F_DECODER_NO_BLESS_OBJECTS);
if ( (svp = hv_fetchs(opt, "validate_utf8", 0)) && SvTRUE(*svp))
SRL_DEC_SET_OPTION(dec, SRL_F_DECODER_VALIDATE_UTF8);
if ( (svp = hv_fetchs(opt, "max_recursion_depth", 0)) && SvTRUE(*svp))
dec->max_recursion_depth = SvUV(*svp);
if ( (svp = hv_fetchs(opt, "max_num_hash_entries", 0)) && SvTRUE(*svp))
dec->max_num_hash_entries = SvUV(*svp);
if ( (svp = hv_fetchs(opt, "incremental", 0)) && SvTRUE(*svp))
SRL_DEC_SET_OPTION(dec,SRL_F_DECODER_DESTRUCTIVE_INCREMENTAL);
}
return dec;
}
/*
=for apidoc mro_get_linear_isa_dfs
Returns the Depth-First Search linearization of C<@ISA>
the given stash. The return value is a read-only AV*.
C<level> should be 0 (it is used internally in this
function's recursion).
You are responsible for C<SvREFCNT_inc()> on the
return value if you plan to store it anywhere
semi-permanently (otherwise it might be deleted
out from under you the next time the cache is
invalidated).
=cut
*/
static AV*
S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
{
AV* retval;
GV** gvp;
GV* gv;
AV* av;
const HEK* stashhek;
struct mro_meta* meta;
SV *our_name;
HV *stored = NULL;
PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
assert(HvAUX(stash));
stashhek
= HvAUX(stash)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(stash)
? HvENAME_HEK_NN(stash)
: 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 '%"HEKf"'",
HEKfARG(stashhek));
meta = HvMROMETA(stash);
/* return cache if valid */
if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) {
return retval;
}
/* not in cache, make a new one */
retval = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
/* We use this later in this function, but don't need a reference to it
beyond the end of this function, so reference count is fine. */
our_name = newSVhek(stashhek);
av_push(retval, our_name); /* add ourselves at the top */
/* fetch our @ISA */
gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
/* "stored" is used to keep track of all of the classnames we have added to
the MRO so far, so we can do a quick exists check and avoid adding
duplicate classnames to the MRO as we go.
It's then retained to be re-used as a fast lookup for ->isa(), by adding
our own name and "UNIVERSAL" to it. */
if(av && AvFILLp(av) >= 0) {
SV **svp = AvARRAY(av);
I32 items = AvFILLp(av) + 1;
/* foreach(@ISA) */
while (items--) {
SV* const sv = *svp ? *svp : &PL_sv_undef;
HV* const basestash = gv_stashsv(sv, 0);
SV *const *subrv_p;
I32 subrv_items;
svp++;
if (!basestash) {
/* if no stash exists for this @ISA member,
simply add it to the MRO and move on */
subrv_p = &sv;
subrv_items = 1;
}
else {
/* otherwise, recurse into ourselves for the MRO
of this @ISA member, and append their MRO to ours.
The recursive call could throw an exception, which
has memory management implications here, hence the use of
the mortal. */
const AV *const subrv
= mro_get_linear_isa_dfs(basestash, level + 1);
subrv_p = AvARRAY(subrv);
subrv_items = AvFILLp(subrv) + 1;
}
if (stored) {
while(subrv_items--) {
SV *const subsv = *subrv_p++;
/* LVALUE fetch will create a new undefined SV if necessary
*/
HE *const he = hv_fetch_ent(stored, subsv, 1, 0);
assert(he);
if(HeVAL(he) != &PL_sv_undef) {
/* It was newly created. Steal it for our new SV, and
replace it in the hash with the "real" thing. */
SV *const val = HeVAL(he);
HEK *const key = HeKEY_hek(he);
HeVAL(he) = &PL_sv_undef;
sv_sethek(val, key);
av_push(retval, val);
}
}
} else {
/* We are the first (or only) parent. We can short cut the
complexity above, because our @ISA is simply us prepended
to our parent's @ISA, and our ->isa cache is simply our
parent's, with our name added. */
/* newSVsv() is slow. This code is only faster if we can avoid
it by ensuring that SVs in the arrays are shared hash key
scalar SVs, because we can "copy" them very efficiently.
Although to be fair, we can't *ensure* this, as a reference
to the internal array is returned by mro::get_linear_isa(),
so we'll have to be defensive just in case someone faffed
with it. */
if (basestash) {
SV **svp;
stored = MUTABLE_HV(sv_2mortal((SV*)newHVhv(HvMROMETA(basestash)->isa)));
av_extend(retval, subrv_items);
AvFILLp(retval) = subrv_items;
svp = AvARRAY(retval);
while(subrv_items--) {
SV *const val = *subrv_p++;
*++svp = SvIsCOW_shared_hash(val)
? newSVhek(SvSHARED_HEK_FROM_PV(SvPVX(val)))
: newSVsv(val);
}
} else {
/* They have no stash. So create ourselves an ->isa cache
as if we'd copied it from what theirs should be. */
stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
(void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
av_push(retval,
newSVhek(HeKEY_hek(hv_store_ent(stored, sv,
&PL_sv_undef, 0))));
}
}
}
} else {
/* We have no parents. */
stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
(void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
}
(void) hv_store_ent(stored, our_name, &PL_sv_undef, 0);
SvREFCNT_inc_simple_void_NN(stored);
SvTEMP_off(stored);
SvREADONLY_on(stored);
meta->isa = stored;
/* now that we're past the exception dangers, grab our own reference to
the AV we're about to use for the result. The reference owned by the
mortals' stack will be released soon, so everything will balance. */
SvREFCNT_inc_simple_void_NN(retval);
SvTEMP_off(retval);
/* we don't want anyone modifying the cache entry but us,
and we do so by replacing it completely */
SvREADONLY_on(retval);
return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg,
MUTABLE_SV(retval)));
}
/*
=for apidoc mro_get_linear_isa_dfs
Returns the Depth-First Search linearization of @ISA
the given stash. The return value is a read-only AV*.
C<level> should be 0 (it is used internally in this
function's recursion).
You are responsible for C<SvREFCNT_inc()> on the
return value if you plan to store it anywhere
semi-permanently (otherwise it might be deleted
out from under you the next time the cache is
invalidated).
=cut
*/
static AV*
S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
{
AV* retval;
GV** gvp;
GV* gv;
AV* av;
const HEK* stashhek;
struct mro_meta* meta;
SV *our_name;
HV *stored;
PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
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 = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) {
return retval;
}
/* not in cache, make a new one */
retval = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
/* We use this later in this function, but don't need a reference to it
beyond the end of this function, so reference count is fine. */
our_name = newSVhek(stashhek);
av_push(retval, our_name); /* add ourselves at the top */
/* fetch our @ISA */
gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
/* "stored" is used to keep track of all of the classnames we have added to
the MRO so far, so we can do a quick exists check and avoid adding
duplicate classnames to the MRO as we go.
It's then retained to be re-used as a fast lookup for ->isa(), by adding
our own name and "UNIVERSAL" to it. */
stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
if(av && AvFILLp(av) >= 0) {
SV **svp = AvARRAY(av);
I32 items = AvFILLp(av) + 1;
/* foreach(@ISA) */
while (items--) {
SV* const sv = *svp++;
HV* const basestash = gv_stashsv(sv, 0);
SV *const *subrv_p;
I32 subrv_items;
if (!basestash) {
/* if no stash exists for this @ISA member,
simply add it to the MRO and move on */
subrv_p = &sv;
subrv_items = 1;
}
else {
/* otherwise, recurse into ourselves for the MRO
of this @ISA member, and append their MRO to ours.
The recursive call could throw an exception, which
has memory management implications here, hence the use of
the mortal. */
const AV *const subrv
= mro_get_linear_isa_dfs(basestash, level + 1);
subrv_p = AvARRAY(subrv);
subrv_items = AvFILLp(subrv) + 1;
}
while(subrv_items--) {
SV *const subsv = *subrv_p++;
/* LVALUE fetch will create a new undefined SV if necessary
*/
HE *const he = hv_fetch_ent(stored, subsv, 1, 0);
assert(he);
if(HeVAL(he) != &PL_sv_undef) {
/* It was newly created. Steal it for our new SV, and
replace it in the hash with the "real" thing. */
SV *const val = HeVAL(he);
HEK *const key = HeKEY_hek(he);
HeVAL(he) = &PL_sv_undef;
/* Save copying by making a shared hash key scalar. We
inline this here rather than calling Perl_newSVpvn_share
because we already have the scalar, and we already have
the hash key. */
assert(SvTYPE(val) == SVt_NULL);
sv_upgrade(val, SVt_PV);
SvPV_set(val, HEK_KEY(share_hek_hek(key)));
SvCUR_set(val, HEK_LEN(key));
SvREADONLY_on(val);
SvFAKE_on(val);
SvPOK_on(val);
if (HEK_UTF8(key))
SvUTF8_on(val);
av_push(retval, val);
}
}
}
}
(void) hv_store_ent(stored, our_name, &PL_sv_undef, 0);
(void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
SvREFCNT_inc_simple_void_NN(stored);
SvTEMP_off(stored);
SvREADONLY_on(stored);
meta->isa = stored;
/* now that we're past the exception dangers, grab our own reference to
the AV we're about to use for the result. The reference owned by the
mortals' stack will be released soon, so everything will balance. */
SvREFCNT_inc_simple_void_NN(retval);
SvTEMP_off(retval);
/* we don't want anyone modifying the cache entry but us,
and we do so by replacing it completely */
SvREADONLY_on(retval);
return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg,
MUTABLE_SV(retval)));
}
void
Perl_taint_env(pTHX)
{
dVAR;
SV** svp;
MAGIC* mg;
const char* const *e;
static const char* const misc_env[] = {
"IFS", /* most shells' inter-field separators */
"CDPATH", /* ksh dain bramage #1 */
"ENV", /* ksh dain bramage #2 */
"BASH_ENV", /* bash dain bramage -- I guess it's contagious */
#ifdef WIN32
"PERL5SHELL", /* used for system() on Windows */
#endif
NULL
};
/* Don't bother if there's no *ENV glob */
if (!PL_envgv)
return;
/* If there's no %ENV hash of if it's not magical, croak, because
* it probably doesn't reflect the actual environment */
if (!GvHV(PL_envgv) || !(SvRMAGICAL(GvHV(PL_envgv))
&& mg_find((const SV *)GvHV(PL_envgv), PERL_MAGIC_env))) {
const bool was_tainted = PL_tainted;
const char * const name = GvENAME(PL_envgv);
PL_tainted = TRUE;
if (strEQ(name,"ENV"))
/* hash alias */
taint_proper("%%ENV is aliased to %s%s", "another variable");
else
/* glob alias: report it in the error message */
taint_proper("%%ENV is aliased to %%%s%s", name);
/* this statement is reached under -t or -U */
PL_tainted = was_tainted;
}
#ifdef VMS
{
int i = 0;
char name[10 + TYPE_DIGITS(int)] = "DCL$PATH";
STRLEN len = 8; /* strlen(name) */
while (1) {
if (i)
len = my_sprintf(name,"DCL$PATH;%d", i);
svp = hv_fetch(GvHVn(PL_envgv), name, len, FALSE);
if (!svp || *svp == &PL_sv_undef)
break;
if (SvTAINTED(*svp)) {
TAINT;
taint_proper("Insecure %s%s", "$ENV{DCL$PATH}");
}
if ((mg = mg_find(*svp, PERL_MAGIC_envelem)) && MgTAINTEDDIR(mg)) {
TAINT;
taint_proper("Insecure directory in %s%s", "$ENV{DCL$PATH}");
}
i++;
}
}
#endif /* VMS */
svp = hv_fetchs(GvHVn(PL_envgv),"PATH",FALSE);
if (svp && *svp) {
if (SvTAINTED(*svp)) {
TAINT;
taint_proper("Insecure %s%s", "$ENV{PATH}");
}
if ((mg = mg_find(*svp, PERL_MAGIC_envelem)) && MgTAINTEDDIR(mg)) {
TAINT;
taint_proper("Insecure directory in %s%s", "$ENV{PATH}");
}
}
#ifndef VMS
/* tainted $TERM is okay if it contains no metachars */
svp = hv_fetchs(GvHVn(PL_envgv),"TERM",FALSE);
if (svp && *svp && SvTAINTED(*svp)) {
STRLEN len;
const bool was_tainted = PL_tainted;
const char *t = SvPV_const(*svp, len);
const char * const e = t + len;
PL_tainted = was_tainted;
if (t < e && isALNUM(*t))
t++;
while (t < e && (isALNUM(*t) || strchr("-_.+", *t)))
t++;
if (t < e) {
TAINT;
taint_proper("Insecure $ENV{%s}%s", "TERM");
}
}
#endif /* !VMS */
for (e = misc_env; *e; e++) {
SV * const * const svp = hv_fetch(GvHVn(PL_envgv), *e, strlen(*e), FALSE);
if (svp && *svp != &PL_sv_undef && SvTAINTED(*svp)) {
TAINT;
taint_proper("Insecure $ENV{%s}%s", *e);
}
}
}
/* Builds the C-level configuration and state struct. */
srl_encoder_t *
srl_build_encoder_struct(pTHX_ HV *opt)
{
srl_encoder_t *enc;
SV **svp;
enc = srl_empty_encoder_struct(aTHX);
enc->flags = 0;
/* load options */
if (opt != NULL) {
int undef_unknown = 0;
/* SRL_F_SHARED_HASHKEYS on by default */
svp = hv_fetchs(opt, "no_shared_hashkeys", 0);
if ( !svp || !SvTRUE(*svp) )
enc->flags |= SRL_F_SHARED_HASHKEYS;
svp = hv_fetchs(opt, "croak_on_bless", 0);
if ( svp && SvTRUE(*svp) )
enc->flags |= SRL_F_CROAK_ON_BLESS;
svp = hv_fetchs(opt, "snappy", 0);
if ( svp && SvTRUE(*svp) )
enc->flags |= SRL_F_COMPRESS_SNAPPY;
svp = hv_fetchs(opt, "undef_unknown", 0);
if ( svp && SvTRUE(*svp) ) {
undef_unknown = 1;
enc->flags |= SRL_F_UNDEF_UNKNOWN;
}
svp = hv_fetchs(opt, "stringify_unknown", 0);
if ( svp && SvTRUE(*svp) ) {
if (expect_false( undef_unknown )) {
croak("'undef_unknown' and 'stringify_unknown' "
"options are mutually exclusive");
}
enc->flags |= SRL_F_STRINGIFY_UNKNOWN;
}
svp = hv_fetchs(opt, "warn_unknown", 0);
if ( svp && SvTRUE(*svp) ) {
enc->flags |= SRL_F_WARN_UNKNOWN;
if (SvIV(*svp) < 0)
enc->flags |= SRL_F_NOWARN_UNKNOWN_OVERLOAD;
}
svp = hv_fetchs(opt, "snappy_threshold", 0);
if ( svp && SvOK(*svp) )
enc->snappy_threshold = SvIV(*svp);
else
enc->snappy_threshold = 1024;
}
else {
/* SRL_F_SHARED_HASHKEYS on by default */
enc->flags |= SRL_F_SHARED_HASHKEYS;
}
DEBUG_ASSERT_BUF_SANE(enc);
return enc;
}
int perlresult2dbres(SV *perlres, db_res_t **r) {
HV * result = NULL;
SV *colarrayref = NULL;
AV *colarray = NULL;
SV *acol = NULL;
int colcount = 0;
SV *rowarrayref = NULL;
AV *rowarray = NULL;
int rowcount = 0;
SV *arowref = NULL;
AV *arow = NULL;
int arowlen = 0;
SV *aelement = NULL;
SV *atypesv = 0;
int atype = 0;
SV *aval = NULL;
char *charbuf;
char *currentstring;
int i, j;
int retval = 0;
STRLEN len;
SV *d1; /* helper variables */
/*db_val_t cur_val;*/ /* Abbreviation in "switch" below. The currently
modified db result value. */
if (!(SvROK(perlres) &&
(sv_derived_from(perlres, "OpenSIPS::VDB::Result")))) {
goto error;
}
result = (HV*)SvRV(perlres);
/* Memory allocation for C side result structure */
*r = db_new_result();
/* Fetch column definitions */
colarrayref = *hv_fetchs(result, PERL_VDB_COLDEFSMETHOD, 0);
/* colarrayref = perlvdb_perlmethod(perlres, PERL_VDB_COLDEFSMETHOD,
NULL, NULL, NULL, NULL); */
if (!(SvROK(colarrayref))) goto error;
colarray = (AV *)SvRV(colarrayref);
/* SvREFCNT_dec(colarray); */
if (!(SvTYPE(colarray) == SVt_PVAV)) goto error;
colcount = av_len(colarray) + 1;
RES_COL_N(*r) = colcount;
db_allocate_columns(*r, colcount);
/* reverse direction, as elements are removed by "SvREFCNT_dec" */
for (i = colcount-1; i >= 0; i--) {
acol = *av_fetch(colarray, i, 0);
d1 = perlvdb_perlmethod(acol, PERL_VDB_TYPEMETHOD,
NULL, NULL, NULL, NULL);
if (!SvIOK(d1)) goto error;
(*r)->col.types[i] = SvIV(d1);
SvREFCNT_dec(d1);
d1 = perlvdb_perlmethod(acol, PERL_VDB_NAMEMETHOD,
NULL, NULL, NULL, NULL);
if (!SvPOK(d1)) goto error;
currentstring = SvPV(d1, len);
charbuf = pkg_malloc(len+1);
/* Column names buffers are freed in the perlvdb free function */
strncpy(charbuf, currentstring, len+1);
(*r)->col.names[i]->s = charbuf;
(*r)->col.names[i]->len = strlen(charbuf);
SvREFCNT_dec(d1);
}
if(hv_exists(result, "rows", 4)){
rowarrayref =(SV*) hv_fetchs(result, "rows", 0);
}else{
(*r)->n = 0;
(*r)->res_rows = 0;
(*r)->last_row = 0;
goto end;
}
if(rowarrayref){
rowarrayref = *((SV**)rowarrayref);
}else{
(*r)->n = 0;
(*r)->res_rows = 0;
(*r)->last_row = 0;
goto end;
}
if (!(SvROK(rowarrayref))) { /* Empty result set */
(*r)->n = 0;
(*r)->res_rows = 0;
(*r)->last_row = 0;
goto end;
}
rowarray = (AV *)SvRV(rowarrayref);
if (!(SvTYPE(rowarray) == SVt_PVAV)) goto error;
rowcount = av_len(rowarray) + 1;
(*r)->n = rowcount;
(*r)->res_rows = rowcount;
(*r)->last_row = rowcount;
db_allocate_rows(*r, rowcount);
/* (rows * (sizeof(db_row_t) + sizeof(db_val_t) * RES_COL_N(_res)) */
/* LM_DBG("We got %d rows each row requres %d bytes because the row struct is %d and"
"the values in that row take up %d. That is %d values each size is %d\n",
rowcount, sizeof(db_row_t) + sizeof(db_val_t) * RES_COL_N(*r), sizeof(db_row_t), sizeof(db_val_t) * RES_COL_N(*r), RES_COL_N(*r), sizeof(db_val_t));
*/
for (i = 0; i < rowcount; i++) {
arowref = *av_fetch(rowarray, i, 0);
if (!SvROK(arowref)) goto error;
arow = (AV *)SvRV(arowref);
if (!(SvTYPE(colarray) == SVt_PVAV)) goto error;
arowlen = av_len(arow) + 1;
(*r)->rows[i].n = arowlen;
for (j = 0; j < arowlen; j++) {
aelement = *av_fetch(arow, j, 0);
#define cur_val (((*r)->rows)[i].values)[j]
/*cur_val = (((*r)->rows)[i].values)[j];*/
/* cur_val is just an "abbreviation" */
if (!(sv_isobject(aelement) &&
sv_derived_from(aelement, PERL_CLASS_VALUE))) {
cur_val.nul = 1;
continue;
}
atypesv = *hv_fetchs((HV*)SvRV(aelement),PERL_VDB_TYPEMETHOD,0); /*aelement->{type} */
atype = SvIV(atypesv);
/*atypesv = perlvdb_perlmethod(aelement,
PERL_VDB_TYPEMETHOD,
NULL, NULL, NULL, NULL);*/
aval = perlvdb_perlmethod(aelement, PERL_VDB_DATAMETHOD,
NULL, NULL, NULL, NULL);
(*r)->rows[i].values[j].type = atype;
/* SvREFCNT_dec(atypesv); */
if (!SvOK(aval)) {
cur_val.nul = 1;
} else {
switch (atype) {
case DB_INT:
cur_val.val.int_val =
SvIV(aval);
cur_val.nul = 0;
break;
case DB_DOUBLE:
cur_val.val.double_val =
SvNV(aval);
cur_val.nul = 0;
break;
case DB_STRING:
case DB_STR:
/* We dont support DB_STR for now.
* Set DB_STRING instead */
cur_val.type = DB_STRING;
currentstring = SvPV(aval, len);
charbuf = pkg_malloc(len+1);
strncpy(charbuf, currentstring,
len+1);
cur_val.val.string_val =
charbuf;
cur_val.nul = 0;
break;
case DB_DATETIME:
cur_val.val.time_val =
(time_t)SvIV(aval);
cur_val.nul = 0;
break;
case DB_BLOB:
currentstring = SvPV(aval, len);
charbuf = pkg_malloc(len+1);
strncpy(charbuf, currentstring,
len+1);
cur_val.val.blob_val.s =
charbuf;
cur_val.val.blob_val.len = len;
cur_val.nul = 0;
break;
case DB_BITMAP:
cur_val.val.bitmap_val =
SvIV(aval);
cur_val.nul = 0;
break;
default:
LM_CRIT("cannot handle this data type.\n");
return -1;
break;
}
}
SvREFCNT_dec(aval);
}
}
end:
return retval;
error:
LM_CRIT("broken result set. Exiting, leaving OpenSIPS in unknown state.\n");
return -1;
}
STATIC I32
S_do_trans_simple_utf8(pTHX_ SV * const sv)
{
dVAR;
U8 *s;
U8 *send;
U8 *d;
U8 *start;
U8 *dstart, *dend;
I32 matches = 0;
const I32 grows = PL_op->op_private & OPpTRANS_GROWS;
STRLEN len;
SV* const rv =
#ifdef USE_ITHREADS
PAD_SVl(cPADOP->op_padix);
#else
(SV*)cSVOP->op_sv;
#endif
HV* const hv = (HV*)SvRV(rv);
SV* const * svp = hv_fetchs(hv, "NONE", FALSE);
const UV none = svp ? SvUV(*svp) : 0x7fffffff;
const UV extra = none + 1;
UV final = 0;
U8 hibit = 0;
s = (U8*)SvPV(sv, len);
if (!SvUTF8(sv)) {
const U8 *t = s;
const U8 * const e = s + len;
while (t < e) {
const U8 ch = *t++;
hibit = !NATIVE_IS_INVARIANT(ch);
if (hibit) {
s = bytes_to_utf8(s, &len);
break;
}
}
}
send = s + len;
start = s;
svp = hv_fetchs(hv, "FINAL", FALSE);
if (svp)
final = SvUV(*svp);
if (grows) {
/* d needs to be bigger than s, in case e.g. upgrading is required */
Newx(d, len * 3 + UTF8_MAXBYTES, U8);
dend = d + len * 3;
dstart = d;
}
else {
dstart = d = s;
dend = d + len;
}
while (s < send) {
const UV uv = swash_fetch(rv, s, TRUE);
if (uv < none) {
s += UTF8SKIP(s);
matches++;
d = uvuni_to_utf8(d, uv);
}
else if (uv == none) {
const int i = UTF8SKIP(s);
Move(s, d, i, U8);
d += i;
s += i;
}
else if (uv == extra) {
s += UTF8SKIP(s);
matches++;
d = uvuni_to_utf8(d, final);
}
else
srl_merger_t *
srl_build_merger_struct(pTHX_ HV *opt)
{
srl_merger_t *mrg;
SV **svp;
int i;
mrg = srl_empty_merger_struct(aTHX);
/* load options */
if (opt != NULL) {
/* Needs to be before the snappy options */
/* mrg->protocol_version defaults to SRL_PROTOCOL_VERSION. */
svp = hv_fetchs(opt, "protocol_version", 0);
if (svp && SvOK(*svp)) {
mrg->protocol_version = SvUV(*svp);
if (mrg->protocol_version < 1 || mrg->protocol_version > SRL_PROTOCOL_VERSION) {
croak("Specified Sereal protocol version ('%lu') is invalid",
(unsigned long) mrg->protocol_version);
}
}
svp = hv_fetchs(opt, "top_level_element", 0);
if (svp && SvOK(*svp)) {
switch (SvUV(*svp)) {
case 0: /* SCALAR */
SRL_MRG_SET_OPTION(mrg, SRL_F_TOPLEVEL_KEY_SCALAR);
break;
case 1: /* ARRAYREF */
SRL_MRG_SET_OPTION(mrg, SRL_F_TOPLEVEL_KEY_ARRAY);
break;
case 2: /* HASHREF */
SRL_MRG_SET_OPTION(mrg, SRL_F_TOPLEVEL_KEY_HASH);
break;
default:
croak("Invalid Sereal::Merger top level element");
}
}
svp = hv_fetchs(opt, "dedupe_strings", 0);
if (svp && SvTRUE(*svp))
SRL_MRG_SET_OPTION(mrg, SRL_F_DEDUPE_STRINGS);
svp = hv_fetchs(opt, "compress", 0);
if (svp && SvOK(*svp)) {
switch (SvIV(*svp)) {
case 0: /* uncompressed */
break;
case 1: /* snappy incremental */
SRL_MRG_SET_OPTION(mrg, SRL_F_COMPRESS_SNAPPY_INCREMENTAL);
break;
default:
croak("Invalid Sereal compression format");
}
}
svp = hv_fetchs(opt, "max_recursion_depth", 0);
if (svp && SvOK(*svp))
mrg->max_recursion_depth = SvUV(*svp);
}
if (mrg->protocol_version == 1) {
srl_fill_header(aTHX_ mrg, NULL, 0);
} else {
/* Preallocate memory for buffer.
* SRL_PREALLOCATE_FOR_USER_HEADER for potential user header + 100 bytes for body */
GROW_BUF(&mrg->obuf, SRL_PREALLOCATE_FOR_USER_HEADER + 100);
mrg->obuf.pos = mrg->obuf.start + SRL_PREALLOCATE_FOR_USER_HEADER;
SRL_UPDATE_BODY_POS(&mrg->obuf, mrg->protocol_version);
}
if (!SRL_MRG_HAVE_OPTION(mrg, SRL_F_TOPLEVEL_KEY_SCALAR)) {
srl_buf_cat_char_nocheck(&mrg->obuf, SRL_HDR_REFN);
srl_buf_cat_char_nocheck(&mrg->obuf, SRL_MRG_HAVE_OPTION(mrg, SRL_F_TOPLEVEL_KEY_HASH) ? SRL_HDR_HASH : SRL_HDR_ARRAY);
mrg->obuf_padding_bytes_offset = BUF_POS_OFS(&mrg->obuf);
for (i = 0; i < SRL_MAX_VARINT_LENGTH_U32; ++i) {
srl_buf_cat_char_nocheck(&mrg->obuf, SRL_HDR_PAD);
}
}
return mrg;
}
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;
}
srl_splitter_t * srl_build_splitter_struct(pTHX_ HV *opt) {
srl_splitter_t *splitter;
SV **svp;
STRLEN input_len;
splitter = srl_empty_splitter_struct(aTHX);
/* load options */
svp = hv_fetchs(opt, "input", 0);
if (svp && SvOK(*svp)) {
splitter->input_str = SvPV(*svp, input_len);
splitter->pos = splitter->input_str;
splitter->input_len = input_len;
splitter->input_str_end = splitter->input_str + input_len;
splitter->input_sv = SvREFCNT_inc(*svp);
SRL_SPLITTER_TRACE("input_size %" UVuf, input_len);
} else {
croak ("no input given");
}
svp = hv_fetchs(opt, "chunk_size", 0);
if (svp && SvOK(*svp)) {
splitter->size_limit = SvUV(*svp);
SRL_SPLITTER_TRACE("size_limit %" UVuf, splitter->size_limit);
}
splitter->compression_format = 0;
svp = hv_fetchs(opt, "compress", 0);
if (svp && SvOK(*svp)) {
IV compression_format = SvIV(*svp);
/* See also Splitter.pm's constants */
switch (compression_format) {
case 0:
SRL_SPLITTER_TRACE("no compression %s", "");
break;
case 1:
croak("incremental snappy compression not yet supported. Try gzip");
break;
case 2:
splitter->compression_format = 2;
SRL_SPLITTER_TRACE("gzip compression %s", "");
break;
default:
croak("invalid valie for 'compress' parameter");
}
}
splitter->header_str = NULL;
splitter->header_sv = NULL;
splitter->header_len = 0;
svp = hv_fetchs(opt, "header_data_template", 0);
if (svp && SvOK(*svp)) {
STRLEN header_len;
splitter->header_str = SvPV(*svp, header_len);
splitter->header_sv = SvREFCNT_inc(*svp);
splitter->header_len = header_len;
SRL_SPLITTER_TRACE("header_data_template found, of length %lu", header_len);
}
splitter->header_count_idx = -1;
svp = hv_fetchs(opt, "header_count_idx", 0);
if (svp && SvOK(*svp)) {
splitter->header_count_idx = SvIV(*svp);
SRL_SPLITTER_TRACE("header_count_idx found, %ld", splitter->header_count_idx);
}
_parse_header(aTHX_ splitter);
/* initialize stacks */
srl_splitter_stack_t * status_stack;
Newxz(status_stack, 1, srl_splitter_stack_t );
Newxz(status_stack->data, STACK_SIZE_INCR, UV );
status_stack->size = STACK_SIZE_INCR;
status_stack->top = 0;
splitter->status_stack = status_stack;
/* initialize */
splitter->deepness = 0;
char tag = *(splitter->pos);
splitter->pos++;
if (IS_SRL_HDR_ARRAYREF(tag)) {
int len = tag & 0xF;
splitter->input_nb_elts = len;
SRL_SPLITTER_TRACE(" * ARRAYREF of len, %d", len);
while (len-- > 0) {
stack_push(splitter->status_stack, ST_VALUE);
}
} else if (tag == SRL_HDR_REFN) {
tag = *(splitter->pos);
splitter->pos++;
if (tag == SRL_HDR_ARRAY) {
UV len = _read_varint_uv_nocheck(splitter);
splitter->input_nb_elts = len;
SRL_SPLITTER_TRACE(" * ARRAY of len, %lu", len);
while (len-- > 0) {
stack_push(splitter->status_stack, ST_VALUE);
}
} else {
croak("first tag is REFN but next tag is not ARRAY");
}
} else {
croak("first tag is not an ArrayRef");
}
/* now splitter->pos is on the first array element */
return splitter;
}
