IV
PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
PerlIO_funcs * tab)
{
IV code;
PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
/* If called (normally) via open() then arg is ref to scalar we are
* using, otherwise arg (from binmode presumably) is either NULL
* or the _name_ of the scalar
*/
if (arg) {
if (SvROK(arg)) {
s->var = SvREFCNT_inc(SvRV(arg));
if (!SvPOK(s->var) && SvTYPE(SvRV(arg)) > SVt_NULL)
(void)SvPV_nolen(s->var);
}
else {
s->var =
SvREFCNT_inc(perl_get_sv
(SvPV_nolen(arg), GV_ADD | GV_ADDMULTI));
}
}
else {
s->var = newSVpvn("", 0);
}
SvUPGRADE(s->var, SVt_PV);
code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
if (!SvOK(s->var) || (PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
SvCUR(s->var) = 0;
if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
s->posn = SvCUR(s->var);
else
s->posn = 0;
return code;
}
SSize_t
PerlIOScalar_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
{
if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
Off_t offset;
PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
SV *sv = s->var;
char *dst;
if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND) {
dst = SvGROW(sv, SvCUR(sv) + count);
offset = SvCUR(sv);
s->posn = offset + count;
}
else {
if ((s->posn + count) > SvCUR(sv))
dst = SvGROW(sv, (STRLEN)s->posn + count);
else
dst = SvPV_nolen(sv);
offset = s->posn;
s->posn += count;
}
Move(vbuf, dst + offset, count, char);
if ((STRLEN) s->posn > SvCUR(sv))
SvCUR_set(sv, (STRLEN)s->posn);
SvPOK_on(s->var);
return count;
}
IV
PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence)
{
PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
STRLEN oldcur = SvCUR(s->var);
STRLEN newlen;
switch (whence) {
case SEEK_SET:
s->posn = offset;
break;
case SEEK_CUR:
s->posn = offset + s->posn;
break;
case SEEK_END:
s->posn = offset + SvCUR(s->var);
break;
}
if (s->posn < 0) {
if (ckWARN(WARN_LAYER))
Perl_warner(aTHX_ packWARN(WARN_LAYER), "Offset outside string");
SETERRNO(EINVAL, SS_IVCHAN);
return -1;
}
newlen = (STRLEN) s->posn;
if (newlen > oldcur) {
(void) SvGROW(s->var, newlen);
Zero(SvPVX(s->var) + oldcur, newlen - oldcur, char);
/* No SvCUR_set(), though. This is just a seek, not a write. */
}
void
enc_pack(pTHX_ SV *result, STRLEN size, U8 endian, UV value)
{
U8 *d = (U8 *) SvPV_nolen(result);
switch(endian) {
case 'v':
case 'V':
d += SvCUR(result);
SvCUR_set(result,SvCUR(result)+size);
while (size--) {
*d++ = (U8)(value & 0xFF);
value >>= 8;
}
break;
case 'n':
case 'N':
SvCUR_set(result,SvCUR(result)+size);
d += SvCUR(result);
while (size--) {
*--d = (U8)(value & 0xFF);
value >>= 8;
}
break;
default:
croak("Unknown endian %c",(char) endian);
break;
}
}
/* maxlen 0 = read one text line */
I32
Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
{
filter_t funcp;
SV *datasv = NULL;
if (!PL_rsfp_filters)
return -1;
if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
/* Provide a default input filter to make life easy. */
/* Note that we append to the line. This is handy. */
DEBUG_P(PerlIO_printf(Perl_debug_log,
"filter_read %d: from rsfp\n", idx));
if (maxlen) {
/* Want a block */
int len ;
const int old_len = SvCUR(buf_sv);
/* ensure buf_sv is large enough */
SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ;
if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
if (PerlIO_error(PL_rsfp))
return -1; /* error */
else
return 0 ; /* end of file */
}
SvCUR_set(buf_sv, old_len + len) ;
} else {
/* Want a line */
if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
if (PerlIO_error(PL_rsfp))
return -1; /* error */
else
return 0 ; /* end of file */
}
}
return SvCUR(buf_sv);
}
/* Skip this filter slot if filter has been deleted */
if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
DEBUG_P(PerlIO_printf(Perl_debug_log,
"filter_read %d: skipped (filter deleted)\n",
idx));
return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
}
/* Get function pointer hidden within datasv */
funcp = DPTR2FPTR(filter_t, IoANY(datasv));
DEBUG_P(PerlIO_printf(Perl_debug_log,
"filter_read %d: via function %p (%s)\n",
idx, datasv, SvPV_nolen_const(datasv)));
/* Call function. The function is expected to */
/* call "FILTER_READ(idx+1, buf_sv)" first. */
/* Return: <0:error, =0:eof, >0:not eof */
return (*funcp)(aTHX_ idx, buf_sv, maxlen);
}
PERL_STATIC_INLINE UV
S__invlist_len(pTHX_ SV* const invlist)
{
/* Returns the current number of elements stored in the inversion list's
* array */
PERL_ARGS_ASSERT__INVLIST_LEN;
assert(SvTYPE(invlist) == SVt_INVLIST);
return (SvCUR(invlist) == 0)
? 0
: FROM_INTERNAL_SIZE(SvCUR(invlist)) - *get_invlist_offset_addr(invlist);
}
void modperl_perl_call_list(pTHX_ AV *subs, const char *name)
{
I32 i, oldscope = PL_scopestack_ix;
SV **ary = AvARRAY(subs);
MP_TRACE_g(MP_FUNC, "pid %lu" MP_TRACEf_TID MP_TRACEf_PERLID
" running %d %s subs",
(unsigned long)getpid(), MP_TRACEv_TID_ MP_TRACEv_PERLID_
AvFILLp(subs)+1, name);
for (i=0; i<=AvFILLp(subs); i++) {
CV *cv = (CV*)ary[i];
SV *atsv = ERRSV;
PUSHMARK(PL_stack_sp);
call_sv((SV*)cv, G_EVAL|G_DISCARD);
if (SvCUR(atsv)) {
Perl_sv_catpvf(aTHX_ atsv, "%s failed--call queue aborted",
name);
while (PL_scopestack_ix > oldscope) {
LEAVE;
}
Perl_croak(aTHX_ "%s", SvPVX(atsv));
}
}
}
GV *
Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
{
register const char *nend;
const char *nsplit = 0;
GV* gv;
for (nend = name; *nend; nend++) {
if (*nend == '\'')
nsplit = nend;
else if (*nend == ':' && *(nend + 1) == ':')
nsplit = ++nend;
}
if (nsplit) {
const char *origname = name;
name = nsplit + 1;
if (*nsplit == ':')
--nsplit;
if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
/* ->SUPER::method should really be looked up in original stash */
SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
CopSTASHPV(PL_curcop)));
stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
origname, HvNAME(stash), name) );
}
else
stash = gv_stashpvn(origname, nsplit - origname, TRUE);
}
gv = gv_fetchmeth(stash, name, nend - name, 0);
if (!gv) {
if (strEQ(name,"import") || strEQ(name,"unimport"))
gv = (GV*)&PL_sv_yes;
else if (autoload)
gv = gv_autoload4(stash, name, nend - name, TRUE);
}
else if (autoload) {
CV* cv = GvCV(gv);
if (!CvROOT(cv) && !CvXSUB(cv)) {
GV* stubgv;
GV* autogv;
if (CvANON(cv))
stubgv = gv;
else {
stubgv = CvGV(cv);
if (GvCV(stubgv) != cv) /* orphaned import */
stubgv = gv;
}
autogv = gv_autoload4(GvSTASH(stubgv),
GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
if (autogv)
gv = autogv;
}
}
return gv;
}
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 void xs_getnameinfo(pTHX_ CV *cv)
{
dVAR;
dXSARGS;
SV *addr;
int flags;
char host[1024];
char serv[256];
char *sa; /* we'll cast to struct sockaddr * when necessary */
STRLEN addr_len;
int err;
if(items < 1 || items > 2)
croak_xs_usage(cv, "addr, flags=0");
SP -= items;
addr = ST(0);
if(items < 2)
flags = 0;
else
flags = SvIV(ST(1));
if(!SvPOK(addr))
croak("addr is not a string");
addr_len = SvCUR(addr);
/* We need to ensure the sockaddr is aligned, because a random SvPV might
* not be due to SvOOK */
Newx(sa, addr_len, char);
Copy(SvPV_nolen(addr), sa, addr_len, char);
#ifdef HAS_SOCKADDR_SA_LEN
((struct sockaddr *)sa)->sa_len = addr_len;
#endif
err = getnameinfo((struct sockaddr *)sa, addr_len,
host, sizeof(host),
serv, sizeof(serv),
flags);
Safefree(sa);
XPUSHs(err_to_SV(aTHX_ err));
if(err)
XSRETURN(1);
XPUSHs(sv_2mortal(newSVpv(host, 0)));
XPUSHs(sv_2mortal(newSVpv(serv, 0)));
XSRETURN(3);
}
char *
Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
{
PERL_ARGS_ASSERT_SV_PVN;
if (SvPOK(sv)) {
*lp = SvCUR(sv);
return SvPVX(sv);
}
return sv_2pv(sv, lp);
}
char *
Perl_sv_pvn_nomg(pTHX_ SV *sv, STRLEN *lp)
{
PERL_ARGS_ASSERT_SV_PVN_NOMG;
if (SvPOK(sv)) {
*lp = SvCUR(sv);
return SvPVX(sv);
}
return sv_2pv_flags(sv, lp, 0);
}
/* convert a hash to a string, with the format "key=val,key=val" */
char *
hash2str( HV* hash )
{
SV* val; /* temp for iterating over hash */
char* key; /* temp for iterating over hash */
I32 keylen; /* temp for iterating over hash */
int len = 0; /* length of final string, including EOS */
int n; /* number of elements in hash */
char* str; /* final string */
char* ptr; /* temp ptr */
/* iterate over hash, determining the length of the final string */
hv_iterinit(hash);
while( val = hv_iternextsv(hash, &key, &keylen) )
{
/* complain if the value is undefined or if it's a reference */
if ( !SvOK(val) || SvROK(val) )
croak( "hash entry for `%s' not a scalar", key );
n++;
len += keylen + SvCUR(val);
}
len += n /* '=' */
+ n-1 /* ',' */
+ 1; /* EOS */
/* now, fill in string */
New( 0, str, len, char );
ptr = str;
hv_iterinit(hash);
while( val = hv_iternextsv(hash, &key, &keylen) )
{
STRLEN cur;
char *pv;
strcpy(ptr, key);
ptr += keylen;
*ptr++ = '=';
pv = SvPV(val, cur);
strncpy(ptr, pv, cur);
ptr += cur;
*ptr++ = ',';
}
/* the EOS position now contains a ',', and ptr is one
past that. fix that */
*--ptr = '\0';
return str;
}
IV
PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence)
{
PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
switch (whence) {
case 0:
s->posn = offset;
break;
case 1:
s->posn = offset + s->posn;
break;
case 2:
s->posn = offset + SvCUR(s->var);
break;
}
if ((STRLEN) s->posn > SvCUR(s->var)) {
(void) SvGROW(s->var, (STRLEN) s->posn);
}
return 0;
}
SV *
sv_maybe_utf8(SV *sv)
{
#ifdef SvUTF8_on
if (SvPOK(sv))
{
if (has_highbit(SvPVX(sv),SvCUR(sv)))
SvUTF8_on(sv);
}
#endif
return sv;
}
static CORBA_boolean
put_sequence (GIOPSendBuffer *buf, CORBA_TypeCode tc, SV *sv)
{
dTHR;
CORBA_unsigned_long len, i;
SV **value;
if (sv == &PL_sv_undef) {
if (PL_dowarn & G_WARN_ON)
warn ("Uninitialized sequence");
len = 0;
buf_putn (buf, &len, sizeof (len));
return CORBA_TRUE;
}
/* get length, check type */
if (tc->subtypes[0]->kind == CORBA_tk_octet ||
tc->subtypes[0]->kind == CORBA_tk_char) {
len = SvCUR(sv);
} else {
if (!SvROK(sv) || (SvTYPE(SvRV(sv)) != SVt_PVAV)) {
warn("Sequence must be array reference");
return CORBA_FALSE;
}
len = 1+av_len((AV *)SvRV(sv));
}
if (tc->length != 0 && len > tc->length) {
warn("Sequence length (%d) exceeds bound (%d)", len, tc->length);
return CORBA_FALSE;
}
buf_putn (buf, &len, sizeof (len));
if (tc->subtypes[0]->kind == CORBA_tk_octet ||
tc->subtypes[0]->kind == CORBA_tk_char) {
giop_send_buffer_append_mem_indirect (buf, SvPV(sv, PL_na), len);
} else {
AV *av = (AV *)SvRV(sv);
for (i = 0; i < len; i++) {
value = av_fetch(av, i, 0);
if (!porbit_put_sv (buf, tc->subtypes[0],
value ? *value : &PL_sv_undef))
return CORBA_FALSE;
}
}
return CORBA_TRUE;
}
static int
verify_opset(pTHX_ SV *opset, int fatal)
{
const char *err = NULL;
dMY_CXT;
if (!SvOK(opset)) err = "undefined";
else if (!SvPOK(opset)) err = "wrong type";
else if (SvCUR(opset) != (STRLEN)opset_len) err = "wrong size";
if (err && fatal) {
croak("Invalid opset: %s", err);
}
return !err;
}
void
plcb_convert_storage(PLCB_t *object, AV *docav, plcb_DOCVAL *vspec)
{
SV *pv = SvROK(vspec->value) ? SvRV(vspec->value) : vspec->value;
uint32_t fmt = vspec->spec;
if (object->cv_customenc) {
vspec->need_free = 1;
vspec->value = custom_convert(docav, object->cv_customenc, vspec->value, &vspec->flags, CONVERT_OUT);
} else if (fmt == PLCB_CF_JSON) {
vspec->flags = PLCB_LF_JSON|PLCB_CF_JSON;
vspec->need_free = 1;
vspec->value = serialize_convert(object->cv_jsonenc, vspec->value, CONVERT_OUT);
} else if (fmt == PLCB_CF_STORABLE) {
vspec->flags = PLCB_CF_STORABLE | PLCB_LF_STORABLE;
vspec->need_free = 1;
vspec->value = serialize_convert(object->cv_serialize, vspec->value, CONVERT_OUT);
} else if (fmt == PLCB_CF_RAW) {
vspec->flags = PLCB_CF_RAW | PLCB_LF_RAW;
vspec->need_free = 0;
if (!SvPOK(pv)) {
die("Raw conversion requires string value!");
}
} else if (vspec->spec == PLCB_CF_UTF8) {
vspec->flags = PLCB_CF_UTF8 | PLCB_LF_UTF8;
vspec->need_free = 0;
sv_utf8_upgrade(pv);
} else {
die("Unrecognized flags used (0x%x) but no custom converted installed!", vspec->spec);
}
if (!vspec->need_free) {
/* Use input as-is */
vspec->value = pv;
}
/* Assume the resultant value is an SV */
if (SvTYPE(vspec->value) == SVt_PV) {
vspec->encoded = SvPVX(vspec->value);
vspec->len = SvCUR(vspec->value);
} else {
vspec->encoded = SvPV(vspec->value, vspec->len);
}
}
IV
PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
PerlIO_funcs * tab)
{
IV code;
PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
/* If called (normally) via open() then arg is ref to scalar we are
* using, otherwise arg (from binmode presumably) is either NULL
* or the _name_ of the scalar
*/
if (arg) {
if (SvROK(arg)) {
if (SvREADONLY(SvRV(arg)) && mode && *mode != 'r') {
if (ckWARN(WARN_LAYER))
Perl_warner(aTHX_ packWARN(WARN_LAYER), "%s", PL_no_modify);
SETERRNO(EINVAL, SS_IVCHAN);
return -1;
}
s->var = SvREFCNT_inc(SvRV(arg));
SvGETMAGIC(s->var);
if (!SvPOK(s->var) && SvOK(s->var))
(void)SvPV_nomg_const_nolen(s->var);
}
else {
s->var =
SvREFCNT_inc(perl_get_sv
(SvPV_nolen(arg), GV_ADD | GV_ADDMULTI));
}
}
else {
s->var = newSVpvn("", 0);
}
SvUPGRADE(s->var, SVt_PV);
code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
if (!SvOK(s->var) || (PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
SvCUR_set(s->var, 0);
if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
s->posn = SvCUR(s->var);
else
s->posn = 0;
return code;
}
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;
}
void pdl_grow (pdl* a, int newsize) {
SV* foo;
HV* hash;
STRLEN nbytes;
STRLEN ncurr;
STRLEN len;
if(a->state & PDL_DONTTOUCHDATA) {
die("Trying to touch data of an untouchable (mmapped?) pdl");
}
if(a->datasv == NULL)
a->datasv = newSVpv("",0);
foo = a->datasv;
nbytes = ((STRLEN) newsize) * pdl_howbig(a->datatype);
ncurr = SvCUR( foo );
if (ncurr == nbytes)
return; /* Nothing to be done */
/* We don't want to do this: if someone is resizing it
* but wanting to preserve data.. */
#ifdef FEOIJFOESIJFOJE
if (ncurr>nbytes) /* Nuke back to zero */
sv_setpvn(foo,"",0);
#endif
if(nbytes > (1024*1024*1024)) {
SV *sv = get_sv("PDL::BIGPDL",0);
if(sv == NULL || !(SvTRUE(sv)))
die("Probably false alloc of over 1Gb PDL! (set $PDL::BIGPDL = 1 to enable)");
fflush(stdout);
}
{
void *p;
p = SvGROW ( foo, nbytes ); SvCUR_set( foo, nbytes );
}
a->data = (void *) SvPV( foo, len ); a->nvals = newsize;
}
IV
PerlIOEncode_flush(pTHX_ PerlIO * f)
{
PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
IV code = 0;
if (e->bufsv) {
dSP;
SV *str;
char *s;
STRLEN len;
SSize_t count = 0;
if ((PerlIOBase(f)->flags & PERLIO_F_WRBUF) && (e->base.ptr > e->base.buf)) {
if (e->inEncodeCall) return 0;
/* Write case - encode the buffer and write() to layer below */
PUSHSTACKi(PERLSI_MAGIC);
SPAGAIN;
ENTER;
SAVETMPS;
PUSHMARK(sp);
XPUSHs(e->enc);
SvCUR_set(e->bufsv, e->base.ptr - e->base.buf);
SvUTF8_on(e->bufsv);
XPUSHs(e->bufsv);
XPUSHs(e->chk);
PUTBACK;
e->inEncodeCall = 1;
if (call_method("encode", G_SCALAR) != 1) {
e->inEncodeCall = 0;
Perl_die(aTHX_ "panic: encode did not return a value");
}
e->inEncodeCall = 0;
SPAGAIN;
str = POPs;
PUTBACK;
s = SvPV(str, len);
count = PerlIO_write(PerlIONext(f),s,len);
if ((STRLEN)count != len) {
code = -1;
}
FREETMPS;
LEAVE;
POPSTACK;
if (PerlIO_flush(PerlIONext(f)) != 0) {
code = -1;
}
if (SvCUR(e->bufsv)) {
/* Did not all translate */
e->base.ptr = e->base.buf+SvCUR(e->bufsv);
return code;
}
}
else if ((PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
/* read case */
/* if we have any untranslated stuff then unread that first */
/* FIXME - unread is fragile is there a better way ? */
if (e->dataSV && SvCUR(e->dataSV)) {
s = SvPV(e->dataSV, len);
count = PerlIO_unread(PerlIONext(f),s,len);
if ((STRLEN)count != len) {
code = -1;
}
SvCUR_set(e->dataSV,0);
}
/* See if there is anything left in the buffer */
if (e->base.ptr < e->base.end) {
if (e->inEncodeCall) return 0;
/* Bother - have unread data.
re-encode and unread() to layer below
*/
PUSHSTACKi(PERLSI_MAGIC);
SPAGAIN;
ENTER;
SAVETMPS;
str = sv_newmortal();
sv_upgrade(str, SVt_PV);
SvPV_set(str, (char*)e->base.ptr);
SvLEN_set(str, 0);
SvCUR_set(str, e->base.end - e->base.ptr);
SvPOK_only(str);
SvUTF8_on(str);
PUSHMARK(sp);
XPUSHs(e->enc);
XPUSHs(str);
XPUSHs(e->chk);
PUTBACK;
e->inEncodeCall = 1;
if (call_method("encode", G_SCALAR) != 1) {
e->inEncodeCall = 0;
Perl_die(aTHX_ "panic: encode did not return a value");
}
e->inEncodeCall = 0;
SPAGAIN;
str = POPs;
PUTBACK;
s = SvPV(str, len);
count = PerlIO_unread(PerlIONext(f),s,len);
if ((STRLEN)count != len) {
code = -1;
}
FREETMPS;
LEAVE;
POPSTACK;
}
}
e->base.ptr = e->base.end = e->base.buf;
PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
}
return code;
}
STATIC char *
S_skipspace(pTHX_ register char *s, int incline)
{
if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
while (s < PL_bufend && SPACE_OR_TAB(*s))
s++;
return s;
}
for (;;) {
STRLEN prevlen;
SSize_t oldprevlen, oldoldprevlen;
SSize_t oldloplen = 0, oldunilen = 0;
while (s < PL_bufend && isSPACE(*s)) {
if (*s++ == '\n' && ((incline == 2) || (PL_in_eval && !PL_rsfp && !incline)))
incline(s);
}
/* comment */
if (s < PL_bufend && *s == '#') {
while (s < PL_bufend && *s != '\n')
s++;
if (s < PL_bufend) {
s++;
if (PL_in_eval && !PL_rsfp && !incline) {
incline(s);
continue;
}
}
}
/* also skip leading whitespace on the beginning of a line before deciding
* whether or not to recharge the linestr. --rafl
*/
while (s < PL_bufend && isSPACE(*s)) {
if (*s++ == '\n' && PL_in_eval && !PL_rsfp && !incline)
incline(s);
}
/* only continue to recharge the buffer if we're at the end
* of the buffer, we're not reading from a source filter, and
* we're in normal lexing mode
*/
if (s < PL_bufend || !PL_rsfp || PL_lex_inwhat ||
PL_lex_state == LEX_FORMLINE)
return s;
/* try to recharge the buffer */
if ((s = filter_gets(PL_linestr, PL_rsfp,
(prevlen = SvCUR(PL_linestr)))) == Nullch)
{
/* end of file. Add on the -p or -n magic */
if (PL_minus_p) {
sv_setpv(PL_linestr,
";}continue{print or die qq(-p destination: $!\\n);}");
PL_minus_n = PL_minus_p = 0;
}
else if (PL_minus_n) {
sv_setpvn(PL_linestr, ";}", 2);
PL_minus_n = 0;
}
else
sv_setpvn(PL_linestr,";", 1);
/* reset variables for next time we lex */
PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
= SvPVX(PL_linestr);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
PL_last_lop = PL_last_uni = Nullch;
/* In perl versions previous to p4-rawid: //depot/perl@32954 -P
* preprocessors were supported here. We don't support -P at all, even
* on perls that support it, and use the following chunk from blead
* perl. (rafl)
*/
/* Close the filehandle. Could be from
* STDIN, or a regular file. If we were reading code from
* STDIN (because the commandline held no -e or filename)
* then we don't close it, we reset it so the code can
* read from STDIN too.
*/
if ((PerlIO*)PL_rsfp == PerlIO_stdin())
PerlIO_clearerr(PL_rsfp);
else
(void)PerlIO_close(PL_rsfp);
PL_rsfp = Nullfp;
return s;
}
/* not at end of file, so we only read another line */
/* make corresponding updates to old pointers, for yyerror() */
oldprevlen = PL_oldbufptr - PL_bufend;
oldoldprevlen = PL_oldoldbufptr - PL_bufend;
if (PL_last_uni)
oldunilen = PL_last_uni - PL_bufend;
if (PL_last_lop)
oldloplen = PL_last_lop - PL_bufend;
PL_linestart = PL_bufptr = s + prevlen;
PL_bufend = s + SvCUR(PL_linestr);
s = PL_bufptr;
PL_oldbufptr = s + oldprevlen;
PL_oldoldbufptr = s + oldoldprevlen;
if (PL_last_uni)
PL_last_uni = s + oldunilen;
if (PL_last_lop)
PL_last_lop = s + oldloplen;
if (!incline)
incline(s);
/* debugger active and we're not compiling the debugger code,
* so store the line into the debugger's array of lines
*/
if (PERLDB_LINE && PL_curstash != PL_debstash) {
AV *fileav = CopFILEAV(PL_curcop);
if (fileav) {
SV * const sv = NEWSV(85,0);
sv_upgrade(sv, SVt_PVMG);
sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
(void)SvIOK_on(sv);
SvIV_set(sv, 0);
av_store(fileav,(I32)CopLINE(PL_curcop),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;
}
START_MY_CXT
#define fdebug (MY_CXT.x_fdebug)
#define current_idx (MY_CXT.x_current_idx)
static I32
filter_call(pTHX_ int idx, SV *buf_sv, int maxlen)
{
dMY_CXT;
SV *my_sv = FILTER_DATA(idx);
char *nl = "\n";
char *p;
char *out_ptr;
int n;
if (fdebug)
warn("**** In filter_call - maxlen = %d, out len buf = %d idx = %d my_sv = %d [%s]\n",
maxlen, SvCUR(buf_sv), idx, SvCUR(my_sv), SvPVX(my_sv) ) ;
while (1) {
/* anything left from last time */
if ((n = SvCUR(my_sv))) {
out_ptr = SvPVX(my_sv) + BUF_OFFSET(my_sv) ;
if (maxlen) {
/* want a block */
if (fdebug)
warn("BLOCK(%d): size = %d, maxlen = %d\n",
idx, n, maxlen) ;
sv_catpvn(buf_sv, out_ptr, maxlen > n ? n : maxlen );
if(n <= maxlen) {
BUF_OFFSET(my_sv) = 0 ;
SET_LEN(my_sv, 0) ;
}
else {
BUF_OFFSET(my_sv) += maxlen ;
SvCUR_set(my_sv, n - maxlen) ;
}
return SvCUR(buf_sv);
}
else {
/* want lines */
if ((p = ninstr(out_ptr, out_ptr + n, nl, nl + 1))) {
sv_catpvn(buf_sv, out_ptr, p - out_ptr + 1);
n = n - (p - out_ptr + 1);
BUF_OFFSET(my_sv) += (p - out_ptr + 1);
SvCUR_set(my_sv, n) ;
if (fdebug)
warn("recycle %d - leaving %d, returning %d [%s]",
idx, n, SvCUR(buf_sv), SvPVX(buf_sv)) ;
return SvCUR(buf_sv);
}
else /* no EOL, so append the complete buffer */
sv_catpvn(buf_sv, out_ptr, n) ;
}
}
SET_LEN(my_sv, 0) ;
BUF_OFFSET(my_sv) = 0 ;
if (FILTER_ACTIVE(my_sv))
{
dSP ;
int count ;
if (fdebug)
warn("gonna call %s::filter\n", PERL_MODULE(my_sv)) ;
ENTER ;
SAVETMPS;
SAVEINT(current_idx) ; /* save current idx */
current_idx = idx ;
SAVESPTR(DEFSV) ; /* save $_ */
/* make $_ use our buffer */
DEFSV = sv_2mortal(newSVpv("", 0)) ;
PUSHMARK(sp) ;
if (CODE_REF(my_sv)) {
/* if (SvROK(PERL_OBJECT(my_sv)) && SvTYPE(SvRV(PERL_OBJECT(my_sv))) == SVt_PVCV) { */
count = perl_call_sv((SV*)PERL_OBJECT(my_sv), G_SCALAR);
}
else {
XPUSHs((SV*)PERL_OBJECT(my_sv)) ;
PUTBACK ;
count = perl_call_method("filter", G_SCALAR);
}
SPAGAIN ;
if (count != 1)
croak("Filter::Util::Call - %s::filter returned %d values, 1 was expected \n",
PERL_MODULE(my_sv), count ) ;
n = POPi ;
if (fdebug)
warn("status = %d, length op buf = %d [%s]\n",
n, SvCUR(DEFSV), SvPVX(DEFSV) ) ;
if (SvCUR(DEFSV))
sv_setpvn(my_sv, SvPVX(DEFSV), SvCUR(DEFSV)) ;
PUTBACK ;
FREETMPS ;
LEAVE ;
}
else
n = FILTER_READ(idx + 1, my_sv, maxlen) ;
if (n <= 0)
{
/* Either EOF or an error */
if (fdebug)
warn ("filter_read %d returned %d , returning %d\n", idx, n,
(SvCUR(buf_sv)>0) ? SvCUR(buf_sv) : n);
/* PERL_MODULE(my_sv) ; */
/* PERL_OBJECT(my_sv) ; */
filter_del(filter_call);
/* If error, return the code */
if (n < 0)
return n ;
/* return what we have so far else signal eof */
return (SvCUR(buf_sv)>0) ? SvCUR(buf_sv) : n;
}
}
}
GV*
Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
{
char autoload[] = "AUTOLOAD";
STRLEN autolen = sizeof(autoload)-1;
GV* gv;
CV* cv;
HV* varstash;
GV* vargv;
SV* varsv;
char *packname = "";
if (len == autolen && strnEQ(name, autoload, autolen))
return Nullgv;
if (stash) {
if (SvTYPE(stash) < SVt_PVHV) {
packname = SvPV_nolen((SV*)stash);
stash = Nullhv;
}
else {
packname = HvNAME(stash);
}
}
if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
return Nullgv;
cv = GvCV(gv);
if (!(CvROOT(cv) || CvXSUB(cv)))
return Nullgv;
/*
* Inheriting AUTOLOAD for non-methods works ... for now.
*/
if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && !method &&
(GvCVGEN(gv) || GvSTASH(gv) != stash))
Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
packname, (int)len, name);
if (CvXSUB(cv)) {
/* rather than lookup/init $AUTOLOAD here
* only to have the XSUB do another lookup for $AUTOLOAD
* and split that value on the last '::',
* pass along the same data via some unused fields in the CV
*/
CvSTASH(cv) = stash;
SvPVX(cv) = (char *)name; /* cast to lose constness warning */
SvCUR(cv) = len;
return gv;
}
/*
* Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
* The subroutine's original name may not be "AUTOLOAD", so we don't
* use that, but for lack of anything better we will use the sub's
* original package to look up $AUTOLOAD.
*/
varstash = GvSTASH(CvGV(cv));
vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
ENTER;
if (!isGV(vargv))
gv_init(vargv, varstash, autoload, autolen, FALSE);
LEAVE;
varsv = GvSV(vargv);
sv_setpv(varsv, packname);
sv_catpvn(varsv, "::", 2);
sv_catpvn(varsv, name, len);
SvTAINTED_off(varsv);
return gv;
}
GV *
Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
{
register const char *nend;
const char *nsplit = 0;
GV* gv;
HV* ostash = stash;
if (stash && SvTYPE(stash) < SVt_PVHV)
stash = Nullhv;
for (nend = name; *nend; nend++) {
if (*nend == '\'')
nsplit = nend;
else if (*nend == ':' && *(nend + 1) == ':')
nsplit = ++nend;
}
if (nsplit) {
const char *origname = name;
name = nsplit + 1;
if (*nsplit == ':')
--nsplit;
if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
/* ->SUPER::method should really be looked up in original stash */
SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
CopSTASHPV(PL_curcop)));
/* __PACKAGE__::SUPER stash should be autovivified */
stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
origname, HvNAME(stash), name) );
}
else {
/* don't autovifify if ->NoSuchStash::method */
stash = gv_stashpvn(origname, nsplit - origname, FALSE);
/* however, explicit calls to Pkg::SUPER::method may
happen, and may require autovivification to work */
if (!stash && (nsplit - origname) >= 7 &&
strnEQ(nsplit - 7, "::SUPER", 7) &&
gv_stashpvn(origname, nsplit - origname - 7, FALSE))
stash = gv_stashpvn(origname, nsplit - origname, TRUE);
}
ostash = stash;
}
gv = gv_fetchmeth(stash, name, nend - name, 0);
if (!gv) {
if (strEQ(name,"import") || strEQ(name,"unimport"))
gv = (GV*)&PL_sv_yes;
else if (autoload)
gv = gv_autoload4(ostash, name, nend - name, TRUE);
}
else if (autoload) {
CV* cv = GvCV(gv);
if (!CvROOT(cv) && !CvXSUB(cv)) {
GV* stubgv;
GV* autogv;
if (CvANON(cv))
stubgv = gv;
else {
stubgv = CvGV(cv);
if (GvCV(stubgv) != cv) /* orphaned import */
stubgv = gv;
}
autogv = gv_autoload4(GvSTASH(stubgv),
GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
if (autogv)
gv = autogv;
}
}
return gv;
}
// 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)) {
std::string sv_to_string(SV* sv) {
if (SvTYPE(sv) != SVt_PV)
Perl_croak(aTHX_ "Expected a perl string");
return std::string( SvPV_nolen(sv), SvCUR(sv) );
}
