static int
modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
{
dVAR;
SV *attr;
int nret;
for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
STRLEN len;
const char *name = SvPV_const(attr, len);
const bool negated = (*name == '-');
if (negated) {
name++;
len--;
}
switch (SvTYPE(sv)) {
case SVt_PVCV:
switch ((int)len) {
case 6:
switch (name[3]) {
case 'l':
if (memEQ(name, "lvalue", 6)) {
if (negated)
CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_LVALUE;
else
CvFLAGS(MUTABLE_CV(sv)) |= CVf_LVALUE;
continue;
}
break;
case 'h':
if (memEQ(name, "method", 6)) {
if (negated)
CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_METHOD;
else
CvFLAGS(MUTABLE_CV(sv)) |= CVf_METHOD;
continue;
}
break;
}
break;
}
break;
default:
if (memEQs(name, 6, "shared")) {
if (negated)
Perl_croak(aTHX_ "A variable may not be unshared");
SvSHARE(sv);
continue;
}
break;
}
/* anything recognized had a 'continue' above */
*retlist++ = attr;
nret++;
}
return nret;
}
SSize_t
PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
PerlIOBuf * const b = &m->base;
if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
PerlIO_flush(f);
if (b->ptr && (b->ptr - count) >= b->buf
&& memEQ(b->ptr - count, vbuf, count)) {
b->ptr -= count;
PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
return count;
}
if (m->len) {
/*
* Loose the unwritable mapped buffer
*/
PerlIO_flush(f);
/*
* If flush took the "buffer" see if we have one from before
*/
if (!b->buf && m->bbuf)
b->buf = m->bbuf;
if (!b->buf) {
PerlIOBuf_get_base(aTHX_ f);
m->bbuf = b->buf;
}
}
return PerlIOBuf_unread(aTHX_ f, vbuf, count);
}
/*
* search for the key in the page.
* return offset index in the range 0 < i < n.
* return 0 if not found.
*/
static int
seepair(char *pag, register int n, register const char *key, register int siz)
{
register int i;
register int off = PBLKSIZ;
register short *ino = (short *) pag;
for (i = 1; i < n; i += 2) {
if (siz == off - ino[i] &&
memEQ(key, pag + ino[i], siz))
return i;
off = ino[i + 1];
}
return 0;
}
static int
modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
{
SV *attr;
int nret;
for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
STRLEN len;
const char *name = SvPV_const(attr, len);
const bool negated = (*name == '-');
if (negated) {
name++;
len--;
}
switch (SvTYPE(sv)) {
case SVt_PVCV:
switch ((int)len) {
#ifdef CVf_ASSERTION
case 9:
if (memEQ(name, "assertion", 9)) {
if (negated)
CvFLAGS((CV*)sv) &= ~CVf_ASSERTION;
else
CvFLAGS((CV*)sv) |= CVf_ASSERTION;
continue;
}
break;
#endif
case 6:
switch (name[3]) {
case 'l':
#ifdef CVf_LVALUE
if (memEQ(name, "lvalue", 6)) {
if (negated)
CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
else
CvFLAGS((CV*)sv) |= CVf_LVALUE;
continue;
}
break;
case 'k':
#endif /* defined CVf_LVALUE */
if (memEQ(name, "locked", 6)) {
if (negated)
CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
else
CvFLAGS((CV*)sv) |= CVf_LOCKED;
continue;
}
break;
case 'h':
if (memEQ(name, "method", 6)) {
if (negated)
CvFLAGS((CV*)sv) &= ~CVf_METHOD;
else
CvFLAGS((CV*)sv) |= CVf_METHOD;
continue;
}
break;
}
break;
}
break;
default:
switch ((int)len) {
case 6:
switch (name[5]) {
case 'd':
if (memEQ(name, "share", 5)) {
if (negated)
Perl_croak(aTHX_ "A variable may not be unshared");
SvSHARE(sv);
continue;
}
break;
case 'e':
if (memEQ(name, "uniqu", 5)) {
if (SvTYPE(sv) == SVt_PVGV) {
if (negated) {
GvUNIQUE_off(sv);
} else {
GvUNIQUE_on(sv);
}
}
/* Hope this came from toke.c if not a GV. */
continue;
}
}
}
break;
}
/* anything recognized had a 'continue' above */
*retlist++ = attr;
nret++;
}
return nret;
}
int
do_encode(encpage_t * enc, const U8 * src, STRLEN * slen, U8 * dst,
STRLEN dlen, STRLEN * dout, int approx, const U8 *term, STRLEN tlen)
{
const U8 *s = src;
const U8 *send = s + *slen;
const U8 *last = s;
U8 *d = dst;
U8 *dend = d + dlen, *dlast = d;
int code = 0;
while (s < send) {
encpage_t *e = enc;
U8 byte = *s;
while (byte > e->max)
e++;
if (byte >= e->min && e->slen && (approx || !(e->slen & 0x80))) {
const U8 *cend = s + (e->slen & 0x7f);
if (cend <= send) {
STRLEN n;
if ((n = e->dlen)) {
const U8 *out = e->seq + n * (byte - e->min);
U8 *oend = d + n;
if (dst) {
if (oend <= dend) {
while (d < oend)
*d++ = *out++;
}
else {
/* Out of space */
code = ENCODE_NOSPACE;
break;
}
}
else
d = oend;
}
enc = e->next;
s++;
if (s == cend) {
if (approx && (e->slen & 0x80))
code = ENCODE_FALLBACK;
last = s;
if (term && (STRLEN)(d-dlast) == tlen && memEQ(dlast, term, tlen)) {
code = ENCODE_FOUND_TERM;
break;
}
dlast = d;
}
}
else {
/* partial source character */
code = ENCODE_PARTIAL;
break;
}
}
else {
/* Cannot represent */
code = ENCODE_NOREP;
break;
}
}
*slen = last - src;
*dout = d - dst;
return code;
}
/* helper for the default modify handler for builtin attributes */
static int
modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
{
SV *attr;
int nret;
for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
STRLEN len;
const char *name = SvPV_const(attr, len);
const bool negated = (*name == '-');
HV *typestash;
if (negated) {
name++;
len--;
}
switch (SvTYPE(sv)) {
case SVt_PVCV:
switch ((int)len) {
case 4:
if (memEQ(name, "pure", 4)) {
if (negated)
Perl_croak(aTHX_ "Illegal :-pure attribute");
CvPURE_on(sv);
goto next_attr;
}
break;
case 5:
if (memEQ(name, "const", 5)) {
if (negated)
CvCONST_off(sv);
else {
#ifndef USE_CPERL
const bool warn = (!CvANON(sv) || CvCLONED(sv))
&& !CvCONST(sv);
CvCONST_on(sv);
if (warn)
break;
#else
CvCONST_on(sv);
#endif
}
goto next_attr;
}
break;
case 6:
switch (name[3]) {
case 'l':
if (memEQ(name, "lvalue", 6)) {
bool warn =
!CvISXSUB(MUTABLE_CV(sv))
&& CvROOT(MUTABLE_CV(sv))
&& !CvLVALUE(MUTABLE_CV(sv)) != negated;
if (negated)
CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_LVALUE;
else
CvFLAGS(MUTABLE_CV(sv)) |= CVf_LVALUE;
if (warn) break;
goto next_attr;
}
break;
case 'h':
if (memEQ(name, "method", 6)) {
if (negated)
CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_METHOD;
else
CvFLAGS(MUTABLE_CV(sv)) |= CVf_METHOD;
goto next_attr;
}
break;
}
break;
default:
if (len > 10 && memEQ(name, "prototype(", 10)) {
SV * proto = newSVpvn(name+10,len-11);
HEK *const hek = CvNAME_HEK((CV *)sv);
SV *subname;
if (name[len-1] != ')')
Perl_croak(aTHX_ "Unterminated attribute parameter in attribute list");
if (hek)
subname = sv_2mortal(newSVhek(hek));
else
subname=(SV *)CvGV((const CV *)sv);
if (ckWARN(WARN_ILLEGALPROTO))
Perl_validate_proto(aTHX_ subname, proto, TRUE);
Perl_cv_ckproto_len_flags(aTHX_ (const CV *)sv,
(const GV *)subname,
name+10,
len-11,
SvUTF8(attr));
sv_setpvn(MUTABLE_SV(sv), name+10, len-11);
if (SvUTF8(attr)) SvUTF8_on(MUTABLE_SV(sv));
goto next_attr;
}
break;
}
if (!negated && (typestash = gv_stashpvn(name, len, SvUTF8(attr)))) {
CvTYPED_on(sv);
CvTYPE_set((CV*)sv, typestash);
continue;
}
break;
case SVt_IV:
case SVt_PVIV:
case SVt_PVMG:
if (memEQ(name, "unsigned", 8)
&& (SvIOK(sv) || SvUOK(sv)))
{
if (negated) /* :-unsigned alias for :signed */
SvIsUV_off(sv);
else
SvIsUV_on(sv);
continue;
}
/* fallthru - all other data types */
default:
if (memEQ(name, "const", 5)
&& !(SvFLAGS(sv) & SVf_PROTECT))
{
if (negated)
SvREADONLY_off(sv);
else
SvREADONLY_on(sv);
continue;
}
if (memEQs(name, len, "shared")) {
if (negated)
Perl_croak(aTHX_ "A variable may not be unshared");
SvSHARE(sv);
continue;
}
break;
}
/* anything recognized had a 'continue' above */
*retlist++ = attr;
nret++;
next_attr:
;
}
return nret;
}
