sign = 1;
}
do {
- *--ptr = '0' + (uv % 10);
+ *--ptr = '0' + (char)(uv % 10);
} while (uv /= 10);
if (sign)
*--ptr = '-';
return ptr;
}
-/* sv_2pv() is now a macro using Perl_sv_2pv_flags();
- * this function provided for binary compatibility only
- */
-
-char *
-Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
-{
- return sv_2pv_flags(sv, lp, SV_GMAGIC);
-}
-
/*
=for apidoc sv_2pv_flags
int left = 0;
int right = 4;
char need_newline = 0;
- U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
+ U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
while((ch = *fptr++)) {
if(reganch & 1) {
ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
else
ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
- SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
+ SvGROW(sv, (STRLEN)(ebuf - ptr + 1)); /* inlined from sv_setpvn */
Move(ptr,SvPVX(sv),ebuf - ptr,char);
SvCUR_set(sv, ebuf - ptr);
s = SvEND(sv);
void
Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
{
- SV *tmpsv = sv_newmortal();
+ SV *tmpsv;
- if ( SvTHINKFIRST(ssv) && SvROK(ssv) && SvAMAGIC(ssv) ) {
- tmpsv = AMG_CALLun(ssv,string);
+ if ( SvTHINKFIRST(ssv) && SvROK(ssv) && SvAMAGIC(ssv) &&
+ (tmpsv = AMG_CALLun(ssv,string))) {
if (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(ssv))) {
SvSetSV(dsv,tmpsv);
return;
}
+ } else {
+ tmpsv = sv_newmortal();
}
{
STRLEN len;
SV* tmpsv;
if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
(!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
- return SvTRUE(tmpsv);
+ return (bool)SvTRUE(tmpsv);
return SvRV(sv) != 0;
}
if (SvPOKp(sv)) {
This is not as a general purpose byte encoding to Unicode interface:
use the Encode extension for that.
-=cut
-*/
-
-/* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
- * this function provided for binary compatibility only
- */
-
-
-STRLEN
-Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
-{
- return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
-}
-
-/*
=for apidoc sv_utf8_upgrade_flags
Convert the PV of an SV to its UTF8-encoded form.
C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
C<SvSetMagicSV_nosteal>.
-
-=cut
-*/
-
-/* sv_setsv() is now a macro using Perl_sv_setsv_flags();
- * this function provided for binary compatibility only
- */
-
-void
-Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
-{
- sv_setsv_flags(dstr, sstr, SV_GMAGIC);
-}
-
-/*
=for apidoc sv_setsv_flags
Copies the contents of the source SV C<ssv> into the destination SV
default:
if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
mg_get(sstr);
- if (SvTYPE(sstr) != stype) {
+ if ((int)SvTYPE(sstr) != stype) {
stype = SvTYPE(sstr);
if (stype == SVt_PVGV && dtype <= SVt_PVGV)
goto glob_assign;
if (stype == SVt_PVLV)
(void)SvUPGRADE(dstr, SVt_PVNV);
else
- (void)SvUPGRADE(dstr, stype);
+ (void)SvUPGRADE(dstr, (U32)stype);
}
sflags = SvFLAGS(sstr);
status set, then the bytes appended should be valid UTF8.
Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
-=cut
-*/
-
-/* sv_catpvn() is now a macro using Perl_sv_catpvn_flags();
- * this function provided for binary compatibility only
- */
-
-void
-Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
-{
- sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
-}
-
-/*
=for apidoc sv_catpvn_flags
Concatenates the string onto the end of the string which is in the SV. The
SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
not 'set' magic. See C<sv_catsv_mg>.
-=cut */
-
-/* sv_catsv() is now a macro using Perl_sv_catsv_flags();
- * this function provided for binary compatibility only
- */
-
-void
-Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
-{
- sv_catsv_flags(dstr, sstr, SV_GMAGIC);
-}
-
-/*
=for apidoc sv_catsv_flags
Concatenates the string from SV C<ssv> onto the end of the string in
/* Some magic sontains a reference loop, where the sv and object refer to
each other. To prevent a reference loop that would prevent such
objects being freed, we look for such loops and if we find one we
- avoid incrementing the object refcount. */
+ avoid incrementing the object refcount.
+
+ Note we cannot do this to avoid self-tie loops as intervening RV must
+ have its REFCNT incremented to keep it in existence - instead we could
+ special case them in sv_free() -- NI-S
+
+ */
if (!obj || obj == sv ||
how == PERL_MAGIC_arylen ||
how == PERL_MAGIC_qr ||
return;
s = (U8*)SvPV(sv, len);
- if (len < *offsetp)
+ if ((I32)len < *offsetp)
Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
send = s + *offsetp;
len = 0;
while (s < send) {
- STRLEN n;
- /* Call utf8n_to_uvchr() to validate the sequence */
- utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
+ STRLEN n = 1;
+ /* Call utf8n_to_uvchr() to validate the sequence
+ * (unless a simple non-UTF character) */
+ if (!UTF8_IS_INVARIANT(*s))
+ utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
if (n > 0) {
s += n;
len++;
/* Grab the size of the record we're getting */
recsize = SvIV(SvRV(PL_rs));
(void)SvPOK_only(sv); /* Validate pointer */
- buffer = SvGROW(sv, recsize + 1);
+ buffer = SvGROW(sv, (STRLEN)(recsize + 1));
/* Go yank in */
#ifdef VMS
/* VMS wants read instead of fread, because fread doesn't respect */
cnt = PerlIO_get_cnt(fp); /* get count into register */
(void)SvPOK_only(sv); /* validate pointer */
- if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
- if (cnt > 80 && SvLEN(sv) > append) {
+ if ((I32)(SvLEN(sv) - append) <= cnt + 1) { /* make sure we have the room */
+ if (cnt > 80 && (I32)SvLEN(sv) > append) {
shortbuffered = cnt - SvLEN(sv) + append + 1;
cnt -= shortbuffered;
}
else {
shortbuffered = 0;
/* remember that cnt can be negative */
- SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
+ SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
}
}
else
SvGROW(sv, bpx + cnt + 2);
bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
- *bp++ = i; /* store character from PerlIO_getc */
+ *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
if (rslen && (STDCHAR)i == rslast) /* all done for now? */
goto thats_all_folks;
}
thats_all_folks:
- if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
+ if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX(sv)) < rslen) ||
memNE((char*)bp - rslen, rsptr, rslen))
goto screamer; /* go back to the fray */
thats_really_all_folks:
if (rslen) {
register STDCHAR *bpe = buf + sizeof(buf);
bp = buf;
- while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
+ while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
; /* keep reading */
cnt = bp - buf;
}
/* Accomodate broken VAXC compiler, which applies U8 cast to
* both args of ?: operator, causing EOF to change into 255
*/
- if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
+ if (cnt > 0) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
}
- if (append)
- sv_catpvn(sv, (char *) buf, cnt);
- else
- sv_setpvn(sv, (char *) buf, cnt);
+ if (cnt > 0) {
+ if (append)
+ sv_catpvn(sv, (char *) buf, cnt);
+ else
+ sv_setpvn(sv, (char *) buf, cnt);
+ }
if (i != EOF && /* joy */
(!rslen ||
if (GvHV(gv) && !HvNAME(GvHV(gv))) {
hv_clear(GvHV(gv));
#ifdef USE_ENVIRON_ARRAY
- if (gv == PL_envgv)
+ if (gv == PL_envgv
+# ifdef USE_ITHREADS
+ && PL_curinterp == aTHX
+# endif
+ )
+ {
environ[0] = Nullch;
+ }
#endif
}
}
Use the C<SvPV_nolen> macro instead
-=cut
-*/
-
-/* sv_pv() is now a macro using SvPV_nolen();
- * this function provided for binary compatibility only
- */
-
-
-char *
-Perl_sv_pv(pTHX_ SV *sv)
-{
- STRLEN n_a;
-
- if (SvPOK(sv))
- return SvPVX(sv);
-
- return sv_2pv(sv, &n_a);
-}
-
-/*
=for apidoc sv_pvn
A private implementation of the C<SvPV> macro for compilers which can't
A private implementation of the C<SvPV_force> macro for compilers which
can't cope with complex macro expressions. Always use the macro instead.
-=cut
-*/
-
-/* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
- * this function provided for binary compatibility only
- */
-
-char *
-Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
-{
- return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
-}
-
-/*
=for apidoc sv_pvn_force_flags
Get a sensible string out of the SV somehow.
Use C<SvPVbyte_nolen> instead.
-=cut
-*/
-
-/* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
- * this function provided for binary compatibility only
- */
-
-
-char *
-Perl_sv_pvbyte(pTHX_ SV *sv)
-{
- sv_utf8_downgrade(sv,0);
- return sv_pv(sv);
-}
-
-/*
=for apidoc sv_pvbyten
A private implementation of the C<SvPVbyte> macro for compilers
Use the C<SvPVutf8_nolen> macro instead
-=cut
-*/
-/* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
- * this function provided for binary compatibility only
- */
-
-
-char *
-Perl_sv_pvutf8(pTHX_ SV *sv)
-{
- sv_utf8_upgrade(sv);
- return sv_pv(sv);
-}
-
-/*
=for apidoc sv_pvutf8n
A private implementation of the C<SvPVutf8> macro for compilers
}
/* Downgrades a PVGV to a PVMG.
- *
- * XXX This function doesn't actually appear to be used anywhere
- * DAPM 15-Jun-01
*/
STATIC void
return FALSE;
}
-/*
-=for apidoc sv_setpviv
-
-Copies an integer into the given SV, also updating its string value.
-Does not handle 'set' magic. See C<sv_setpviv_mg>.
-
-=cut
-*/
-
-void
-Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
-{
- char buf[TYPE_CHARS(UV)];
- char *ebuf;
- char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
-
- sv_setpvn(sv, ptr, ebuf - ptr);
-}
-
-/*
-=for apidoc sv_setpviv_mg
-
-Like C<sv_setpviv>, but also handles 'set' magic.
-
-=cut
-*/
-
-void
-Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
-{
- char buf[TYPE_CHARS(UV)];
- char *ebuf;
- char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
-
- sv_setpvn(sv, ptr, ebuf - ptr);
- SvSETMAGIC(sv);
-}
-
#if defined(PERL_IMPLICIT_CONTEXT)
/* pTHX_ magic can't cope with varargs, so this is a no-context
/* large enough for "%#.#f" --chip */
/* what about long double NVs? --jhi */
- SV *vecsv;
+ SV *vecsv = Nullsv;
U8 *vecstr = Null(U8*);
STRLEN veclen = 0;
char c = 0;
unsigned base = 0;
IV iv = 0;
UV uv = 0;
+ /* we need a long double target in case HAS_LONG_DOUBLE but
+ not USE_LONG_DOUBLE
+ */
+#if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
+ long double nv;
+#else
NV nv;
+#endif
STRLEN have;
STRLEN need;
STRLEN gap;
We allow format specification elements in this order:
\d+\$ explicit format parameter index
[-+ 0#]+ flags
- \*?(\d+\$)?v vector with optional (optionally specified) arg
+ v|*(\d+\$)?v vector with optional (optionally specified) arg
\d+|\*(\d+\$)? width using optional (optionally specified) arg
\.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
[hlqLV] size
q++;
if (*q == '*') {
q++;
- if (EXPECT_NUMBER(q, epix) && *q++ != '$') /* epix currently unused */
+ if (EXPECT_NUMBER(q, epix) && *q++ != '$')
+ goto unknown;
+ /* XXX: todo, support specified precision parameter */
+ if (epix)
goto unknown;
if (args)
i = va_arg(*args, int);
q++;
break;
#endif
-#if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
+#if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
case 'L': /* Ld */
/* FALL THROUGH */
-#endif
#ifdef HAS_QUAD
case 'q': /* qd */
+#endif
intsize = 'q';
q++;
break;
#endif
case 'l':
-#if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
+#if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
if (*(q + 1) == 'l') { /* lld, llf */
intsize = 'q';
q += 2;
goto string;
}
- if (!args)
+ if (vectorize)
+ argsv = vecsv;
+ else if (!args)
argsv = (efix ? efix <= svmax : svix < svmax) ?
svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
/* STRINGS */
case 'c':
- uv = args ? va_arg(*args, int) : SvIVx(argsv);
+ uv = (args && !vectorize) ? va_arg(*args, int) : SvIVx(argsv);
if ((uv > 255 ||
(!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
&& !IN_BYTES) {
goto string;
case 's':
- if (args) {
+ if (args && !vectorize) {
eptr = va_arg(*args, char*);
if (eptr)
#ifdef MACOS_TRADITIONAL
* if ISO or ANSI decide to use '_' for something.
* So we keep it hidden from users' code.
*/
- if (!args)
+ if (!args || vectorize)
goto unknown;
argsv = va_arg(*args, SV*);
eptr = SvPVx(argsv, elen);
/* INTEGERS */
case 'p':
- if (alt)
+ if (alt || vectorize)
goto unknown;
uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
base = 16;
/* This is evil, but floating point is even more evil */
- vectorize = FALSE;
- nv = args ? va_arg(*args, NV) : SvNVx(argsv);
+ /* for SV-style calling, we can only get NV
+ for C-style calling, we assume %f is double;
+ for simplicity we allow any of %Lf, %llf, %qf for long double
+ */
+ switch (intsize) {
+ case 'V':
+#if defined(USE_LONG_DOUBLE)
+ intsize = 'q';
+#endif
+ break;
+ default:
+#if defined(USE_LONG_DOUBLE)
+ intsize = args ? 0 : 'q';
+#endif
+ break;
+ case 'q':
+#if defined(HAS_LONG_DOUBLE)
+ break;
+#else
+ /* FALL THROUGH */
+#endif
+ case 'h':
+ /* FALL THROUGH */
+ case 'l':
+ goto unknown;
+ }
+
+ /* now we need (long double) if intsize == 'q', else (double) */
+ nv = (args && !vectorize) ?
+#if LONG_DOUBLESIZE > DOUBLESIZE
+ intsize == 'q' ?
+ va_arg(*args, long double) :
+ va_arg(*args, double)
+#else
+ va_arg(*args, double)
+#endif
+ : SvNVx(argsv);
need = 0;
+ vectorize = FALSE;
if (c != 'e' && c != 'E') {
i = PERL_INT_MIN;
+ /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
+ will cast our (long double) to (double) */
(void)Perl_frexp(nv, &i);
if (i == PERL_INT_MIN)
Perl_die(aTHX_ "panic: frexp");
eptr = ebuf + sizeof ebuf;
*--eptr = '\0';
*--eptr = c;
-#if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
- {
+ /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
+#if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
+ if (intsize == 'q') {
/* Copy the one or more characters in a long double
* format before the 'base' ([efgEFG]) character to
* the format string. */
/* No taint. Otherwise we are in the strange situation
* where printf() taints but print($float) doesn't.
* --jhi */
+#if defined(HAS_LONG_DOUBLE)
+ if (intsize == 'q')
+ (void)sprintf(PL_efloatbuf, eptr, nv);
+ else
+ (void)sprintf(PL_efloatbuf, eptr, (double)nv);
+#else
(void)sprintf(PL_efloatbuf, eptr, nv);
-
+#endif
eptr = PL_efloatbuf;
elen = strlen(PL_efloatbuf);
break;
/* SPECIAL */
case 'n':
- vectorize = FALSE;
i = SvCUR(sv) - origlen;
- if (args) {
+ if (args && !vectorize) {
switch (intsize) {
case 'h': *(va_arg(*args, short*)) = i; break;
default: *(va_arg(*args, int*)) = i; break;
}
else
sv_setuv_mg(argsv, (UV)i);
+ vectorize = FALSE;
continue; /* not "break" */
/* UNKNOWN */
SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
p = SvEND(sv);
if (esignlen && fill == '0') {
- for (i = 0; i < esignlen; i++)
+ for (i = 0; i < (int)esignlen; i++)
*p++ = esignbuf[i];
}
if (gap && !left) {
p += gap;
}
if (esignlen && fill != '0') {
- for (i = 0; i < esignlen; i++)
+ for (i = 0; i < (int)esignlen; i++)
*p++ = esignbuf[i];
}
if (zeros) {
for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
if (tblent->oldval == oldv) {
tblent->newval = newv;
- tbl->tbl_items++;
return;
}
}
/* attempt to make everything in the typeglob readonly */
STATIC SV *
-S_gv_share(pTHX_ SV *sstr)
+S_gv_share(pTHX_ SV *sstr, CLONE_PARAMS *param)
{
GV *gv = (GV*)sstr;
- SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
+ SV *sv = ¶m->proto_perl->Isv_no; /* just need SvREADONLY-ness */
if (GvIO(gv) || GvFORM(gv)) {
GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
}
else {
/* CvPADLISTs cannot be shared */
- if (!CvXSUB(GvCV(gv))) {
+ if (!SvREADONLY(GvCV(gv)) && !CvXSUB(GvCV(gv))) {
GvUNIQUE_off(gv);
}
}
case SVt_PVGV:
if (GvUNIQUE((GV*)sstr)) {
SV *share;
- if ((share = gv_share(sstr))) {
+ if ((share = gv_share(sstr, param))) {
del_SV(dstr);
dstr = share;
+ ptr_table_store(PL_ptr_table, sstr, dstr);
#if 0
PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
HvNAME(GvSTASH(share)), GvNAME(share));
PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
while (i <= sxhv->xhv_max) {
((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
- !!HvSHAREKEYS(sstr), param);
+ (bool)!!HvSHAREKEYS(sstr),
+ param);
++i;
}
- dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr), param);
+ dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter,
+ (bool)!!HvSHAREKEYS(sstr), param);
}
else {
SvPVX(dstr) = Nullch;
CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
break;
default:
- Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
+ Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
break;
}
case CXt_EVAL:
ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
- ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);;
+ ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
break;
PERL_SET_THX(my_perl);
# ifdef DEBUGGING
- memset(my_perl, 0xab, sizeof(PerlInterpreter));
+ Poison(my_perl, 1, PerlInterpreter);
PL_markstack = 0;
PL_scopestack = 0;
PL_savestack = 0;
# ifdef DEBUGGING
- memset(my_perl, 0xab, sizeof(PerlInterpreter));
+ Poison(my_perl, 1, PerlInterpreter);
PL_markstack = 0;
PL_scopestack = 0;
PL_savestack = 0;
# endif /* DEBUGGING */
#endif /* PERL_IMPLICIT_SYS */
param->flags = flags;
+ param->proto_perl = proto_perl;
/* arena roots */
PL_xiv_arenaroot = NULL;
Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
PL_nexttoke = proto_perl->Inexttoke;
- PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
- i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
- PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
- i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
- PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
- i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
- PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
+ /* XXX This is probably masking the deeper issue of why
+ * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
+ * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
+ * (A little debugging with a watchpoint on it may help.)
+ */
+ if (SvANY(proto_perl->Ilinestr)) {
+ PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
+ i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
+ PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
+ i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
+ PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
+ i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
+ PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
+ i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
+ PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
+ }
+ else {
+ PL_linestr = NEWSV(65,79);
+ sv_upgrade(PL_linestr,SVt_PVIV);
+ sv_setpvn(PL_linestr,"",0);
+ PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
+ }
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
- i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
- PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
PL_pending_ident = proto_perl->Ipending_ident;
PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
PL_padix_floor = proto_perl->Ipadix_floor;
PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
- i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
- PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
- i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
- PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
- PL_last_lop_op = proto_perl->Ilast_lop_op;
+ /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
+ if (SvANY(proto_perl->Ilinestr)) {
+ i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
+ PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
+ i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
+ PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
+ PL_last_lop_op = proto_perl->Ilast_lop_op;
+ }
+ else {
+ PL_last_uni = SvPVX(PL_linestr);
+ PL_last_lop = SvPVX(PL_linestr);
+ PL_last_lop_op = 0;
+ }
PL_in_my = proto_perl->Iin_my;
PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
#ifdef FCRYPT
PL_retstack_ix = proto_perl->Tretstack_ix;
PL_retstack_max = proto_perl->Tretstack_max;
Newz(54, PL_retstack, PL_retstack_max, OP*);
- Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
+ Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, OP*);
/* NOTE: si_dup() looks at PL_markstack */
PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
char *
Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
{
- if (SvPOK(sv) && !DO_UTF8(sv) && SvROK(encoding)) {
+ if (SvPOK(sv) && !DO_UTF8(sv) && SvROK(encoding)) {
SV *uni;
STRLEN len;
char *s;
EXTEND(SP, 3);
XPUSHs(encoding);
XPUSHs(sv);
+/*
+ NI-S 2002/07/09
+ Passing sv_yes is wrong - it needs to be or'ed set of constants
+ for Encode::XS, while UTf-8 decode (currently) assumes a true value means
+ remove converted chars from source.
+
+ Both will default the value - let them.
+
XPUSHs(&PL_sv_yes);
+*/
PUTBACK;
call_method("decode", G_SCALAR);
SPAGAIN;
PUTBACK;
s = SvPV(uni, len);
if (s != SvPVX(sv)) {
- SvGROW(sv, len);
+ SvGROW(sv, len + 1);
Move(s, SvPVX(sv), len, char);
SvCUR_set(sv, len);
+ SvPVX(sv)[len] = 0;
}
FREETMPS;
LEAVE;
SvUTF8_on(sv);
- }
- return SvPVX(sv);
+ }
+ return SvPVX(sv);
}
+