Public API:
- sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
+ sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
=cut
return visited;
}
+#ifdef DEBUGGING
+
/* called by sv_report_used() for each live SV */
static void
sv_dump(sv);
}
}
+#endif
/*
=for apidoc sv_report_used
void
Perl_sv_report_used(pTHX)
{
+#ifdef DEBUGGING
visit(do_report_used);
+#endif
}
/* called by sv_clean_objs() for each live SV */
STATIC void
S_not_a_number(pTHX_ SV *sv)
{
- char tmpbuf[64];
- char *d = tmpbuf;
- char *limit = tmpbuf + sizeof(tmpbuf) - 8;
- /* each *s can expand to 4 chars + "...\0",
- i.e. need room for 8 chars */
-
- char *s, *end;
- for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
- int ch = *s & 0xFF;
- if (ch & 128 && !isPRINT_LC(ch)) {
- *d++ = 'M';
- *d++ = '-';
- ch &= 127;
- }
- if (ch == '\n') {
- *d++ = '\\';
- *d++ = 'n';
- }
- else if (ch == '\r') {
- *d++ = '\\';
- *d++ = 'r';
- }
- else if (ch == '\f') {
- *d++ = '\\';
- *d++ = 'f';
- }
- else if (ch == '\\') {
- *d++ = '\\';
- *d++ = '\\';
- }
- else if (ch == '\0') {
- *d++ = '\\';
- *d++ = '0';
- }
- else if (isPRINT_LC(ch))
- *d++ = ch;
- else {
- *d++ = '^';
- *d++ = toCTRL(ch);
- }
- }
- if (s < end) {
- *d++ = '.';
- *d++ = '.';
- *d++ = '.';
+ SV *dsv;
+ char tmpbuf[64];
+ char *pv;
+
+ if (DO_UTF8(sv)) {
+ dsv = sv_2mortal(newSVpv("", 0));
+ pv = sv_uni_display(dsv, sv, 10, 0);
+ } else {
+ char *d = tmpbuf;
+ char *limit = tmpbuf + sizeof(tmpbuf) - 8;
+ /* each *s can expand to 4 chars + "...\0",
+ i.e. need room for 8 chars */
+
+ char *s, *end;
+ for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
+ int ch = *s & 0xFF;
+ if (ch & 128 && !isPRINT_LC(ch)) {
+ *d++ = 'M';
+ *d++ = '-';
+ ch &= 127;
+ }
+ if (ch == '\n') {
+ *d++ = '\\';
+ *d++ = 'n';
+ }
+ else if (ch == '\r') {
+ *d++ = '\\';
+ *d++ = 'r';
+ }
+ else if (ch == '\f') {
+ *d++ = '\\';
+ *d++ = 'f';
+ }
+ else if (ch == '\\') {
+ *d++ = '\\';
+ *d++ = '\\';
+ }
+ else if (ch == '\0') {
+ *d++ = '\\';
+ *d++ = '0';
+ }
+ else if (isPRINT_LC(ch))
+ *d++ = ch;
+ else {
+ *d++ = '^';
+ *d++ = toCTRL(ch);
+ }
+ }
+ if (s < end) {
+ *d++ = '.';
+ *d++ = '.';
+ *d++ = '.';
+ }
+ *d = '\0';
+ pv = tmpbuf;
}
- *d = '\0';
if (PL_op)
Perl_warner(aTHX_ WARN_NUMERIC,
- "Argument \"%s\" isn't numeric in %s", tmpbuf,
- OP_DESC(PL_op));
+ "Argument \"%s\" isn't numeric in %s", pv,
+ OP_DESC(PL_op));
else
Perl_warner(aTHX_ WARN_NUMERIC,
- "Argument \"%s\" isn't numeric", tmpbuf);
+ "Argument \"%s\" isn't numeric", pv);
}
/*
SvIVX(sv) = -(IV)value;
} else {
/* Too negative for an IV. This is a double upgrade, but
- I'm assuming it will be be rare. */
+ I'm assuming it will be rare. */
if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
SvNOK_on(sv);
SvIVX(sv) = -(IV)value;
} else {
/* Too negative for an IV. This is a double upgrade, but
- I'm assuming it will be be rare. */
+ I'm assuming it will be rare. */
if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
SvNOK_on(sv);
default: s = "UNKNOWN"; break;
}
tsv = NEWSV(0,0);
- if (SvOBJECT(sv))
- Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
+ if (SvOBJECT(sv)) {
+ HV *svs = SvSTASH(sv);
+ Perl_sv_setpvf(
+ aTHX_ tsv, "%s=%s",
+ /* [20011101.072] This bandaid for C<package;>
+ should eventually be removed. AMS 20011103 */
+ (svs ? HvNAME(svs) : "<none>"), s
+ );
+ }
else
sv_setpv(tsv, s);
Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
=for apidoc sv_2bool
This function is only called on magical items, and is only used by
-sv_true() or its macro equivalent.
+sv_true() or its macro equivalent.
=cut
*/
sv_force_normal(sv);
}
- /* This function could be much more efficient if we had a FLAG in SVs
- * to signal if there are any hibit chars in the PV.
- * Given that there isn't make loop fast as possible
- */
- s = (U8 *) SvPVX(sv);
- e = (U8 *) SvEND(sv);
- t = s;
- while (t < e) {
- U8 ch = *t++;
- if ((hibit = !NATIVE_IS_INVARIANT(ch)))
- break;
- }
- if (hibit) {
- STRLEN len;
-
- len = SvCUR(sv) + 1; /* Plus the \0 */
- SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
- SvCUR(sv) = len - 1;
- if (SvLEN(sv) != 0)
- Safefree(s); /* No longer using what was there before. */
- SvLEN(sv) = len; /* No longer know the real size. */
+ if (PL_encoding)
+ Perl_sv_recode_to_utf8(aTHX_ sv, PL_encoding);
+ else { /* Assume Latin-1/EBCDIC */
+ /* This function could be much more efficient if we
+ * had a FLAG in SVs to signal if there are any hibit
+ * chars in the PV. Given that there isn't such a flag
+ * make the loop as fast as possible. */
+ s = (U8 *) SvPVX(sv);
+ e = (U8 *) SvEND(sv);
+ t = s;
+ while (t < e) {
+ U8 ch = *t++;
+ if ((hibit = !NATIVE_IS_INVARIANT(ch)))
+ break;
+ }
+ if (hibit) {
+ STRLEN len;
+
+ len = SvCUR(sv) + 1; /* Plus the \0 */
+ SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
+ SvCUR(sv) = len - 1;
+ if (SvLEN(sv) != 0)
+ Safefree(s); /* No longer using what was there before. */
+ SvLEN(sv) = len; /* No longer know the real size. */
+ }
+ /* Mark as UTF-8 even if no hibit - saves scanning loop */
+ SvUTF8_on(sv);
}
- /* Mark as UTF-8 even if no hibit - saves scanning loop */
- SvUTF8_on(sv);
return SvCUR(sv);
}
if ((spv = SvPV(ssv, slen))) {
/* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
gcc version 2.95.2 20000220 (Debian GNU/Linux) for
- Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
- get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
+ Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
+ get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
dsv->sv_flags doesn't have that bit set.
Andy Dougherty 12 Oct 2001
*/
mg->mg_moremagic = SvMAGIC(sv);
SvMAGIC(sv) = mg;
- /* Some magic contains a reference loop, where the sv and object refer to
- each other. To avoid 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. */
+ /* 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. */
if (!obj || obj == sv ||
how == PERL_MAGIC_arylen ||
how == PERL_MAGIC_qr ||
DEBUG_P(PerlIO_printf(Perl_debug_log,
"Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
PTR2UV(ptr),(long)cnt));
- PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
+ PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
DEBUG_P(PerlIO_printf(Perl_debug_log,
"Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
cnt += shortbuffered;
DEBUG_P(PerlIO_printf(Perl_debug_log,
"Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
- PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
+ PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
DEBUG_P(PerlIO_printf(Perl_debug_log,
"Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
if (SvGMAGICAL(sv))
mg_get(sv);
if (SvTHINKFIRST(sv)) {
+ if (SvREADONLY(sv) && SvFAKE(sv))
+ sv_force_normal(sv);
if (SvREADONLY(sv)) {
if (PL_curcop != &PL_compiling)
Perl_croak(aTHX_ PL_no_modify);
#endif
if (SvIsUV(sv)) {
if (SvUVX(sv) == UV_MAX)
- sv_setnv(sv, (NV)UV_MAX + 1.0);
+ sv_setnv(sv, UV_MAX_P1);
else
(void)SvIOK_only_UV(sv);
++SvUVX(sv);
while (isDIGIT(*d)) d++;
if (*d) {
#ifdef PERL_PRESERVE_IVUV
- /* Got to punt this an an integer if needs be, but we don't issue
+ /* Got to punt this as an integer if needs be, but we don't issue
warnings. Probably ought to make the sv_iv_please() that does
the conversion if possible, and silently. */
int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
if (SvGMAGICAL(sv))
mg_get(sv);
if (SvTHINKFIRST(sv)) {
+ if (SvREADONLY(sv) && SvFAKE(sv))
+ sv_force_normal(sv);
if (SvREADONLY(sv)) {
if (PL_curcop != &PL_compiling)
Perl_croak(aTHX_ PL_no_modify);
char *
Perl_sv_reftype(pTHX_ SV *sv, int ob)
{
- if (ob && SvOBJECT(sv))
- return HvNAME(SvSTASH(sv));
+ if (ob && SvOBJECT(sv)) {
+ HV *svs = SvSTASH(sv);
+ /* [20011101.072] This bandaid for C<package;> should eventually
+ be removed. AMS 20011103 */
+ return (svs ? HvNAME(svs) : "<none>");
+ }
else {
switch (SvTYPE(sv)) {
case SVt_NULL:
else
SvAMAGIC_off(sv);
+ if(SvSMAGICAL(tmpRef))
+ if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
+ mg_set(tmpRef);
+
+
+
return sv;
}
#define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
#define SAVEPV(p) (p ? savepv(p) : Nullch)
#define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
-
+
/* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
regcomp.c. AMS 20010712 */
REGEXP *
-Perl_re_dup(pTHX_ REGEXP *r, clone_params *param)
+Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param)
{
REGEXP *ret;
int i, len, npar;
/* duplicate a file handle */
PerlIO *
-Perl_fp_dup(pTHX_ PerlIO *fp, char type)
+Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
{
PerlIO *ret;
if (!fp)
return ret;
/* create anew and remember what it is */
- ret = PerlIO_fdupopen(aTHX_ fp);
+ ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
ptr_table_store(PL_ptr_table, fp, ret);
return ret;
}
/* duplicate a typeglob */
GP *
-Perl_gp_dup(pTHX_ GP *gp, clone_params* param)
+Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
{
GP *ret;
if (!gp)
/* duplicate a chain of magic */
MAGIC *
-Perl_mg_dup(pTHX_ MAGIC *mg, clone_params* param)
+Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
{
MAGIC *mgprev = (MAGIC*)NULL;
MAGIC *mgret;
/* duplicate an SV of any type (including AV, HV etc) */
SV *
-Perl_sv_dup(pTHX_ SV *sstr, clone_params* param)
+Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
{
SV *dstr;
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
- IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
+ IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr), param);
if (IoOFP(sstr) == IoIFP(sstr))
IoOFP(dstr) = IoIFP(dstr);
else
- IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
+ IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr), param);
/* PL_rsfp_filters entries have fake IoDIRP() */
if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
/* duplicate a context */
PERL_CONTEXT *
-Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, clone_params* param)
+Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
{
PERL_CONTEXT *ncxs;
/* duplicate a stack info structure */
PERL_SI *
-Perl_si_dup(pTHX_ PERL_SI *si, clone_params* param)
+Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
{
PERL_SI *nsi;
/* duplicate the save stack */
ANY *
-Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, clone_params* param)
+Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
{
ANY *ss = proto_perl->Tsavestack;
I32 ix = proto_perl->Tsavestack_ix;
* their pointers copied. */
IV i;
- clone_params* param = (clone_params*) malloc(sizeof(clone_params));
+ CLONE_PARAMS* param = (CLONE_PARAMS*) malloc(sizeof(CLONE_PARAMS));
PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
PERL_SET_THX(my_perl);
PL_Proc = ipP;
#else /* !PERL_IMPLICIT_SYS */
IV i;
- clone_params* param = (clone_params*) malloc(sizeof(clone_params));
+ CLONE_PARAMS* param = (CLONE_PARAMS*) malloc(sizeof(CLONE_PARAMS));
PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
PERL_SET_THX(my_perl);
PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
}
-
param->stashes = newAV(); /* Setup array of objects to call clone on */
+#ifdef PERLIO_LAYERS
+ /* Clone PerlIO tables as soon as we can handle general xx_dup() */
+ PerlIO_clone(aTHX_ proto_perl, param);
+#endif
PL_envgv = gv_dup(proto_perl->Ienvgv, param);
PL_incgv = gv_dup(proto_perl->Iincgv, param);
#ifdef VMS
PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
#endif
+ PL_encoding = sv_dup(proto_perl->Iencoding, param);
/* Clone the regex array */
PL_regex_padav = newAV();
for(i = 1; i <= len; i++) {
if(SvREPADTMP(regexen[i])) {
av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
- } else {
+ } else {
av_push(PL_regex_padav,
SvREFCNT_inc(
- newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
+ newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
SvIVX(regexen[i])), param)))
));
}
PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
PL_profiledata = NULL;
- PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
+ PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
/* PL_rsfp_filters entries have fake IoDIRP() */
PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
+ PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
/* swatch cache */
PL_last_swash_hv = Nullhv; /* reinits on demand */
ptr_table_free(PL_ptr_table);
PL_ptr_table = NULL;
}
-
+
/* Call the ->CLONE method, if it exists, for each of the stashes
identified by sv_dup() above.
*/
}
#endif /* USE_ITHREADS */
+
+/*
+=for apidoc sv_recode_to_utf8
+
+The encoding is assumed to be an Encode object, on entry the PV
+of the sv is assumed to be octets in that encoding, and the sv
+will be converted into Unicode (and UTF-8).
+
+If the sv already is UTF-8 (or if it is not POK), or if the encoding
+is not a reference, nothing is done to the sv. If the encoding is not
+an C<Encode::XS> Encoding object, bad things will happen.
+(See F<lib/encoding.pm> and L<Encode>).
+
+The PV of the sv is returned.
+
+=cut */
+
+char *
+Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
+{
+ if (SvPOK(sv) && !DO_UTF8(sv) && SvROK(encoding)) {
+ SV *uni;
+ STRLEN len;
+ char *s;
+ dSP;
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(sp);
+ EXTEND(SP, 3);
+ XPUSHs(encoding);
+ XPUSHs(sv);
+ XPUSHs(&PL_sv_yes);
+ PUTBACK;
+ call_method("decode", G_SCALAR);
+ SPAGAIN;
+ uni = POPs;
+ PUTBACK;
+ s = SvPV(uni, len);
+ if (s != SvPVX(sv)) {
+ SvGROW(sv, len);
+ Move(s, SvPVX(sv), len, char);
+ SvCUR_set(sv, len);
+ }
+ FREETMPS;
+ LEAVE;
+ SvUTF8_on(sv);
+ }
+ return SvPVX(sv);
+}
+
projects / p5sagit/p5-mst-13.2.git / blobdiff