void
Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
{
register GP *gp;
bool doproto = SvTYPE(gv) > SVt_NULL;
char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
sv_upgrade((SV*)gv, SVt_PVGV);
if (SvLEN(gv)) {
if (proto) {
SvPVX(gv) = NULL;
SvLEN(gv) = 0;
SvPOK_off(gv);
} else
Safefree(SvPVX(gv));
}
Newz(602, gp, 1, GP);
GvGP(gv) = gp_ref(gp);
GvSV(gv) = NEWSV(72,0);
GvLINE(gv) = CopLINE(PL_curcop);
GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : "";
GvCVGEN(gv) = 0;
GvEGV(gv) = gv;
sv_magic((SV*)gv, (SV*)gv, '*', Nullch, 0);
GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
GvNAME(gv) = savepvn(name, len);
GvNAMELEN(gv) = len;
if (multi || doproto) /* doproto means it _was_ mentioned */
GvMULTI_on(gv);
if (doproto) { /* Replicate part of newSUB here. */
SvIOK_off(gv);
ENTER;
/* XXX unsafe for threads if eval_owner isn't held */
start_subparse(0,0); /* Create CV in compcv. */
GvCV(gv) = PL_compcv;
LEAVE;
PL_sub_generation++;
CvGV(GvCV(gv)) = gv;
CvFILE(GvCV(gv)) = CopFILE(PL_curcop);
CvSTASH(GvCV(gv)) = PL_curstash;
#ifdef USE_THREADS
CvOWNER(GvCV(gv)) = 0;
if (!CvMUTEXP(GvCV(gv))) {
New(666, CvMUTEXP(GvCV(gv)), 1, perl_mutex);
MUTEX_INIT(CvMUTEXP(GvCV(gv)));
}
#endif /* USE_THREADS */
if (proto) {
sv_setpv((SV*)GvCV(gv), proto);
Safefree(proto);
}
}
}
static void regexp_setup(pTHX_ regexp* r, SV* pat, U32 nparens, SV* callback)
{
I32 len;
int i;
/* fprintf(stderr,"regexp_setup "); */
Safefree(r->precomp);
r->prelen = SvLEN(pat);
r->precomp = savesvpv(pat);
r->nparens = nparens;
Renew(r->startp, nparens+1, I32);
Renew(r->endp, nparens+1, I32);
len = 1;
if(r->offsets[0] < len) {
Renew(r->offsets, 2*len+1, U32);
r->offsets[0] = len;
}
r->offsets[1] = RECOGNITION_FLAG;
Safefree(r->substrs->data[0].substr);
r->substrs->data[0].substr = SvREFCNT_inc(callback);
r->minlen = 0;
r->reganch = 0;
/* XXX Does regcomp.c zero any of the match fields? */
}
int SLenFromScalar(PERL_CALL SV *string, BOOL isRef)
{
if(!string)
return NULL;
if(isRef && !(string = SvROK(string) ? SvRV(string) : NULL))
return NULL;
return SvLEN(string) - 1;
}
STDCHAR *
PerlIOEncode_get_base(pTHX_ PerlIO * f)
{
PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
if (!e->base.bufsiz)
e->base.bufsiz = 1024;
if (!e->bufsv) {
e->bufsv = newSV(e->base.bufsiz);
sv_setpvn(e->bufsv, "", 0);
}
e->base.buf = (STDCHAR *) SvPVX(e->bufsv);
if (!e->base.ptr)
e->base.ptr = e->base.buf;
if (!e->base.end)
e->base.end = e->base.buf;
if (e->base.ptr < e->base.buf
|| e->base.ptr > e->base.buf + SvLEN(e->bufsv)) {
Perl_warn(aTHX_ " ptr %p(%p)%p", e->base.buf, e->base.ptr,
e->base.buf + SvLEN(e->bufsv));
abort();
}
if (SvLEN(e->bufsv) < e->base.bufsiz) {
SSize_t poff = e->base.ptr - e->base.buf;
SSize_t eoff = e->base.end - e->base.buf;
e->base.buf = (STDCHAR *) SvGROW(e->bufsv, e->base.bufsiz);
e->base.ptr = e->base.buf + poff;
e->base.end = e->base.buf + eoff;
}
if (e->base.ptr < e->base.buf
|| e->base.ptr > e->base.buf + SvLEN(e->bufsv)) {
Perl_warn(aTHX_ " ptr %p(%p)%p", e->base.buf, e->base.ptr,
e->base.buf + SvLEN(e->bufsv));
abort();
}
return e->base.buf;
}
void
srl_merger_append_all(pTHX_ srl_merger_t *mrg, AV *src)
{
SSize_t i;
SV **svptr;
STRLEN size = 0;
SSize_t tidx = av_len(src);
if (mrg->obuf_last_successfull_offset) {
/* If obuf_last_successfull_offset is true then last merge
* operation has failed. It means that some cleanup operation needs to
* be done. */
SRL_MERGER_TRACE("last merge operation has failed, need to do some cleanup (offset %"UVuf")",
mrg->obuf_last_successfull_offset);
mrg->obuf.pos = mrg->obuf.body_pos + mrg->obuf_last_successfull_offset;
srl_cleanup_dedup_tlbs(aTHX_ mrg, mrg->obuf_last_successfull_offset);
DEBUG_ASSERT_BUF_SANE(&mrg->obuf);
}
for (i = 0; i <= tidx; ++i) {
svptr = av_fetch(src, i, 0);
if (expect_false(svptr == NULL))
croak("av_fetch returned NULL");
size += SvLEN(*svptr);
}
/* preallocate space in obuf in one go,
* of course this's is very rough estimation */
GROW_BUF(&mrg->obuf, size);
for (i = 0; i <= tidx; ++i) {
srl_set_input_buffer(aTHX_ mrg, *av_fetch(src, i, 0));
srl_build_track_table(aTHX_ mrg);
/* save current offset as last successfull */
mrg->obuf_last_successfull_offset = BODY_POS_OFS(&mrg->obuf);
mrg->recursion_depth = 0;
mrg->ibuf.pos = mrg->ibuf.body_pos + 1;
srl_merge_single_value(aTHX_ mrg);
mrg->cnt_of_merged_elements++;
mrg->obuf_last_successfull_offset = 0;
}
}
int SLenFromHash(PERL_CALL HV *hash, PSTR idx, BOOL isRef)
{
if(isRef && hash)
{
if(!(hash = SvROK(hash) ? (HV*)SvRV(hash) : NULL))
return NULL;
if(SvTYPE(hash) != SVt_PVHV)
return NULL;
}
SV **item = hash ? hv_fetch(hash, idx, strlen(idx), 0) : NULL;
if(item && *item)
return SvLEN(*item) - 1;
else
return NULL;
}
int SLenFromArray(PERL_CALL AV *array, int idx, BOOL isRef)
{
if(isRef && array)
{
if(!(array = SvROK(array) ? (AV*)SvRV(array) : NULL))
return NULL;
if(SvTYPE(array) != SVt_PVAV)
return NULL;
}
SV **item = array ? av_fetch(array, idx, 0) : NULL;
if(item && *item)
return SvLEN(*item) - 1;
else
return NULL;
}
void store_self(pTHX, mthread* thread) {
SV *thread_sv, *self;
AV* message_cache;
thread_sv = newSV_type(SVt_PV);
SvPVX(thread_sv) = (char*) thread;
SvCUR(thread_sv) = sizeof(mthread);
SvLEN(thread_sv) = 0;
SvPOK_only(thread_sv);
SvREADONLY_on(thread_sv);
hv_store(PL_modglobal, "threads::lite::thread", 21, thread_sv, 0);
self = newRV_noinc(newSVuv(thread->id));
sv_bless(self, gv_stashpv("threads::lite::tid", TRUE));
hv_store(PL_modglobal, "threads::lite::self", 19, self, 0);
message_cache = newAV();
hv_store(PL_modglobal, "threads::lite::message_cache", 28, (SV*)message_cache, 0);
thread->cache = message_cache;
}
/*multiple errors for multiple operations on a cookie*/
static inline void
error_pseudo_multi(
PLCBA_t *async,
PLCBA_cookie_t *cookie,
AV *reqlist,
libcouchbase_error_t *errors)
{
int i, idx_max;
AV *reqav;
libcouchbase_error_t errtmp;
SV **tmpsv;
idx_max = av_len(reqlist);
for(i = 0; i <= idx_max; i++) {
if(errors[i] == LIBCOUCHBASE_SUCCESS) {
continue;
}
reqav = (AV*)*(av_fetch(reqlist, i, 0));
tmpsv = av_fetch(reqav, PLCBA_REQIDX_KEY, 0);
error_single(async, cookie, SvPVX_const(*tmpsv), SvLEN(*tmpsv),
errors[i]);
}
}
SV *
DeadCode(pTHX)
{
#ifdef PURIFY
return Nullsv;
#else
SV* sva;
SV* sv;
SV* ret = newRV_noinc((SV*)newAV());
register SV* svend;
int tm = 0, tref = 0, ts = 0, ta = 0, tas = 0;
for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
svend = &sva[SvREFCNT(sva)];
for (sv = sva + 1; sv < svend; ++sv) {
if (SvTYPE(sv) == SVt_PVCV) {
CV *cv = (CV*)sv;
AV* padlist = CvPADLIST(cv), *argav;
SV** svp;
SV** pad;
int i = 0, j, levelm, totm = 0, levelref, totref = 0;
int levels, tots = 0, levela, tota = 0, levelas, totas = 0;
int dumpit = 0;
if (CvXSUB(sv)) {
continue; /* XSUB */
}
if (!CvGV(sv)) {
continue; /* file-level scope. */
}
if (!CvROOT(cv)) {
/* PerlIO_printf(Perl_debug_log, " no root?!\n"); */
continue; /* autoloading stub. */
}
do_gvgv_dump(0, Perl_debug_log, "GVGV::GV", CvGV(sv));
if (CvDEPTH(cv)) {
PerlIO_printf(Perl_debug_log, " busy\n");
continue;
}
svp = AvARRAY(padlist);
while (++i <= AvFILL(padlist)) { /* Depth. */
SV **args;
pad = AvARRAY((AV*)svp[i]);
argav = (AV*)pad[0];
if (!argav || (SV*)argav == &PL_sv_undef) {
PerlIO_printf(Perl_debug_log, " closure-template\n");
continue;
}
args = AvARRAY(argav);
levelm = levels = levelref = levelas = 0;
levela = sizeof(SV*) * (AvMAX(argav) + 1);
if (AvREAL(argav)) {
for (j = 0; j < AvFILL(argav); j++) {
if (SvROK(args[j])) {
PerlIO_printf(Perl_debug_log, " ref in args!\n");
levelref++;
}
/* else if (SvPOK(args[j]) && SvPVX(args[j])) { */
else if (SvTYPE(args[j]) >= SVt_PV && SvLEN(args[j])) {
levelas += SvLEN(args[j])/SvREFCNT(args[j]);
}
}
}
for (j = 1; j < AvFILL((AV*)svp[1]); j++) { /* Vars. */
if (SvROK(pad[j])) {
levelref++;
do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0);
dumpit = 1;
}
/* else if (SvPOK(pad[j]) && SvPVX(pad[j])) { */
else if (SvTYPE(pad[j]) >= SVt_PVAV) {
if (!SvPADMY(pad[j])) {
levelref++;
do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0);
dumpit = 1;
}
}
else if (SvTYPE(pad[j]) >= SVt_PV && SvLEN(pad[j])) {
levels++;
levelm += SvLEN(pad[j])/SvREFCNT(pad[j]);
/* Dump(pad[j],4); */
}
}
PerlIO_printf(Perl_debug_log, " level %i: refs: %i, strings: %i in %i,\targsarray: %i, argsstrings: %i\n",
i, levelref, levelm, levels, levela, levelas);
totm += levelm;
tota += levela;
totas += levelas;
tots += levels;
totref += levelref;
if (dumpit)
do_sv_dump(0, Perl_debug_log, (SV*)cv, 0, 2, 0, 0);
}
if (AvFILL(padlist) > 1) {
PerlIO_printf(Perl_debug_log, " total: refs: %i, strings: %i in %i,\targsarrays: %i, argsstrings: %i\n",
totref, totm, tots, tota, totas);
}
tref += totref;
tm += totm;
ts += tots;
ta += tota;
tas += totas;
}
}
}
PerlIO_printf(Perl_debug_log, "total: refs: %i, strings: %i in %i\targsarray: %i, argsstrings: %i\n", tref, tm, ts, ta, tas);
return ret;
#endif /* !PURIFY */
}
void
LUCY_RegexTokenizer_Tokenize_Utf8_IMP(lucy_RegexTokenizer *self,
const char *string, size_t string_len,
lucy_Inversion *inversion) {
dTHX;
lucy_RegexTokenizerIVARS *const ivars = lucy_RegexTokenizer_IVARS(self);
uint32_t num_code_points = 0;
SV *wrapper = sv_newmortal();
#if (PERL_VERSION > 10)
REGEXP *rx = (REGEXP*)ivars->token_re;
regexp *rx_struct = (regexp*)SvANY(rx);
#else
REGEXP *rx = (REGEXP*)ivars->token_re;
regexp *rx_struct = rx;
#endif
char *string_beg = (char*)string;
char *string_end = string_beg + string_len;
char *string_arg = string_beg;
// Fake up an SV wrapper to feed to the regex engine.
sv_upgrade(wrapper, SVt_PV);
SvREADONLY_on(wrapper);
SvLEN(wrapper) = 0;
SvUTF8_on(wrapper);
// Wrap the string in an SV to please the regex engine.
SvPVX(wrapper) = string_beg;
SvCUR_set(wrapper, string_len);
SvPOK_on(wrapper);
while (pregexec(rx, string_arg, string_end, string_arg, 1, wrapper, 1)) {
#if ((PERL_VERSION >= 10) || (PERL_VERSION == 9 && PERL_SUBVERSION >= 5))
char *const start_ptr = string_arg + rx_struct->offs[0].start;
char *const end_ptr = string_arg + rx_struct->offs[0].end;
#else
char *const start_ptr = string_arg + rx_struct->startp[0];
char *const end_ptr = string_arg + rx_struct->endp[0];
#endif
uint32_t start, end;
// Get start and end offsets in Unicode code points.
for (; string_arg < start_ptr; num_code_points++) {
string_arg += cfish_StrHelp_UTF8_COUNT[(uint8_t)(*string_arg)];
if (string_arg > string_end) {
THROW(CFISH_ERR, "scanned past end of '%s'", string_beg);
}
}
start = num_code_points;
for (; string_arg < end_ptr; num_code_points++) {
string_arg += cfish_StrHelp_UTF8_COUNT[(uint8_t)(*string_arg)];
if (string_arg > string_end) {
THROW(CFISH_ERR, "scanned past end of '%s'", string_beg);
}
}
end = num_code_points;
// Add a token to the new inversion.
LUCY_Inversion_Append(inversion,
lucy_Token_new(
start_ptr,
(end_ptr - start_ptr),
start,
end,
1.0f, // boost always 1 for now
1 // position increment
)
);
}
}
// This function reads the various JavaBin datatypes and returns a Perl SV.
// Different datatypes are jumped to view a lookup in an array of computed gotos.
//
// The first group (undef to enum) use the entire tag for the index of the type.
//
// The second are matched by taking the tag byte, shifting it by 5 so to only read
// the first 3 bits of the tag byte, giving it a range or 0-7 inclusive.
//
// To store both in one array the second group have 18 added to them. See DISPATCH.
//
// The remaining 5 bits can then be used to store the size of the datatype, e.g. how
// many chars in a string, this therefore has a range of 0-31, if the size exceeds or
// matches this then an additional vint is added.
//
// The overview of the tag byte is therefore TTTSSSSS with T and S being type and size.
static SV* read_sv(pTHX) {
void* dispatch[] = {
&&read_undef,
&&read_bool,
&&read_bool,
&&read_byte,
&&read_short,
&&read_double,
&&read_int,
&&read_long,
&&read_float,
&&read_date,
&&read_map,
&&read_solr_doc,
&&read_solr_doc_list,
&&read_byte_array,
&&read_iterator,
NULL,
NULL,
NULL,
&&read_enum,
&&read_string,
&&read_small_int,
&&read_small_long,
&&read_array,
&&read_map,
&&read_map,
};
in++;
goto *dispatch[in[-1] >> 5 ? (in[-1] >> 5) + 18 : in[-1]];
read_undef:
return &PL_sv_undef;
read_bool: {
SV *rv = newSV_type(SVt_IV), *sv = in[-1] == 1 ? bool_true : bool_false;
SvREFCNT(sv)++;
SvROK_on(rv);
SvRV_set(rv, sv);
return rv;
}
read_byte:
return newSViv((int8_t) *in++);
read_short: {
const int16_t s = in[0] << 8 | in[1];
in += 2;
return newSViv(s);
}
read_double: {
// For perls with double length NVs this conversion is simple.
// Read 8 bytes, cast to double, return. For long double perls
// more magic is used, see read_float for more details.
const int_double u = { (uint64_t) in[0] << 56 |
(uint64_t) in[1] << 48 |
(uint64_t) in[2] << 40 |
(uint64_t) in[3] << 32 |
(uint64_t) in[4] << 24 |
(uint64_t) in[5] << 16 |
(uint64_t) in[6] << 8 |
(uint64_t) in[7] };
in += 8;
#ifdef USE_LONG_DOUBLE
char *str = alloca(snprintf(NULL, 0, "%.14f", u.d));
sprintf(str, "%.14f", u.d);
return newSVnv(strtold(str, NULL));
#else
return newSVnv(u.d);
#endif
}
read_int: {
const int32_t i = in[0] << 24 | in[1] << 16 | in[2] << 8 | in[3];
in += 4;
return newSViv(i);
}
read_long: {
const int64_t l = (uint64_t) in[0] << 56 |
(uint64_t) in[1] << 48 |
(uint64_t) in[2] << 40 |
(uint64_t) in[3] << 32 |
(uint64_t) in[4] << 24 |
(uint64_t) in[5] << 16 |
(uint64_t) in[6] << 8 |
(uint64_t) in[7];
in += 8;
return newSViv(l);
}
read_float: {
// JavaBin has a 4byte float format, NVs in perl are double or long double,
// therefore a little magic is required. Read the 4 bytes into an int in the
// correct endian order. Re-read these bits as a float, stringify this float,
// then finally numify the string into a double or long double.
const int_float u = { in[0] << 24 | in[1] << 16 | in[2] << 8 | in[3] };
in += 4;
char *str = alloca(snprintf(NULL, 0, "%f", u.f));
sprintf(str, "%f", u.f);
#ifdef USE_LONG_DOUBLE
return newSVnv(strtold(str, NULL));
#else
return newSVnv(strtod(str, NULL));
#endif
}
read_date: {
const int64_t date_ms = (uint64_t) in[0] << 56 |
(uint64_t) in[1] << 48 |
(uint64_t) in[2] << 40 |
(uint64_t) in[3] << 32 |
(uint64_t) in[4] << 24 |
(uint64_t) in[5] << 16 |
(uint64_t) in[6] << 8 |
(uint64_t) in[7];
in += 8;
const time_t date = date_ms / 1000;
const struct tm *t = gmtime(&date);
char date_str[25];
sprintf(date_str, "%u-%02u-%02uT%02u:%02u:%02u.%03uZ", t->tm_year + 1900,
t->tm_mon + 1,
t->tm_mday,
t->tm_hour,
t->tm_min,
t->tm_sec,
(uint32_t) (date_ms % 1000));
return newSVpvn(date_str, 24);
}
read_solr_doc:
in++; // Assume a solr doc is a map.
read_map: {
HV *hv = (HV*)newSV_type(SVt_PVHV);
uint32_t len = in[-1] >> 5 ? READ_LEN : read_v_int();
while (len--) {
cached_key key;
in++;
const uint32_t i = READ_LEN;
if (i)
key = cached_keys[i];
else {
in++;
cached_keys[++cache_pos] = key = (cached_key){ (char*)in, 0, READ_LEN };
uint8_t *key_str = in;
in += key.len;
// Set the UTF8 flag if we hit a high byte.
while (key_str != in) {
if (*key_str++ & 128) {
key.flags = HVhek_UTF8;
break;
}
}
}
hv_common(hv, NULL, key.key, key.len, key.flags, HV_FETCH_ISSTORE, read_sv(aTHX), 0);
}
SV *rv = newSV_type(SVt_IV);
SvROK_on(rv);
SvRV_set(rv, (SV*)hv);
return rv;
}
read_solr_doc_list: {
HV *hv = (HV*)newSV_type(SVt_PVHV);
// Assume values are in an array, skip tag & read_sv.
in++;
hv_set(hv, "numFound", read_sv(aTHX), numFound);
hv_set(hv, "start", read_sv(aTHX), start);
hv_set(hv, "maxScore", read_sv(aTHX), maxScore);
hv_set(hv, "docs", read_sv(aTHX), docs);
SV *rv = newSV_type(SVt_IV);
SvROK_on(rv);
SvRV_set(rv, (SV*)hv);
return rv;
}
read_byte_array: {
AV *av = (AV*)newSV_type(SVt_PVAV);
SSize_t len = read_v_int();
SV **ary = safemalloc(len * sizeof(SV*));
AvALLOC(av) = AvARRAY(av) = ary;
AvFILLp(av) = AvMAX(av) = len - 1;
while (len--)
*ary++ = newSViv((int8_t) *in++);
SV *rv = newSV_type(SVt_IV);
SvROK_on(rv);
SvRV_set(rv, (SV*)av);
return rv;
}
read_iterator: {
AV *av = (AV*)newSV_type(SVt_PVAV);
uint32_t len = 0;
while (*in != 15)
av_store(av, len++, read_sv(aTHX));
in++;
SV *rv = newSV_type(SVt_IV);
SvROK_on(rv);
SvRV_set(rv, (SV*)av);
return rv;
}
read_enum: {
SV *sv = read_sv(aTHX); // small_int if +ve, int otherwise.
sv_upgrade(sv, SVt_PVMG);
in++;
const STRLEN len = READ_LEN;
char *str = sv_grow(sv, len + 1);
memcpy(str, in, len);
in += len;
str[len] = '\0';
SvCUR(sv) = len;
SvFLAGS(sv) = SVf_IOK | SVp_IOK | SVs_OBJECT | SVf_POK | SVp_POK | SVt_PVMG | SVf_UTF8;
HV *stash = CALL(gv_stashpvn, STR_WITH_LEN("JavaBin::Enum"), 0);
SvREFCNT(stash)++;
SvSTASH_set(sv, stash);
SV *rv = newSV_type(SVt_IV);
SvROK_on(rv);
SvRV_set(rv, sv);
return rv;
}
read_string: {
const STRLEN len = READ_LEN;
SV *sv = newSV_type(SVt_PV);
char *str = SvPVX(sv) = (char*)safemalloc(len);
memcpy(str, in, len);
SvCUR(sv) = SvLEN(sv) = len;
SvFLAGS(sv) |= SVf_POK | SVp_POK | SVf_UTF8;
in += len;
return sv;
}
read_small_int: {
uint32_t result = in[-1] & 15;
if (in[-1] & 16)
result |= read_v_int() << 4;
return newSViv(result);
}
read_small_long: {
uint64_t result = in[-1] & 15;
// Inlined variable-length +ve long code, see read_v_int().
if (in[-1] & 16) {
uint8_t shift = 4;
do result |= (*in++ & 127) << shift;
while (in[-1] & 128 && (shift += 7));
}
return newSViv(result);
}
read_array: {
AV *av = (AV*)newSV_type(SVt_PVAV);
SSize_t len = READ_LEN;
SV **ary = safemalloc(len * sizeof(SV*));
AvALLOC(av) = AvARRAY(av) = ary;
AvFILLp(av) = AvMAX(av) = len - 1;
while (len--)
*ary++ = read_sv(aTHX);
SV *rv = newSV_type(SVt_IV);
SvROK_on(rv);
SvRV(rv) = (SV*)av;
return rv;
}
}
static void grow_out(pTHX_ const STRLEN want) {
const STRLEN len = out_buf - (uint8_t *)SvPVX(out_sv);
// If we want more than we have, realloc the string.
if (len + want >= SvLEN(out_sv)) {
sv_grow(out_sv, len + want);
out_buf = (uint8_t *)SvPVX(out_sv) + len;
}
}
static void write_v_int(uint32_t i) {
while (i & ~127) {
*out_buf++ = (i & 127) | 128;
i >>= 7;
}
*out_buf++ = i;
}
static void write_shifted_tag(uint8_t tag, uint32_t len) {
if (len < 31)
*out_buf++ = tag | len;
else {
*out_buf++ = tag | 31;
write_v_int(len - 31);
}
}
static void write_sv(pTHX_ SV *sv) {
SvGETMAGIC(sv);
if (SvPOKp(sv)) {
const STRLEN len = SvCUR(sv);
grow_out(aTHX_ len + 5);
write_shifted_tag(32, len);
memcpy(out_buf, SvPVX(sv), len);
out_buf += len;
}
else if (SvNOKp(sv)) {
const int_double u = { .d = SvNV(sv) };
grow_out(aTHX_ 9);
*out_buf++ = 5;
*out_buf++ = u.i >> 56;
*out_buf++ = u.i >> 48;
*out_buf++ = u.i >> 40;
*out_buf++ = u.i >> 32;
*out_buf++ = u.i >> 24;
*out_buf++ = u.i >> 16;
*out_buf++ = u.i >> 8;
*out_buf++ = u.i;
}
else if (SvIOKp(sv)) {
OP *
Perl_do_readline(pTHX_ GV* gv)
{
dVAR; dSP; dTARGETSTACKED;
register SV *sv;
STRLEN tmplen = 0;
STRLEN offset;
PerlIO *fp;
register IO * const io = GvIO(gv);
register const I32 type = PL_op->op_type;
const I32 gimme = GIMME_V;
PERL_ARGS_ASSERT_DO_READLINE;
fp = NULL;
if (io) {
fp = IoIFP(io);
if (!fp) {
if (IoFLAGS(io) & IOf_ARGV) {
if (IoFLAGS(io) & IOf_START) {
IoLINES(io) = 0;
if (av_len(GvAVn(gv)) < 0) {
IoFLAGS(io) &= ~IOf_START;
do_openn(io,"-",1,FALSE,O_RDONLY,0,NULL,NULL,0);
sv_setpvn(GvSVn(gv), "-", 1);
SvSETMAGIC(GvSV(gv));
fp = IoIFP(io);
goto have_fp;
}
}
fp = nextargv(gv);
if (!fp) { /* Note: fp != IoIFP(io) */
(void)do_close(gv, FALSE); /* now it does*/
}
}
}
else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
report_evil_fh(io, OP_phoney_OUTPUT_ONLY);
}
}
if (!fp) {
if ((!io || !(IoFLAGS(io) & IOf_START))
&& ckWARN2(WARN_GLOB, WARN_CLOSED))
{
if (type == OP_GLOB)
Perl_warner(aTHX_ packWARN(WARN_GLOB),
"glob failed (can't start child: %s)",
Strerror(errno));
else
report_evil_fh(io, PL_op->op_type);
}
if (gimme == G_SCALAR) {
/* undef TARG, and push that undefined value */
if (type != OP_RCATLINE) {
SV_CHECK_THINKFIRST_COW_DROP(TARG);
if ( ! SvPVOK(TARG) )
sv_upgrade(TARG, SVt_PV);
SvOK_off(TARG);
}
PUSHTARG;
}
RETURN;
}
have_fp:
if (gimme == G_SCALAR) {
sv = TARG;
if (type == OP_RCATLINE) {
NOOP;
}
else {
if ( SvOK(sv) && ! SvPVOK(sv) )
sv_clear_body(sv);
}
if (SvROK(sv)) {
if (type == OP_RCATLINE)
SvPV_force_nolen(sv);
else
sv_unref(sv);
}
else if (isGV_with_GP(sv)) {
SvPV_force_nolen(sv);
}
SvUPGRADE(sv, SVt_PV);
tmplen = SvLEN(sv); /* remember if already alloced */
if (!tmplen && !SvREADONLY(sv))
Sv_Grow(sv, 80); /* try short-buffering it */
offset = 0;
if (type == OP_RCATLINE && SvOK(sv)) {
if (!SvPOK(sv)) {
SvPV_force_nolen(sv);
}
offset = SvCUR(sv);
}
}
else {
sv = sv_2mortal(newSV(80));
offset = 0;
}
/* delay EOF state for a snarfed empty file */
#define SNARF_EOF(gimme,rs,io,sv) \
(gimme != G_SCALAR || SvCUR(sv) \
|| (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
for (;;) {
PUTBACK;
if (!sv_gets(sv, fp, offset)
&& (type == OP_GLOB
|| SNARF_EOF(gimme, PL_rs, io, sv)
|| PerlIO_error(fp)))
{
PerlIO_clearerr(fp);
if (IoFLAGS(io) & IOf_ARGV) {
fp = nextargv(gv);
if (fp)
continue;
(void)do_close(gv, FALSE);
}
else if (type == OP_GLOB) {
if (!do_close(gv, FALSE) && ckWARN(WARN_GLOB)) {
Perl_warner(aTHX_ packWARN(WARN_GLOB),
"glob failed (child exited with status %d%s)",
(int)(STATUS_CURRENT >> 8),
(STATUS_CURRENT & 0x80) ? ", core dumped" : "");
}
}
if (gimme == G_SCALAR) {
if (type != OP_RCATLINE) {
SV_CHECK_THINKFIRST_COW_DROP(TARG);
SvOK_off(TARG);
}
SPAGAIN;
PUSHTARG;
}
RETURN;
}
IV
PerlIOEncode_fill(pTHX_ PerlIO * f)
{
PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
dSP;
IV code = 0;
PerlIO *n;
SSize_t avail;
if (PerlIO_flush(f) != 0)
return -1;
n = PerlIONext(f);
if (!PerlIO_fast_gets(n)) {
/* Things get too messy if we don't have a buffer layer
push a :perlio to do the job */
char mode[8];
n = PerlIO_push(aTHX_ n, &PerlIO_perlio, PerlIO_modestr(f,mode), Nullsv);
if (!n) {
Perl_die(aTHX_ "panic: cannot push :perlio for %p",f);
}
}
PUSHSTACKi(PERLSI_MAGIC);
SPAGAIN;
ENTER;
SAVETMPS;
retry:
avail = PerlIO_get_cnt(n);
if (avail <= 0) {
avail = PerlIO_fill(n);
if (avail == 0) {
avail = PerlIO_get_cnt(n);
}
else {
if (!PerlIO_error(n) && PerlIO_eof(n))
avail = 0;
}
}
if (avail > 0 || (e->flags & NEEDS_LINES)) {
STDCHAR *ptr = PerlIO_get_ptr(n);
SSize_t use = (avail >= 0) ? avail : 0;
SV *uni;
char *s = NULL;
STRLEN len = 0;
e->base.ptr = e->base.end = (STDCHAR *) NULL;
(void) PerlIOEncode_get_base(aTHX_ f);
if (!e->dataSV)
e->dataSV = newSV(0);
if (SvTYPE(e->dataSV) < SVt_PV) {
sv_upgrade(e->dataSV,SVt_PV);
}
if (e->flags & NEEDS_LINES) {
/* Encoding needs whole lines (e.g. iso-2022-*)
search back from end of available data for
and line marker
*/
STDCHAR *nl = ptr+use-1;
while (nl >= ptr) {
if (*nl == '\n') {
break;
}
nl--;
}
if (nl >= ptr && *nl == '\n') {
/* found a line - take up to and including that */
use = (nl+1)-ptr;
}
else if (avail > 0) {
/* No line, but not EOF - append avail to the pending data */
sv_catpvn(e->dataSV, (char*)ptr, use);
PerlIO_set_ptrcnt(n, ptr+use, 0);
goto retry;
}
else if (!SvCUR(e->dataSV)) {
goto end_of_file;
}
}
if (SvCUR(e->dataSV)) {
/* something left over from last time - create a normal
SV with new data appended
*/
if (use + SvCUR(e->dataSV) > e->base.bufsiz) {
if (e->flags & NEEDS_LINES) {
/* Have to grow buffer */
e->base.bufsiz = use + SvCUR(e->dataSV);
PerlIOEncode_get_base(aTHX_ f);
}
else {
use = e->base.bufsiz - SvCUR(e->dataSV);
}
}
sv_catpvn(e->dataSV,(char*)ptr,use);
}
else {
/* Create a "dummy" SV to represent the available data from layer below */
if (SvLEN(e->dataSV) && SvPVX_const(e->dataSV)) {
Safefree(SvPVX_mutable(e->dataSV));
}
if (use > (SSize_t)e->base.bufsiz) {
if (e->flags & NEEDS_LINES) {
/* Have to grow buffer */
e->base.bufsiz = use;
PerlIOEncode_get_base(aTHX_ f);
}
else {
use = e->base.bufsiz;
}
}
SvPV_set(e->dataSV, (char *) ptr);
SvLEN_set(e->dataSV, 0); /* Hands off sv.c - it isn't yours */
SvCUR_set(e->dataSV,use);
SvPOK_only(e->dataSV);
}
SvUTF8_off(e->dataSV);
PUSHMARK(sp);
XPUSHs(e->enc);
XPUSHs(e->dataSV);
XPUSHs(e->chk);
PUTBACK;
if (call_method("decode", G_SCALAR) != 1) {
Perl_die(aTHX_ "panic: decode did not return a value");
}
SPAGAIN;
uni = POPs;
PUTBACK;
/* Now get translated string (forced to UTF-8) and use as buffer */
if (SvPOK(uni)) {
s = SvPVutf8(uni, len);
#ifdef PARANOID_ENCODE_CHECKS
if (len && !is_utf8_string((U8*)s,len)) {
Perl_warn(aTHX_ "panic: decode did not return UTF-8 '%.*s'",(int) len,s);
}
#endif
}
if (len > 0) {
/* Got _something */
/* if decode gave us back dataSV then data may vanish when
we do ptrcnt adjust - so take our copy now.
(The copy is a pain - need a put-it-here option for decode.)
*/
sv_setpvn(e->bufsv,s,len);
e->base.ptr = e->base.buf = (STDCHAR*)SvPVX(e->bufsv);
e->base.end = e->base.ptr + SvCUR(e->bufsv);
PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
SvUTF8_on(e->bufsv);
/* Adjust ptr/cnt not taking anything which
did not translate - not clear this is a win */
/* compute amount we took */
use -= SvCUR(e->dataSV);
PerlIO_set_ptrcnt(n, ptr+use, (avail-use));
/* and as we did not take it it isn't pending */
SvCUR_set(e->dataSV,0);
} else {
/* Got nothing - assume partial character so we need some more */
/* Make sure e->dataSV is a normal SV before re-filling as
buffer alias will change under us
*/
s = SvPV(e->dataSV,len);
sv_setpvn(e->dataSV,s,len);
PerlIO_set_ptrcnt(n, ptr+use, (avail-use));
goto retry;
}
}
else {
end_of_file:
code = -1;
if (avail == 0)
PerlIOBase(f)->flags |= PERLIO_F_EOF;
else
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
}
FREETMPS;
LEAVE;
POPSTACK;
return code;
}
