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;
}
}
static HV*
S_thaw_fields(lucy_InStream *instream) {
// Read frozen data into an SV buffer.
size_t len = (size_t)LUCY_InStream_Read_C64(instream);
SV *buf_sv = newSV(len + 1);
SvPOK_on(buf_sv);
SvCUR_set(buf_sv, len);
char *buf = SvPVX(buf_sv);
LUCY_InStream_Read_Bytes(instream, buf, len);
// Call back to Storable to thaw the frozen hash.
dSP;
ENTER;
SAVETMPS;
EXTEND(SP, 1);
PUSHMARK(SP);
mPUSHs(buf_sv);
PUTBACK;
call_pv("Storable::thaw", G_SCALAR);
SPAGAIN;
SV *frozen = POPs;
if (frozen && !SvROK(frozen)) {
CFISH_THROW(CFISH_ERR, "thaw failed");
}
HV *fields = (HV*)SvRV(frozen);
(void)SvREFCNT_inc((SV*)fields);
PUTBACK;
FREETMPS;
LEAVE;
return fields;
}
void decode_time(pTHX_ unsigned char *input, STRLEN len, struct cc_type *type, SV *output)
{
int64_t nano, seconds, hours, minutes;
STRLEN pvlen;
char *result;
union {
unsigned char bytes[8];
int64_t bigint;
} bytes_or_bigint;
if (UNLIKELY(len != 8))
croak("decode_time: len != 8");
memcpy(bytes_or_bigint.bytes, input, 8);
bswap8(bytes_or_bigint.bytes);
if (UNLIKELY(bytes_or_bigint.bigint < 0 || bytes_or_bigint.bigint > 86399999999999))
croak("decode_time: invalid value");
nano = bytes_or_bigint.bigint % 1000000000;
seconds = bytes_or_bigint.bigint / 1000000000;
hours = seconds / 3600;
minutes = (seconds % 3600) / 60;
seconds = seconds % 60;
sv_setpvf(output, "%lld:%.2lld:%.2lld.%lld", hours, minutes, seconds, nano);
result = SvPV(output, pvlen);
while (result[pvlen-1] == '0')
pvlen--;
if (result[pvlen-1] == '.')
pvlen--;
SvCUR_set(output, pvlen);
}
GLvoid * EL(SV * sv, int needlen)
{
STRLEN skip = 0;
SV * svref;
if (SvREADONLY(sv))
croak("Readonly value for buffer");
if(SvROK(sv)) {
svref = SvRV(sv);
sv = svref;
}
else
{
#ifdef USE_STRICT_UNGLOB
if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
sv_unglob(sv);
#endif
SvUPGRADE(sv, SVt_PV);
SvGROW(sv, (unsigned int)(needlen + 1));
SvPOK_on(sv);
SvCUR_set(sv, needlen);
*SvEND(sv) = '\0'; /* Why is this here? -chm */
}
return SvPV_force(sv, skip);
}
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
PerlIOEncode_close(pTHX_ PerlIO * f)
{
PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
IV code;
if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
/* Discard partial character */
if (e->dataSV) {
SvCUR_set(e->dataSV,0);
}
/* Don't back decode and unread any pending data */
e->base.ptr = e->base.end = e->base.buf;
}
code = PerlIOBase_close(aTHX_ f);
if (e->bufsv) {
/* This should only fire for write case */
if (e->base.buf && e->base.ptr > e->base.buf) {
Perl_croak(aTHX_ "Close with partial character");
}
SvREFCNT_dec(e->bufsv);
e->bufsv = Nullsv;
}
e->base.buf = NULL;
e->base.ptr = NULL;
e->base.end = NULL;
PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
return code;
}
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
}
/* 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);
}
static SV *sv_soundex_utf8 (SV* source)
{
U8 *source_p;
U8 *source_end;
{
STRLEN source_len;
source_p = (U8 *) SvPV(source, source_len);
source_end = &source_p[source_len];
}
while (source_p < source_end)
{
STRLEN offset;
UV c = utf8n_to_uvchr(source_p, source_end-source_p, &offset, 0);
char codepart_last = (c <= 0xFF) ? sv_soundex_table[c] : '\0';
source_p = (offset >= 1) ? &source_p[offset] : source_end;
if (codepart_last != '\0')
{
SV *code = newSV(SOUNDEX_ACCURACY);
char *code_p = SvPVX(code);
char *code_end = &code_p[SOUNDEX_ACCURACY];
SvCUR_set(code, SOUNDEX_ACCURACY);
SvPOK_only(code);
*code_p++ = toupper(c);
while (source_p != source_end && code_p != code_end)
{
char codepart;
c = utf8n_to_uvchr(source_p, source_end-source_p, &offset, 0);
codepart = (c <= 0xFF) ? sv_soundex_table[c] : '\0';
source_p = (offset >= 1) ? &source_p[offset] : source_end;
if (codepart != '\0')
if (codepart != codepart_last && (codepart_last = codepart) != '0')
*code_p++ = codepart;
}
while (code_p != code_end)
*code_p++ = '0';
*code_end = '\0';
return code;
}
source_p++;
}
return SvREFCNT_inc(perl_get_sv("Text::Soundex::nocode", FALSE));
}
SSize_t
PerlIOScalar_unread(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
{
PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
char *dst = SvGROW(s->var, (STRLEN)s->posn + count);
Move(vbuf, dst + s->posn, count, char);
s->posn += count;
SvCUR_set(s->var, (STRLEN)s->posn);
SvPOK_on(s->var);
return count;
}
static SV *sv_soundex (SV *source)
{
char *source_p;
char *source_end;
{
STRLEN source_len;
source_p = SvPV(source, source_len);
source_end = &source_p[source_len];
}
while (source_p != source_end)
{
char codepart_last = sv_soundex_table[(unsigned char) *source_p];
if (codepart_last != '\0')
{
SV *code = newSV(SOUNDEX_ACCURACY);
char *code_p = SvPVX(code);
char *code_end = &code_p[SOUNDEX_ACCURACY];
SvCUR_set(code, SOUNDEX_ACCURACY);
SvPOK_only(code);
*code_p++ = toupper(*source_p++);
while (source_p != source_end && code_p != code_end)
{
char c = *source_p++;
char codepart = sv_soundex_table[(unsigned char) c];
if (codepart != '\0')
if (codepart != codepart_last && (codepart_last = codepart) != '0')
*code_p++ = codepart;
}
while (code_p != code_end)
*code_p++ = '0';
*code_end = '\0';
return code;
}
source_p++;
}
return SvREFCNT_inc(perl_get_sv("Text::Soundex::nocode", FALSE));
}
void
Perl_set_version(pTHX_ const char *name, STRLEN nlen, const char *strval, STRLEN plen, NV nvval)
{
SV* ver = GvSV(gv_add_by_type(gv_fetchpvn(name, nlen, GV_ADD, SVt_PVNV),
SVt_PVNV));
PERL_ARGS_ASSERT_SET_VERSION;
SvREADONLY_off(ver);
SvUPGRADE(ver, SVt_PVNV);
SvPVX(ver) = SvGROW(ver, plen+1);
Move(strval, SvPVX(ver), plen, char);
SvCUR_set(ver, plen);
SvNVX(ver) = nvval;
/* not the PROTECT bit */
SvFLAGS(ver) |= (SVf_NOK|SVp_NOK|SVf_POK|SVp_POK|SVf_READONLY);
}
MP_INLINE SV *modperl_slurp_filename(pTHX_ request_rec *r, int tainted)
{
SV *sv;
apr_status_t rc;
apr_size_t size;
apr_file_t *file;
size = r->finfo.size;
sv = newSV(size);
/* XXX: could have checked whether r->finfo.filehand is valid and
* save the apr_file_open call, but apache gives us no API to
* check whether filehand is valid. we can't test whether it's
* NULL or not, as it may contain garbagea
*/
rc = apr_file_open(&file, r->filename, APR_READ|APR_BINARY,
APR_OS_DEFAULT, r->pool);
SLURP_SUCCESS("opening");
rc = apr_file_read(file, SvPVX(sv), &size);
SLURP_SUCCESS("reading");
MP_TRACE_o(MP_FUNC, "read %d bytes from '%s'", size, r->filename);
if (r->finfo.size != size) {
SvREFCNT_dec(sv);
Perl_croak(aTHX_ "Error: read %d bytes, expected %d ('%s')",
size, (apr_size_t)r->finfo.size, r->filename);
}
rc = apr_file_close(file);
SLURP_SUCCESS("closing");
SvPVX(sv)[size] = '\0';
SvCUR_set(sv, size);
SvPOK_on(sv);
if (tainted) {
SvTAINTED_on(sv);
}
else {
SvTAINTED_off(sv);
}
return newRV_noinc(sv);
}
STATIC char *
S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
{
#ifdef PERL_CR_FILTER
if (!PL_rsfp_filters) {
filter_add(S_cr_textfilter,NULL);
}
#endif
if (PL_rsfp_filters) {
if (!append)
SvCUR_set(sv, 0); /* start with empty line */
if (FILTER_READ(0, sv, 0) > 0)
return ( SvPVX(sv) ) ;
else
return Nullch ;
}
else
return (sv_gets(sv, fp, append));
}
static SV *
new_opset(pTHX_ SV *old_opset)
{
SV *opset;
dMY_CXT;
if (old_opset) {
verify_opset(aTHX_ old_opset,1);
opset = newSVsv(old_opset);
}
else {
opset = newSV(opset_len);
Zero(SvPVX_const(opset), opset_len + 1, char);
SvCUR_set(opset, opset_len);
(void)SvPOK_only(opset);
}
/* not mortalised here */
return opset;
}
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 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;
}
/* 32bit compat */
void decode_time(pTHX_ unsigned char *input, STRLEN len, struct cc_type *type, SV *output)
{
int32_t nano, seconds, hours, minutes;
char *txt;
char workbuf[20];
STRLEN txt_len;
decode_varint(aTHX_ input, len, type, output);
/* output now contains a string represending the ns since midnight */
txt = SvPV(output, txt_len);
if (txt_len > 14) {
croak("decode_time: invalid value");
}
if (txt_len <= 9) {
memset(workbuf, 0, 20);
memcpy(workbuf, txt, txt_len);
seconds = 0;
nano = atoi(workbuf);
} else {
memset(workbuf, 0, 20);
memcpy(workbuf, txt+txt_len-9, 9);
nano = atoi(workbuf);
memset(workbuf, 0, 20);
memcpy(workbuf, txt, txt_len-9);
seconds = atoi(workbuf);
}
hours = seconds / 3600;
minutes = (seconds % 3600) / 60;
seconds = seconds % 60;
sv_setpvf(output, "%d:%.2d:%.2d.%d", hours, minutes, seconds, nano);
txt = SvPV(output, txt_len);
while (txt[txt_len-1] == '0')
txt_len--;
if (txt[txt_len-1] == '.')
txt_len--;
SvCUR_set(output, txt_len);
}
void _mpack_item(SV *res, SV *o)
{
size_t len, res_len, new_len;
char *s, *res_s;
res_s = SvPVbyte(res, res_len);
unsigned i;
if (!SvOK(o)) {
new_len = res_len + mp_sizeof_nil();
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
mp_encode_nil(res_s + res_len);
return;
}
if (SvROK(o)) {
o = SvRV(o);
if (SvOBJECT(o)) {
SvGETMAGIC(o);
HV *stash = SvSTASH(o);
GV *mtd = gv_fetchmethod_autoload(stash, "msgpack", 0);
if (!mtd)
croak("Object has no method 'msgpack'");
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs (sv_bless (sv_2mortal (newRV_inc(o)), stash));
PUTBACK;
call_sv((SV *)GvCV(mtd), G_SCALAR);
SPAGAIN;
SV *pkt = POPs;
if (!SvOK(pkt))
croak("O->msgpack returned undef");
s = SvPV(pkt, len);
new_len = res_len + len;
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
memcpy(res_s + res_len, s, len);
PUTBACK;
FREETMPS;
LEAVE;
return;
}
switch(SvTYPE(o)) {
case SVt_PVAV: {
AV *a = (AV *)o;
len = av_len(a) + 1;
new_len = res_len + mp_sizeof_array(len);
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
mp_encode_array(res_s + res_len, len);
for (i = 0; i < len; i++) {
SV **item = av_fetch(a, i, 0);
if (!item)
_mpack_item(res, 0);
else
_mpack_item(res, *item);
}
break;
}
case SVt_PVHV: {
HV *h = (HV *)o;
len = hv_iterinit(h);
new_len = res_len + mp_sizeof_map(len);
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
mp_encode_map(res_s + res_len, len);
for (;;) {
HE * iter = hv_iternext(h);
if (!iter)
break;
SV *k = hv_iterkeysv(iter);
SV *v = HeVAL(iter);
_mpack_item(res, k);
_mpack_item(res, v);
}
break;
}
default:
croak("Can't serialize reference");
}
return;
}
switch(SvTYPE(o)) {
case SVt_PV:
case SVt_PVIV:
case SVt_PVNV:
case SVt_PVMG:
case SVt_REGEXP:
if (!looks_like_number(o)) {
s = SvPV(o, len);
new_len = res_len + mp_sizeof_str(len);
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
mp_encode_str(res_s + res_len, s, len);
break;
}
case SVt_NV: {
NV v = SvNV(o);
IV iv = (IV)v;
if (v != iv) {
new_len = res_len + mp_sizeof_double(v);
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
mp_encode_double(res_s + res_len, v);
break;
}
}
case SVt_IV: {
IV v = SvIV(o);
if (v >= 0) {
new_len = res_len + mp_sizeof_uint(v);
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
mp_encode_uint(res_s + res_len, v);
} else {
new_len = res_len + mp_sizeof_int(v);
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
mp_encode_int(res_s + res_len, v);
}
break;
}
default:
croak("Internal msgpack error %d", SvTYPE(o));
}
}
/*
=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)));
}
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;
}
}
}
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;
}
STATIC I32
S_do_trans_simple(pTHX_ SV * const sv)
{
dVAR;
I32 matches = 0;
STRLEN len;
U8 *s = (U8*)SvPV(sv,len);
U8 * const send = s+len;
const short * const tbl = (short*)cPVOP->op_pv;
if (!tbl)
Perl_croak(aTHX_ "panic: do_trans_simple line %d",__LINE__);
/* First, take care of non-UTF-8 input strings, because they're easy */
if (!SvUTF8(sv)) {
while (s < send) {
const I32 ch = tbl[*s];
if (ch >= 0) {
matches++;
*s = (U8)ch;
}
s++;
}
SvSETMAGIC(sv);
}
else {
const I32 grows = PL_op->op_private & OPpTRANS_GROWS;
U8 *d;
U8 *dstart;
/* Allow for expansion: $_="a".chr(400); tr/a/\xFE/, FE needs encoding */
if (grows)
Newx(d, len*2+1, U8);
else
d = s;
dstart = d;
while (s < send) {
STRLEN ulen;
I32 ch;
/* Need to check this, otherwise 128..255 won't match */
const UV c = utf8n_to_uvchr(s, send - s, &ulen, UTF8_ALLOW_DEFAULT);
if (c < 0x100 && (ch = tbl[c]) >= 0) {
matches++;
d = uvchr_to_utf8(d, ch);
s += ulen;
}
else { /* No match -> copy */
Move(s, d, ulen, U8);
d += ulen;
s += ulen;
}
}
if (grows) {
sv_setpvn(sv, (char*)dstart, d - dstart);
Safefree(dstart);
}
else {
*d = '\0';
SvCUR_set(sv, d - dstart);
}
SvUTF8_on(sv);
SvSETMAGIC(sv);
}
return matches;
}
STATIC I32
S_do_trans_complex(pTHX_ SV * const sv)
{
dVAR;
STRLEN len;
U8 *s = (U8*)SvPV(sv, len);
U8 * const send = s+len;
I32 matches = 0;
const short * const tbl = (short*)cPVOP->op_pv;
if (!tbl)
Perl_croak(aTHX_ "panic: do_trans_complex line %d",__LINE__);
if (!SvUTF8(sv)) {
U8 *d = s;
U8 * const dstart = d;
if (PL_op->op_private & OPpTRANS_SQUASH) {
const U8* p = send;
while (s < send) {
const I32 ch = tbl[*s];
if (ch >= 0) {
*d = (U8)ch;
matches++;
if (p != d - 1 || *p != *d)
p = d++;
}
else if (ch == -1) /* -1 is unmapped character */
*d++ = *s;
else if (ch == -2) /* -2 is delete character */
matches++;
s++;
}
}
else {
while (s < send) {
const I32 ch = tbl[*s];
if (ch >= 0) {
matches++;
*d++ = (U8)ch;
}
else if (ch == -1) /* -1 is unmapped character */
*d++ = *s;
else if (ch == -2) /* -2 is delete character */
matches++;
s++;
}
}
*d = '\0';
SvCUR_set(sv, d - dstart);
}
else { /* is utf8 */
const I32 complement = PL_op->op_private & OPpTRANS_COMPLEMENT;
const I32 grows = PL_op->op_private & OPpTRANS_GROWS;
const I32 del = PL_op->op_private & OPpTRANS_DELETE;
U8 *d;
U8 *dstart;
STRLEN rlen = 0;
if (grows)
Newx(d, len*2+1, U8);
else
d = s;
dstart = d;
if (complement && !del)
rlen = tbl[0x100];
#ifdef MACOS_TRADITIONAL
#define comp CoMP /* "comp" is a keyword in some compilers ... */
#endif
if (PL_op->op_private & OPpTRANS_SQUASH) {
UV pch = 0xfeedface;
while (s < send) {
STRLEN len;
const UV comp = utf8n_to_uvchr(s, send - s, &len,
UTF8_ALLOW_DEFAULT);
I32 ch;
if (comp > 0xff) {
if (!complement) {
Move(s, d, len, U8);
d += len;
}
else {
matches++;
if (!del) {
ch = (rlen == 0) ? (I32)comp :
(comp - 0x100 < rlen) ?
tbl[comp+1] : tbl[0x100+rlen];
if ((UV)ch != pch) {
d = uvchr_to_utf8(d, ch);
pch = (UV)ch;
}
s += len;
continue;
}
}
}
else if ((ch = tbl[comp]) >= 0) {
matches++;
if ((UV)ch != pch) {
d = uvchr_to_utf8(d, ch);
pch = (UV)ch;
}
s += len;
continue;
}
else if (ch == -1) { /* -1 is unmapped character */
Move(s, d, len, U8);
d += len;
}
else if (ch == -2) /* -2 is delete character */
matches++;
s += len;
pch = 0xfeedface;
}
}
else {
while (s < send) {
STRLEN len;
const UV comp = utf8n_to_uvchr(s, send - s, &len,
UTF8_ALLOW_DEFAULT);
I32 ch;
if (comp > 0xff) {
if (!complement) {
Move(s, d, len, U8);
d += len;
}
else {
matches++;
if (!del) {
if (comp - 0x100 < rlen)
d = uvchr_to_utf8(d, tbl[comp+1]);
else
d = uvchr_to_utf8(d, tbl[0x100+rlen]);
}
}
}
else if ((ch = tbl[comp]) >= 0) {
d = uvchr_to_utf8(d, ch);
matches++;
}
else if (ch == -1) { /* -1 is unmapped character */
Move(s, d, len, U8);
d += len;
}
else if (ch == -2) /* -2 is delete character */
matches++;
s += len;
}
}
if (grows) {
sv_setpvn(sv, (char*)dstart, d - dstart);
Safefree(dstart);
}
else {
*d = '\0';
SvCUR_set(sv, d - dstart);
}
SvUTF8_on(sv);
}
SvSETMAGIC(sv);
return matches;
}
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
)
);
}
}
void
Perl_set_caret_X(pTHX) {
GV* tmpgv = gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL, SVt_PV); /* $^X */
SV *const caret_x = GvSV(tmpgv);
#if defined(OS2)
sv_setpv(caret_x, os2_execname(aTHX));
#elif defined(USE_KERN_PROC_PATHNAME)
size_t size = 0;
int mib[4];
mib[0] = CTL_KERN;
mib[1] = KERN_PROC;
mib[2] = KERN_PROC_PATHNAME;
mib[3] = -1;
if (sysctl(mib, 4, NULL, &size, NULL, 0) == 0
&& size > 0 && size < MAXPATHLEN * MAXPATHLEN) {
sv_grow(caret_x, size);
if (sysctl(mib, 4, SvPVX(caret_x), &size, NULL, 0) == 0
&& size > 2) {
SvPOK_only(caret_x);
SvCUR_set(caret_x, size - 1);
SvTAINT(caret_x);
return;
}
}
#elif defined(USE_NSGETEXECUTABLEPATH)
char buf[1];
uint32_t size = sizeof(buf);
_NSGetExecutablePath(buf, &size);
if (size < MAXPATHLEN * MAXPATHLEN) {
sv_grow(caret_x, size);
if (_NSGetExecutablePath(SvPVX(caret_x), &size) == 0) {
char *const tidied = realpath(SvPVX(caret_x), NULL);
if (tidied) {
sv_setpv(caret_x, tidied);
free(tidied);
} else {
SvPOK_only(caret_x);
SvCUR_set(caret_x, size);
}
return;
}
}
#elif defined(HAS_PROCSELFEXE)
char buf[MAXPATHLEN];
SSize_t len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
/* NOTE: if the length returned by readlink() is sizeof(buf) - 1,
* it is impossible to know whether the result was truncated. */
if (len != -1) {
buf[len] = '\0';
}
/* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
includes a spurious NUL which will cause $^X to fail in system
or backticks (this will prevent extensions from being built and
many tests from working). readlink is not meant to add a NUL.
Normal readlink works fine.
*/
if (len > 0 && buf[len-1] == '\0') {
len--;
}
/* FreeBSD's implementation is acknowledged to be imperfect, sometimes
returning the text "unknown" from the readlink rather than the path
to the executable (or returning an error from the readlink). Any
valid path has a '/' in it somewhere, so use that to validate the
result. See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
*/
if (len > 0 && memchr(buf, '/', len)) {
sv_setpvn(caret_x, buf, len);
return;
}
#elif defined(WIN32)
char *ansi;
WCHAR widename[MAX_PATH];
GetModuleFileNameW(NULL, widename, sizeof(widename)/sizeof(WCHAR));
ansi = win32_ansipath(widename);
sv_setpv(caret_x, ansi);
win32_free(ansi);
return;
#else
/* Fallback to this: */
sv_setpv(caret_x, PL_origargv[0]);
#endif
}
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;
}
lucy_HitDoc*
lucy_DefDocReader_fetch_doc(lucy_DefaultDocReader *self, int32_t doc_id) {
lucy_Schema *const schema = self->schema;
lucy_InStream *const dat_in = self->dat_in;
lucy_InStream *const ix_in = self->ix_in;
HV *fields = newHV();
int64_t start;
uint32_t num_fields;
SV *field_name_sv = newSV(1);
// Get data file pointer from index, read number of fields.
Lucy_InStream_Seek(ix_in, (int64_t)doc_id * 8);
start = Lucy_InStream_Read_U64(ix_in);
Lucy_InStream_Seek(dat_in, start);
num_fields = Lucy_InStream_Read_C32(dat_in);
// Decode stored data and build up the doc field by field.
while (num_fields--) {
STRLEN field_name_len;
char *field_name_ptr;
SV *value_sv;
lucy_FieldType *type;
// Read field name.
field_name_len = Lucy_InStream_Read_C32(dat_in);
field_name_ptr = SvGROW(field_name_sv, field_name_len + 1);
Lucy_InStream_Read_Bytes(dat_in, field_name_ptr, field_name_len);
SvPOK_on(field_name_sv);
SvCUR_set(field_name_sv, field_name_len);
SvUTF8_on(field_name_sv);
*SvEND(field_name_sv) = '\0';
// Find the Field's FieldType.
lucy_ZombieCharBuf *field_name_zcb
= CFISH_ZCB_WRAP_STR(field_name_ptr, field_name_len);
Lucy_ZCB_Assign_Str(field_name_zcb, field_name_ptr, field_name_len);
type = Lucy_Schema_Fetch_Type(schema, (lucy_CharBuf*)field_name_zcb);
// Read the field value.
switch (Lucy_FType_Primitive_ID(type) & lucy_FType_PRIMITIVE_ID_MASK) {
case lucy_FType_TEXT: {
STRLEN value_len = Lucy_InStream_Read_C32(dat_in);
value_sv = newSV((value_len ? value_len : 1));
Lucy_InStream_Read_Bytes(dat_in, SvPVX(value_sv), value_len);
SvCUR_set(value_sv, value_len);
*SvEND(value_sv) = '\0';
SvPOK_on(value_sv);
SvUTF8_on(value_sv);
break;
}
case lucy_FType_BLOB: {
STRLEN value_len = Lucy_InStream_Read_C32(dat_in);
value_sv = newSV((value_len ? value_len : 1));
Lucy_InStream_Read_Bytes(dat_in, SvPVX(value_sv), value_len);
SvCUR_set(value_sv, value_len);
*SvEND(value_sv) = '\0';
SvPOK_on(value_sv);
break;
}
case lucy_FType_FLOAT32:
value_sv = newSVnv(Lucy_InStream_Read_F32(dat_in));
break;
case lucy_FType_FLOAT64:
value_sv = newSVnv(Lucy_InStream_Read_F64(dat_in));
break;
case lucy_FType_INT32:
value_sv = newSViv((int32_t)Lucy_InStream_Read_C32(dat_in));
break;
case lucy_FType_INT64:
if (sizeof(IV) == 8) {
int64_t val = (int64_t)Lucy_InStream_Read_C64(dat_in);
value_sv = newSViv((IV)val);
}
else { // (lossy)
int64_t val = (int64_t)Lucy_InStream_Read_C64(dat_in);
value_sv = newSVnv((double)val);
}
break;
default:
value_sv = NULL;
CFISH_THROW(LUCY_ERR, "Unrecognized type: %o", type);
}
// Store the value.
(void)hv_store_ent(fields, field_name_sv, value_sv, 0);
}
SvREFCNT_dec(field_name_sv);
lucy_HitDoc *retval = lucy_HitDoc_new(fields, doc_id, 0.0);
SvREFCNT_dec((SV*)fields);
return retval;
}
EXTERN SV*
decode_entities(pTHX_ SV* sv, HV* entity2char, bool expand_prefix)
{
STRLEN len;
char *s = SvPV_force(sv, len);
char *t = s;
char *end = s + len;
char *ent_start;
char *repl;
STRLEN repl_len;
#ifdef UNICODE_HTML_PARSER
char buf[UTF8_MAXLEN];
int repl_utf8;
int high_surrogate = 0;
#else
char buf[1];
#endif
#if defined(__GNUC__) && defined(UNICODE_HTML_PARSER)
/* gcc -Wall reports this variable as possibly used uninitialized */
repl_utf8 = 0;
#endif
while (s < end) {
assert(t <= s);
if ((*t++ = *s++) != '&')
continue;
ent_start = s;
repl = 0;
if (s < end && *s == '#') {
UV num = 0;
int ok = 0;
s++;
if (s < end && (*s == 'x' || *s == 'X')) {
s++;
while (s < end) {
char *tmp = strchr(PL_hexdigit, *s);
if (!tmp)
break;
num = num << 4 | ((tmp - PL_hexdigit) & 15);
if (num > 0x10FFFF) {
/* overflow */
ok = 0;
break;
}
s++;
ok = 1;
}
}
else {
while (s < end && isDIGIT(*s)) {
num = num * 10 + (*s - '0');
if (num > 0x10FFFF) {
/* overflow */
ok = 0;
break;
}
s++;
ok = 1;
}
}
if (num && ok) {
#ifdef UNICODE_HTML_PARSER
if (!SvUTF8(sv) && num <= 255) {
buf[0] = (char) num;
repl = buf;
repl_len = 1;
repl_utf8 = 0;
}
else if (num == 0xFFFE || num == 0xFFFF) {
/* illegal */
}
else {
char *tmp;
if ((num & 0xFFFFFC00) == 0xDC00) { /* low-surrogate */
if (high_surrogate != 0) {
t -= 3; /* Back up past 0xFFFD */
num = ((high_surrogate - 0xD800) << 10) +
(num - 0xDC00) + 0x10000;
high_surrogate = 0;
} else {
num = 0xFFFD;
}
}
else if ((num & 0xFFFFFC00) == 0xD800) { /* high-surrogate */
high_surrogate = num;
num = 0xFFFD;
}
else {
high_surrogate = 0;
/* otherwise invalid? */
if ((num >= 0xFDD0 && num <= 0xFDEF) ||
((num & 0xFFFE) == 0xFFFE) ||
num > 0x10FFFF)
{
num = 0xFFFD;
}
}
tmp = (char*)uvuni_to_utf8((U8*)buf, num);
repl = buf;
repl_len = tmp - buf;
repl_utf8 = 1;
}
#else
if (num <= 255) {
buf[0] = (char) num & 0xFF;
repl = buf;
repl_len = 1;
}
#endif
}
}
else {
char *ent_name = s;
while (s < end && isALNUM(*s))
s++;
if (ent_name != s && entity2char) {
SV** svp;
if ( (svp = hv_fetch(entity2char, ent_name, s - ent_name, 0)) ||
(*s == ';' && (svp = hv_fetch(entity2char, ent_name, s - ent_name + 1, 0)))
)
{
repl = SvPV(*svp, repl_len);
#ifdef UNICODE_HTML_PARSER
repl_utf8 = SvUTF8(*svp);
#endif
}
else if (expand_prefix) {
char *ss = s - 1;
while (ss > ent_name) {
svp = hv_fetch(entity2char, ent_name, ss - ent_name, 0);
if (svp) {
repl = SvPV(*svp, repl_len);
#ifdef UNICODE_HTML_PARSER
repl_utf8 = SvUTF8(*svp);
#endif
s = ss;
break;
}
ss--;
}
}
}
#ifdef UNICODE_HTML_PARSER
high_surrogate = 0;
#endif
}
if (repl) {
char *repl_allocated = 0;
if (s < end && *s == ';')
s++;
t--; /* '&' already copied, undo it */
#ifdef UNICODE_HTML_PARSER
if (*s != '&') {
high_surrogate = 0;
}
if (!SvUTF8(sv) && repl_utf8) {
/* need to upgrade sv before we continue */
STRLEN before_gap_len = t - SvPVX(sv);
char *before_gap = (char*)bytes_to_utf8((U8*)SvPVX(sv), &before_gap_len);
STRLEN after_gap_len = end - s;
char *after_gap = (char*)bytes_to_utf8((U8*)s, &after_gap_len);
sv_setpvn(sv, before_gap, before_gap_len);
sv_catpvn(sv, after_gap, after_gap_len);
SvUTF8_on(sv);
Safefree(before_gap);
Safefree(after_gap);
s = t = SvPVX(sv) + before_gap_len;
end = SvPVX(sv) + before_gap_len + after_gap_len;
}
else if (SvUTF8(sv) && !repl_utf8) {
repl = (char*)bytes_to_utf8((U8*)repl, &repl_len);
repl_allocated = repl;
}
#endif
if (t + repl_len > s) {
/* need to grow the string */
grow_gap(aTHX_ sv, repl_len - (s - t), &t, &s, &end);
}
/* copy replacement string into string */
while (repl_len--)
*t++ = *repl++;
if (repl_allocated)
Safefree(repl_allocated);
}
else {
while (ent_start < s)
*t++ = *ent_start++;
}
}
*t = '\0';
SvCUR_set(sv, t - SvPVX(sv));
return sv;
}
