3 * Copyright (c) 1991-2000, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "I wonder what the Entish is for 'yes' and 'no'," he thought.
19 #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
21 static void do_report_used(pTHXo_ SV *sv);
22 static void do_clean_objs(pTHXo_ SV *sv);
23 #ifndef DISABLE_DESTRUCTOR_KLUDGE
24 static void do_clean_named_objs(pTHXo_ SV *sv);
26 static void do_clean_all(pTHXo_ SV *sv);
29 * "A time to plant, and a time to uproot what was planted..."
34 SvANY(p) = (void *)PL_sv_root; \
35 SvFLAGS(p) = SVTYPEMASK; \
40 /* sv_mutex must be held while calling uproot_SV() */
41 #define uproot_SV(p) \
44 PL_sv_root = (SV*)SvANY(p); \
66 if (PL_debug & 32768) \
76 if (PL_debug & 32768) {
81 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
83 svend = &sva[SvREFCNT(sva)];
84 if (p >= sv && p < svend)
88 if (ckWARN_d(WARN_INTERNAL))
89 Perl_warner(aTHX_ WARN_INTERNAL,
90 "Attempt to free non-arena SV: 0x%"UVxf,
98 #else /* ! DEBUGGING */
100 #define del_SV(p) plant_SV(p)
102 #endif /* DEBUGGING */
105 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
110 Zero(sva, size, char);
112 /* The first SV in an arena isn't an SV. */
113 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
114 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
115 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
117 PL_sv_arenaroot = sva;
118 PL_sv_root = sva + 1;
120 svend = &sva[SvREFCNT(sva) - 1];
123 SvANY(sv) = (void *)(SV*)(sv + 1);
124 SvFLAGS(sv) = SVTYPEMASK;
128 SvFLAGS(sv) = SVTYPEMASK;
131 /* sv_mutex must be held while calling more_sv() */
138 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
139 PL_nice_chunk = Nullch;
142 char *chunk; /* must use New here to match call to */
143 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
144 sv_add_arena(chunk, 1008, 0);
151 S_visit(pTHX_ SVFUNC_t f)
157 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
158 svend = &sva[SvREFCNT(sva)];
159 for (sv = sva + 1; sv < svend; ++sv) {
160 if (SvTYPE(sv) != SVTYPEMASK)
167 Perl_sv_report_used(pTHX)
169 visit(do_report_used);
173 Perl_sv_clean_objs(pTHX)
175 PL_in_clean_objs = TRUE;
176 visit(do_clean_objs);
177 #ifndef DISABLE_DESTRUCTOR_KLUDGE
178 /* some barnacles may yet remain, clinging to typeglobs */
179 visit(do_clean_named_objs);
181 PL_in_clean_objs = FALSE;
185 Perl_sv_clean_all(pTHX)
187 PL_in_clean_all = TRUE;
189 PL_in_clean_all = FALSE;
193 Perl_sv_free_arenas(pTHX)
198 /* Free arenas here, but be careful about fake ones. (We assume
199 contiguity of the fake ones with the corresponding real ones.) */
201 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
202 svanext = (SV*) SvANY(sva);
203 while (svanext && SvFAKE(svanext))
204 svanext = (SV*) SvANY(svanext);
207 Safefree((void *)sva);
211 Safefree(PL_nice_chunk);
212 PL_nice_chunk = Nullch;
213 PL_nice_chunk_size = 0;
219 Perl_report_uninit(pTHX)
222 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit,
223 " in ", PL_op_desc[PL_op->op_type]);
225 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", "");
237 * See comment in more_xiv() -- RAM.
239 PL_xiv_root = *(IV**)xiv;
241 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
245 S_del_xiv(pTHX_ XPVIV *p)
247 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
249 *(IV**)xiv = PL_xiv_root;
260 New(705, ptr, 1008/sizeof(XPV), XPV);
261 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
262 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
265 xivend = &xiv[1008 / sizeof(IV) - 1];
266 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
268 while (xiv < xivend) {
269 *(IV**)xiv = (IV *)(xiv + 1);
283 PL_xnv_root = *(NV**)xnv;
285 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
289 S_del_xnv(pTHX_ XPVNV *p)
291 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
293 *(NV**)xnv = PL_xnv_root;
303 New(711, xnv, 1008/sizeof(NV), NV);
304 xnvend = &xnv[1008 / sizeof(NV) - 1];
305 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
307 while (xnv < xnvend) {
308 *(NV**)xnv = (NV*)(xnv + 1);
322 PL_xrv_root = (XRV*)xrv->xrv_rv;
328 S_del_xrv(pTHX_ XRV *p)
331 p->xrv_rv = (SV*)PL_xrv_root;
340 register XRV* xrvend;
341 New(712, PL_xrv_root, 1008/sizeof(XRV), XRV);
343 xrvend = &xrv[1008 / sizeof(XRV) - 1];
344 while (xrv < xrvend) {
345 xrv->xrv_rv = (SV*)(xrv + 1);
359 PL_xpv_root = (XPV*)xpv->xpv_pv;
365 S_del_xpv(pTHX_ XPV *p)
368 p->xpv_pv = (char*)PL_xpv_root;
377 register XPV* xpvend;
378 New(713, PL_xpv_root, 1008/sizeof(XPV), XPV);
380 xpvend = &xpv[1008 / sizeof(XPV) - 1];
381 while (xpv < xpvend) {
382 xpv->xpv_pv = (char*)(xpv + 1);
395 xpviv = PL_xpviv_root;
396 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
402 S_del_xpviv(pTHX_ XPVIV *p)
405 p->xpv_pv = (char*)PL_xpviv_root;
414 register XPVIV* xpviv;
415 register XPVIV* xpvivend;
416 New(714, PL_xpviv_root, 1008/sizeof(XPVIV), XPVIV);
417 xpviv = PL_xpviv_root;
418 xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
419 while (xpviv < xpvivend) {
420 xpviv->xpv_pv = (char*)(xpviv + 1);
434 xpvnv = PL_xpvnv_root;
435 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
441 S_del_xpvnv(pTHX_ XPVNV *p)
444 p->xpv_pv = (char*)PL_xpvnv_root;
453 register XPVNV* xpvnv;
454 register XPVNV* xpvnvend;
455 New(715, PL_xpvnv_root, 1008/sizeof(XPVNV), XPVNV);
456 xpvnv = PL_xpvnv_root;
457 xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
458 while (xpvnv < xpvnvend) {
459 xpvnv->xpv_pv = (char*)(xpvnv + 1);
474 xpvcv = PL_xpvcv_root;
475 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
481 S_del_xpvcv(pTHX_ XPVCV *p)
484 p->xpv_pv = (char*)PL_xpvcv_root;
493 register XPVCV* xpvcv;
494 register XPVCV* xpvcvend;
495 New(716, PL_xpvcv_root, 1008/sizeof(XPVCV), XPVCV);
496 xpvcv = PL_xpvcv_root;
497 xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
498 while (xpvcv < xpvcvend) {
499 xpvcv->xpv_pv = (char*)(xpvcv + 1);
514 xpvav = PL_xpvav_root;
515 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
521 S_del_xpvav(pTHX_ XPVAV *p)
524 p->xav_array = (char*)PL_xpvav_root;
533 register XPVAV* xpvav;
534 register XPVAV* xpvavend;
535 New(717, PL_xpvav_root, 1008/sizeof(XPVAV), XPVAV);
536 xpvav = PL_xpvav_root;
537 xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
538 while (xpvav < xpvavend) {
539 xpvav->xav_array = (char*)(xpvav + 1);
542 xpvav->xav_array = 0;
554 xpvhv = PL_xpvhv_root;
555 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
561 S_del_xpvhv(pTHX_ XPVHV *p)
564 p->xhv_array = (char*)PL_xpvhv_root;
573 register XPVHV* xpvhv;
574 register XPVHV* xpvhvend;
575 New(718, PL_xpvhv_root, 1008/sizeof(XPVHV), XPVHV);
576 xpvhv = PL_xpvhv_root;
577 xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
578 while (xpvhv < xpvhvend) {
579 xpvhv->xhv_array = (char*)(xpvhv + 1);
582 xpvhv->xhv_array = 0;
593 xpvmg = PL_xpvmg_root;
594 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
600 S_del_xpvmg(pTHX_ XPVMG *p)
603 p->xpv_pv = (char*)PL_xpvmg_root;
612 register XPVMG* xpvmg;
613 register XPVMG* xpvmgend;
614 New(719, PL_xpvmg_root, 1008/sizeof(XPVMG), XPVMG);
615 xpvmg = PL_xpvmg_root;
616 xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
617 while (xpvmg < xpvmgend) {
618 xpvmg->xpv_pv = (char*)(xpvmg + 1);
633 xpvlv = PL_xpvlv_root;
634 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
640 S_del_xpvlv(pTHX_ XPVLV *p)
643 p->xpv_pv = (char*)PL_xpvlv_root;
652 register XPVLV* xpvlv;
653 register XPVLV* xpvlvend;
654 New(720, PL_xpvlv_root, 1008/sizeof(XPVLV), XPVLV);
655 xpvlv = PL_xpvlv_root;
656 xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
657 while (xpvlv < xpvlvend) {
658 xpvlv->xpv_pv = (char*)(xpvlv + 1);
672 xpvbm = PL_xpvbm_root;
673 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
679 S_del_xpvbm(pTHX_ XPVBM *p)
682 p->xpv_pv = (char*)PL_xpvbm_root;
691 register XPVBM* xpvbm;
692 register XPVBM* xpvbmend;
693 New(721, PL_xpvbm_root, 1008/sizeof(XPVBM), XPVBM);
694 xpvbm = PL_xpvbm_root;
695 xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
696 while (xpvbm < xpvbmend) {
697 xpvbm->xpv_pv = (char*)(xpvbm + 1);
703 #define new_XIV() (void*)new_xiv()
704 #define del_XIV(p) del_xiv((XPVIV*) p)
706 #define new_XNV() (void*)new_xnv()
707 #define del_XNV(p) del_xnv((XPVNV*) p)
709 #define new_XRV() (void*)new_xrv()
710 #define del_XRV(p) del_xrv((XRV*) p)
712 #define new_XPV() (void*)new_xpv()
713 #define del_XPV(p) del_xpv((XPV *)p)
716 S_my_safemalloc(MEM_SIZE size)
719 New(717, p, size, char);
722 # define my_safefree(s) Safefree(s)
724 #define new_XPVIV() (void*)new_xpviv()
725 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
727 #define new_XPVNV() (void*)new_xpvnv()
728 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
730 #define new_XPVCV() (void*)new_xpvcv()
731 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
733 #define new_XPVAV() (void*)new_xpvav()
734 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
736 #define new_XPVHV() (void*)new_xpvhv()
737 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
739 #define new_XPVMG() (void*)new_xpvmg()
740 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
742 #define new_XPVLV() (void*)new_xpvlv()
743 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
745 #define new_XPVGV() (void*)my_safemalloc(sizeof(XPVGV))
746 #define del_XPVGV(p) my_safefree((char*)p)
748 #define new_XPVBM() (void*)new_xpvbm()
749 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
751 #define new_XPVFM() (void*)my_safemalloc(sizeof(XPVFM))
752 #define del_XPVFM(p) my_safefree((char*)p)
754 #define new_XPVIO() (void*)my_safemalloc(sizeof(XPVIO))
755 #define del_XPVIO(p) my_safefree((char*)p)
758 =for apidoc sv_upgrade
760 Upgrade an SV to a more complex form. Use C<SvUPGRADE>. See
767 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
777 if (SvTYPE(sv) == mt)
783 switch (SvTYPE(sv)) {
804 else if (mt < SVt_PVIV)
821 pv = (char*)SvRV(sv);
841 else if (mt == SVt_NV)
852 del_XPVIV(SvANY(sv));
862 del_XPVNV(SvANY(sv));
872 del_XPVMG(SvANY(sv));
875 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
880 Perl_croak(aTHX_ "Can't upgrade to undef");
882 SvANY(sv) = new_XIV();
886 SvANY(sv) = new_XNV();
890 SvANY(sv) = new_XRV();
894 SvANY(sv) = new_XPV();
900 SvANY(sv) = new_XPVIV();
910 SvANY(sv) = new_XPVNV();
918 SvANY(sv) = new_XPVMG();
928 SvANY(sv) = new_XPVLV();
942 SvANY(sv) = new_XPVAV();
957 SvANY(sv) = new_XPVHV();
973 SvANY(sv) = new_XPVCV();
974 Zero(SvANY(sv), 1, XPVCV);
984 SvANY(sv) = new_XPVGV();
999 SvANY(sv) = new_XPVBM();
1005 SvMAGIC(sv) = magic;
1006 SvSTASH(sv) = stash;
1012 SvANY(sv) = new_XPVFM();
1013 Zero(SvANY(sv), 1, XPVFM);
1019 SvMAGIC(sv) = magic;
1020 SvSTASH(sv) = stash;
1023 SvANY(sv) = new_XPVIO();
1024 Zero(SvANY(sv), 1, XPVIO);
1030 SvMAGIC(sv) = magic;
1031 SvSTASH(sv) = stash;
1032 IoPAGE_LEN(sv) = 60;
1035 SvFLAGS(sv) &= ~SVTYPEMASK;
1041 Perl_sv_backoff(pTHX_ register SV *sv)
1045 char *s = SvPVX(sv);
1046 SvLEN(sv) += SvIVX(sv);
1047 SvPVX(sv) -= SvIVX(sv);
1049 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1051 SvFLAGS(sv) &= ~SVf_OOK;
1058 Expands the character buffer in the SV. This will use C<sv_unref> and will
1059 upgrade the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1066 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1070 #ifdef HAS_64K_LIMIT
1071 if (newlen >= 0x10000) {
1072 PerlIO_printf(Perl_debug_log,
1073 "Allocation too large: %"UVxf"\n", (UV)newlen);
1076 #endif /* HAS_64K_LIMIT */
1079 if (SvTYPE(sv) < SVt_PV) {
1080 sv_upgrade(sv, SVt_PV);
1083 else if (SvOOK(sv)) { /* pv is offset? */
1086 if (newlen > SvLEN(sv))
1087 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1088 #ifdef HAS_64K_LIMIT
1089 if (newlen >= 0x10000)
1095 if (newlen > SvLEN(sv)) { /* need more room? */
1096 if (SvLEN(sv) && s) {
1097 #if defined(MYMALLOC) && !defined(PURIFY) && !defined(LEAKTEST)
1098 STRLEN l = malloced_size((void*)SvPVX(sv));
1104 Renew(s,newlen,char);
1107 New(703,s,newlen,char);
1109 SvLEN_set(sv, newlen);
1115 =for apidoc sv_setiv
1117 Copies an integer into the given SV. Does not handle 'set' magic. See
1124 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1126 SV_CHECK_THINKFIRST(sv);
1127 switch (SvTYPE(sv)) {
1129 sv_upgrade(sv, SVt_IV);
1132 sv_upgrade(sv, SVt_PVNV);
1136 sv_upgrade(sv, SVt_PVIV);
1147 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1148 PL_op_desc[PL_op->op_type]);
1151 (void)SvIOK_only(sv); /* validate number */
1157 =for apidoc sv_setiv_mg
1159 Like C<sv_setiv>, but also handles 'set' magic.
1165 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1172 =for apidoc sv_setuv
1174 Copies an unsigned integer into the given SV. Does not handle 'set' magic.
1181 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1189 =for apidoc sv_setuv_mg
1191 Like C<sv_setuv>, but also handles 'set' magic.
1197 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1204 =for apidoc sv_setnv
1206 Copies a double into the given SV. Does not handle 'set' magic. See
1213 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1215 SV_CHECK_THINKFIRST(sv);
1216 switch (SvTYPE(sv)) {
1219 sv_upgrade(sv, SVt_NV);
1224 sv_upgrade(sv, SVt_PVNV);
1235 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1236 PL_op_name[PL_op->op_type]);
1240 (void)SvNOK_only(sv); /* validate number */
1245 =for apidoc sv_setnv_mg
1247 Like C<sv_setnv>, but also handles 'set' magic.
1253 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1260 S_not_a_number(pTHX_ SV *sv)
1266 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1267 /* each *s can expand to 4 chars + "...\0",
1268 i.e. need room for 8 chars */
1270 for (s = SvPVX(sv); *s && d < limit; s++) {
1272 if (ch & 128 && !isPRINT_LC(ch)) {
1281 else if (ch == '\r') {
1285 else if (ch == '\f') {
1289 else if (ch == '\\') {
1293 else if (isPRINT_LC(ch))
1308 Perl_warner(aTHX_ WARN_NUMERIC,
1309 "Argument \"%s\" isn't numeric in %s", tmpbuf,
1310 PL_op_desc[PL_op->op_type]);
1312 Perl_warner(aTHX_ WARN_NUMERIC,
1313 "Argument \"%s\" isn't numeric", tmpbuf);
1316 /* the number can be converted to integer with atol() or atoll() */
1317 #define IS_NUMBER_TO_INT_BY_ATOL 0x01
1318 #define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
1319 #define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */
1320 #define IS_NUMBER_NEG 0x08 /* not good to cache UV */
1322 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1323 until proven guilty, assume that things are not that bad... */
1326 Perl_sv_2iv(pTHX_ register SV *sv)
1330 if (SvGMAGICAL(sv)) {
1335 return I_V(SvNVX(sv));
1337 if (SvPOKp(sv) && SvLEN(sv))
1340 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1342 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1348 if (SvTHINKFIRST(sv)) {
1351 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1352 return SvIV(tmpstr);
1353 return PTR2IV(SvRV(sv));
1355 if (SvREADONLY(sv) && !SvOK(sv)) {
1357 if (ckWARN(WARN_UNINITIALIZED))
1364 return (IV)(SvUVX(sv));
1371 /* We can cache the IV/UV value even if it not good enough
1372 * to reconstruct NV, since the conversion to PV will prefer
1376 if (SvTYPE(sv) == SVt_NV)
1377 sv_upgrade(sv, SVt_PVNV);
1380 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1381 SvIVX(sv) = I_V(SvNVX(sv));
1383 SvUVX(sv) = U_V(SvNVX(sv));
1386 DEBUG_c(PerlIO_printf(Perl_debug_log,
1387 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1391 return (IV)SvUVX(sv);
1394 else if (SvPOKp(sv) && SvLEN(sv)) {
1395 I32 numtype = looks_like_number(sv);
1397 /* We want to avoid a possible problem when we cache an IV which
1398 may be later translated to an NV, and the resulting NV is not
1399 the translation of the initial data.
1401 This means that if we cache such an IV, we need to cache the
1402 NV as well. Moreover, we trade speed for space, and do not
1403 cache the NV if not needed.
1405 if (numtype & IS_NUMBER_NOT_IV) {
1406 /* May be not an integer. Need to cache NV if we cache IV
1407 * - otherwise future conversion to NV will be wrong. */
1410 d = Atof(SvPVX(sv));
1412 if (SvTYPE(sv) < SVt_PVNV)
1413 sv_upgrade(sv, SVt_PVNV);
1417 #if defined(USE_LONG_DOUBLE)
1418 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1419 PTR2UV(sv), SvNVX(sv)));
1421 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%g)\n",
1422 PTR2UV(sv), SvNVX(sv)));
1424 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1425 SvIVX(sv) = I_V(SvNVX(sv));
1427 SvUVX(sv) = U_V(SvNVX(sv));
1433 /* The NV may be reconstructed from IV - safe to cache IV,
1434 which may be calculated by atol(). */
1435 if (SvTYPE(sv) == SVt_PV)
1436 sv_upgrade(sv, SVt_PVIV);
1438 SvIVX(sv) = Atol(SvPVX(sv));
1440 else { /* Not a number. Cache 0. */
1443 if (SvTYPE(sv) < SVt_PVIV)
1444 sv_upgrade(sv, SVt_PVIV);
1447 if (ckWARN(WARN_NUMERIC))
1453 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1455 if (SvTYPE(sv) < SVt_IV)
1456 /* Typically the caller expects that sv_any is not NULL now. */
1457 sv_upgrade(sv, SVt_IV);
1460 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1461 PTR2UV(sv),SvIVX(sv)));
1462 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1466 Perl_sv_2uv(pTHX_ register SV *sv)
1470 if (SvGMAGICAL(sv)) {
1475 return U_V(SvNVX(sv));
1476 if (SvPOKp(sv) && SvLEN(sv))
1479 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1481 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1487 if (SvTHINKFIRST(sv)) {
1490 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1491 return SvUV(tmpstr);
1492 return PTR2UV(SvRV(sv));
1494 if (SvREADONLY(sv) && !SvOK(sv)) {
1496 if (ckWARN(WARN_UNINITIALIZED))
1506 return (UV)SvIVX(sv);
1510 /* We can cache the IV/UV value even if it not good enough
1511 * to reconstruct NV, since the conversion to PV will prefer
1514 if (SvTYPE(sv) == SVt_NV)
1515 sv_upgrade(sv, SVt_PVNV);
1517 if (SvNVX(sv) >= -0.5) {
1519 SvUVX(sv) = U_V(SvNVX(sv));
1522 SvIVX(sv) = I_V(SvNVX(sv));
1524 DEBUG_c(PerlIO_printf(Perl_debug_log,
1525 "0x%"UVxf" 2uv(%"IVdf" => %"IVdf") (as signed)\n",
1528 (IV)(UV)SvIVX(sv)));
1529 return (UV)SvIVX(sv);
1532 else if (SvPOKp(sv) && SvLEN(sv)) {
1533 I32 numtype = looks_like_number(sv);
1535 /* We want to avoid a possible problem when we cache a UV which
1536 may be later translated to an NV, and the resulting NV is not
1537 the translation of the initial data.
1539 This means that if we cache such a UV, we need to cache the
1540 NV as well. Moreover, we trade speed for space, and do not
1541 cache the NV if not needed.
1543 if (numtype & IS_NUMBER_NOT_IV) {
1544 /* May be not an integer. Need to cache NV if we cache IV
1545 * - otherwise future conversion to NV will be wrong. */
1548 d = Atof(SvPVX(sv));
1550 if (SvTYPE(sv) < SVt_PVNV)
1551 sv_upgrade(sv, SVt_PVNV);
1555 #if defined(USE_LONG_DOUBLE)
1556 DEBUG_c(PerlIO_printf(Perl_debug_log,
1557 "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1558 PTR2UV(sv), SvNVX(sv)));
1560 DEBUG_c(PerlIO_printf(Perl_debug_log,
1561 "0x%"UVxf" 2nv(%g)\n",
1562 PTR2UV(sv), SvNVX(sv)));
1564 if (SvNVX(sv) < -0.5) {
1565 SvIVX(sv) = I_V(SvNVX(sv));
1568 SvUVX(sv) = U_V(SvNVX(sv));
1572 else if (numtype & IS_NUMBER_NEG) {
1573 /* The NV may be reconstructed from IV - safe to cache IV,
1574 which may be calculated by atol(). */
1575 if (SvTYPE(sv) == SVt_PV)
1576 sv_upgrade(sv, SVt_PVIV);
1578 SvIVX(sv) = (IV)Atol(SvPVX(sv));
1580 else if (numtype) { /* Non-negative */
1581 /* The NV may be reconstructed from UV - safe to cache UV,
1582 which may be calculated by strtoul()/atol. */
1583 if (SvTYPE(sv) == SVt_PV)
1584 sv_upgrade(sv, SVt_PVIV);
1586 (void)SvIsUV_on(sv);
1588 SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
1589 #else /* no atou(), but we know the number fits into IV... */
1590 /* The only problem may be if it is negative... */
1591 SvUVX(sv) = (UV)Atol(SvPVX(sv));
1594 else { /* Not a number. Cache 0. */
1597 if (SvTYPE(sv) < SVt_PVIV)
1598 sv_upgrade(sv, SVt_PVIV);
1599 SvUVX(sv) = 0; /* We assume that 0s have the
1600 same bitmap in IV and UV. */
1602 (void)SvIsUV_on(sv);
1603 if (ckWARN(WARN_NUMERIC))
1608 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1610 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1613 if (SvTYPE(sv) < SVt_IV)
1614 /* Typically the caller expects that sv_any is not NULL now. */
1615 sv_upgrade(sv, SVt_IV);
1619 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
1620 PTR2UV(sv),SvUVX(sv)));
1621 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
1625 Perl_sv_2nv(pTHX_ register SV *sv)
1629 if (SvGMAGICAL(sv)) {
1633 if (SvPOKp(sv) && SvLEN(sv)) {
1635 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1637 return Atof(SvPVX(sv));
1641 return (NV)SvUVX(sv);
1643 return (NV)SvIVX(sv);
1646 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1648 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1654 if (SvTHINKFIRST(sv)) {
1657 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
1658 return SvNV(tmpstr);
1659 return PTR2NV(SvRV(sv));
1661 if (SvREADONLY(sv) && !SvOK(sv)) {
1663 if (ckWARN(WARN_UNINITIALIZED))
1668 if (SvTYPE(sv) < SVt_NV) {
1669 if (SvTYPE(sv) == SVt_IV)
1670 sv_upgrade(sv, SVt_PVNV);
1672 sv_upgrade(sv, SVt_NV);
1673 #if defined(USE_LONG_DOUBLE)
1675 RESTORE_NUMERIC_STANDARD();
1676 PerlIO_printf(Perl_debug_log,
1677 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
1678 PTR2UV(sv), SvNVX(sv));
1679 RESTORE_NUMERIC_LOCAL();
1683 RESTORE_NUMERIC_STANDARD();
1684 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
1685 PTR2UV(sv), SvNVX(sv));
1686 RESTORE_NUMERIC_LOCAL();
1690 else if (SvTYPE(sv) < SVt_PVNV)
1691 sv_upgrade(sv, SVt_PVNV);
1693 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
1695 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
1697 else if (SvPOKp(sv) && SvLEN(sv)) {
1699 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1701 SvNVX(sv) = Atof(SvPVX(sv));
1705 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1707 if (SvTYPE(sv) < SVt_NV)
1708 /* Typically the caller expects that sv_any is not NULL now. */
1709 sv_upgrade(sv, SVt_NV);
1713 #if defined(USE_LONG_DOUBLE)
1715 RESTORE_NUMERIC_STANDARD();
1716 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1717 PTR2UV(sv), SvNVX(sv));
1718 RESTORE_NUMERIC_LOCAL();
1722 RESTORE_NUMERIC_STANDARD();
1723 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
1724 PTR2UV(sv), SvNVX(sv));
1725 RESTORE_NUMERIC_LOCAL();
1732 S_asIV(pTHX_ SV *sv)
1734 I32 numtype = looks_like_number(sv);
1737 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1738 return Atol(SvPVX(sv));
1741 if (ckWARN(WARN_NUMERIC))
1744 d = Atof(SvPVX(sv));
1749 S_asUV(pTHX_ SV *sv)
1751 I32 numtype = looks_like_number(sv);
1754 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1755 return Strtoul(SvPVX(sv), Null(char**), 10);
1759 if (ckWARN(WARN_NUMERIC))
1762 return U_V(Atof(SvPVX(sv)));
1766 * Returns a combination of (advisory only - can get false negatives)
1767 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
1769 * 0 if does not look like number.
1771 * In fact possible values are 0 and
1772 * IS_NUMBER_TO_INT_BY_ATOL 123
1773 * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
1774 * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
1775 * with a possible addition of IS_NUMBER_NEG.
1779 =for apidoc looks_like_number
1781 Test if an the content of an SV looks like a number (or is a
1788 Perl_looks_like_number(pTHX_ SV *sv)
1791 register char *send;
1792 register char *sbegin;
1793 register char *nbegin;
1801 else if (SvPOKp(sv))
1802 sbegin = SvPV(sv, len);
1805 send = sbegin + len;
1812 numtype = IS_NUMBER_NEG;
1819 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
1820 * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
1824 /* next must be digit or the radix separator */
1828 } while (isDIGIT(*s));
1830 if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */
1831 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1833 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
1836 #ifdef USE_LOCALE_NUMERIC
1837 || IS_NUMERIC_RADIX(*s)
1841 numtype |= IS_NUMBER_NOT_IV;
1842 while (isDIGIT(*s)) /* optional digits after the radix */
1847 #ifdef USE_LOCALE_NUMERIC
1848 || IS_NUMERIC_RADIX(*s)
1852 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
1853 /* no digits before the radix means we need digits after it */
1857 } while (isDIGIT(*s));
1865 /* we can have an optional exponent part */
1866 if (*s == 'e' || *s == 'E') {
1867 numtype &= ~IS_NUMBER_NEG;
1868 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1870 if (*s == '+' || *s == '-')
1875 } while (isDIGIT(*s));
1884 if (len == 10 && memEQ(sbegin, "0 but true", 10))
1885 return IS_NUMBER_TO_INT_BY_ATOL;
1890 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
1893 return sv_2pv(sv, &n_a);
1896 /* We assume that buf is at least TYPE_CHARS(UV) long. */
1898 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
1901 char *ptr = buf + TYPE_CHARS(UV);
1916 *--ptr = '0' + (uv % 10);
1925 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
1930 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
1931 char *tmpbuf = tbuf;
1937 if (SvGMAGICAL(sv)) {
1945 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
1947 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
1952 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
1957 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1959 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1966 if (SvTHINKFIRST(sv)) {
1969 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
1970 return SvPV(tmpstr,*lp);
1977 switch (SvTYPE(sv)) {
1979 if ( ((SvFLAGS(sv) &
1980 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
1981 == (SVs_OBJECT|SVs_RMG))
1982 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
1983 && (mg = mg_find(sv, 'r'))) {
1985 regexp *re = (regexp *)mg->mg_obj;
1988 char *fptr = "msix";
1993 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
1995 while(ch = *fptr++) {
1997 reflags[left++] = ch;
2000 reflags[right--] = ch;
2005 reflags[left] = '-';
2009 mg->mg_len = re->prelen + 4 + left;
2010 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2011 Copy("(?", mg->mg_ptr, 2, char);
2012 Copy(reflags, mg->mg_ptr+2, left, char);
2013 Copy(":", mg->mg_ptr+left+2, 1, char);
2014 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2015 mg->mg_ptr[mg->mg_len - 1] = ')';
2016 mg->mg_ptr[mg->mg_len] = 0;
2018 PL_reginterp_cnt += re->program[0].next_off;
2030 case SVt_PVBM: s = "SCALAR"; break;
2031 case SVt_PVLV: s = "LVALUE"; break;
2032 case SVt_PVAV: s = "ARRAY"; break;
2033 case SVt_PVHV: s = "HASH"; break;
2034 case SVt_PVCV: s = "CODE"; break;
2035 case SVt_PVGV: s = "GLOB"; break;
2036 case SVt_PVFM: s = "FORMAT"; break;
2037 case SVt_PVIO: s = "IO"; break;
2038 default: s = "UNKNOWN"; break;
2042 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2045 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2051 if (SvREADONLY(sv) && !SvOK(sv)) {
2053 if (ckWARN(WARN_UNINITIALIZED))
2059 if (SvNOKp(sv)) { /* See note in sv_2uv() */
2060 /* XXXX 64-bit? IV may have better precision... */
2061 /* I tried changing this for to be 64-bit-aware and
2062 * the t/op/numconvert.t became very, very, angry.
2064 if (SvTYPE(sv) < SVt_PVNV)
2065 sv_upgrade(sv, SVt_PVNV);
2068 olderrno = errno; /* some Xenix systems wipe out errno here */
2070 if (SvNVX(sv) == 0.0)
2071 (void)strcpy(s,"0");
2075 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2078 #ifdef FIXNEGATIVEZERO
2079 if (*s == '-' && s[1] == '0' && !s[2])
2088 else if (SvIOKp(sv)) {
2089 U32 isIOK = SvIOK(sv);
2090 U32 isUIOK = SvIsUV(sv);
2091 char buf[TYPE_CHARS(UV)];
2094 if (SvTYPE(sv) < SVt_PVIV)
2095 sv_upgrade(sv, SVt_PVIV);
2097 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2099 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2100 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2101 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2102 SvCUR_set(sv, ebuf - ptr);
2115 if (ckWARN(WARN_UNINITIALIZED)
2116 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2121 if (SvTYPE(sv) < SVt_PV)
2122 /* Typically the caller expects that sv_any is not NULL now. */
2123 sv_upgrade(sv, SVt_PV);
2126 *lp = s - SvPVX(sv);
2129 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2130 PTR2UV(sv),SvPVX(sv)));
2134 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2135 /* Sneaky stuff here */
2139 tsv = newSVpv(tmpbuf, 0);
2155 len = strlen(tmpbuf);
2157 #ifdef FIXNEGATIVEZERO
2158 if (len == 2 && t[0] == '-' && t[1] == '0') {
2163 (void)SvUPGRADE(sv, SVt_PV);
2165 s = SvGROW(sv, len + 1);
2174 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2176 return sv_2pv_nolen(sv);
2180 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2182 return sv_2pv(sv,lp);
2186 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2188 return sv_2pv_nolen(sv);
2192 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2194 return sv_2pv(sv,lp);
2197 /* This function is only called on magical items */
2199 Perl_sv_2bool(pTHX_ register SV *sv)
2209 if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
2210 return SvTRUE(tmpsv);
2211 return SvRV(sv) != 0;
2214 register XPV* Xpvtmp;
2215 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2216 (*Xpvtmp->xpv_pv > '0' ||
2217 Xpvtmp->xpv_cur > 1 ||
2218 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2225 return SvIVX(sv) != 0;
2228 return SvNVX(sv) != 0.0;
2235 /* Note: sv_setsv() should not be called with a source string that needs
2236 * to be reused, since it may destroy the source string if it is marked
2241 =for apidoc sv_setsv
2243 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
2244 The source SV may be destroyed if it is mortal. Does not handle 'set'
2245 magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
2252 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
2255 register U32 sflags;
2261 SV_CHECK_THINKFIRST(dstr);
2263 sstr = &PL_sv_undef;
2264 stype = SvTYPE(sstr);
2265 dtype = SvTYPE(dstr);
2269 /* There's a lot of redundancy below but we're going for speed here */
2274 if (dtype != SVt_PVGV) {
2275 (void)SvOK_off(dstr);
2283 sv_upgrade(dstr, SVt_IV);
2286 sv_upgrade(dstr, SVt_PVNV);
2290 sv_upgrade(dstr, SVt_PVIV);
2293 (void)SvIOK_only(dstr);
2294 SvIVX(dstr) = SvIVX(sstr);
2307 sv_upgrade(dstr, SVt_NV);
2312 sv_upgrade(dstr, SVt_PVNV);
2315 SvNVX(dstr) = SvNVX(sstr);
2316 (void)SvNOK_only(dstr);
2324 sv_upgrade(dstr, SVt_RV);
2325 else if (dtype == SVt_PVGV &&
2326 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2329 if (GvIMPORTED(dstr) != GVf_IMPORTED
2330 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2332 GvIMPORTED_on(dstr);
2343 sv_upgrade(dstr, SVt_PV);
2346 if (dtype < SVt_PVIV)
2347 sv_upgrade(dstr, SVt_PVIV);
2350 if (dtype < SVt_PVNV)
2351 sv_upgrade(dstr, SVt_PVNV);
2358 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2359 PL_op_name[PL_op->op_type]);
2361 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
2365 if (dtype <= SVt_PVGV) {
2367 if (dtype != SVt_PVGV) {
2368 char *name = GvNAME(sstr);
2369 STRLEN len = GvNAMELEN(sstr);
2370 sv_upgrade(dstr, SVt_PVGV);
2371 sv_magic(dstr, dstr, '*', name, len);
2372 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2373 GvNAME(dstr) = savepvn(name, len);
2374 GvNAMELEN(dstr) = len;
2375 SvFAKE_on(dstr); /* can coerce to non-glob */
2377 /* ahem, death to those who redefine active sort subs */
2378 else if (PL_curstackinfo->si_type == PERLSI_SORT
2379 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2380 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
2382 (void)SvOK_off(dstr);
2383 GvINTRO_off(dstr); /* one-shot flag */
2385 GvGP(dstr) = gp_ref(GvGP(sstr));
2387 if (GvIMPORTED(dstr) != GVf_IMPORTED
2388 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2390 GvIMPORTED_on(dstr);
2398 if (SvGMAGICAL(sstr)) {
2400 if (SvTYPE(sstr) != stype) {
2401 stype = SvTYPE(sstr);
2402 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2406 if (stype == SVt_PVLV)
2407 (void)SvUPGRADE(dstr, SVt_PVNV);
2409 (void)SvUPGRADE(dstr, stype);
2412 sflags = SvFLAGS(sstr);
2414 if (sflags & SVf_ROK) {
2415 if (dtype >= SVt_PV) {
2416 if (dtype == SVt_PVGV) {
2417 SV *sref = SvREFCNT_inc(SvRV(sstr));
2419 int intro = GvINTRO(dstr);
2424 GvINTRO_off(dstr); /* one-shot flag */
2425 Newz(602,gp, 1, GP);
2426 GvGP(dstr) = gp_ref(gp);
2427 GvSV(dstr) = NEWSV(72,0);
2428 GvLINE(dstr) = CopLINE(PL_curcop);
2429 GvEGV(dstr) = (GV*)dstr;
2432 switch (SvTYPE(sref)) {
2435 SAVESPTR(GvAV(dstr));
2437 dref = (SV*)GvAV(dstr);
2438 GvAV(dstr) = (AV*)sref;
2439 if (GvIMPORTED_AV_off(dstr)
2440 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2442 GvIMPORTED_AV_on(dstr);
2447 SAVESPTR(GvHV(dstr));
2449 dref = (SV*)GvHV(dstr);
2450 GvHV(dstr) = (HV*)sref;
2451 if (GvIMPORTED_HV_off(dstr)
2452 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2454 GvIMPORTED_HV_on(dstr);
2459 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2460 SvREFCNT_dec(GvCV(dstr));
2461 GvCV(dstr) = Nullcv;
2462 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2463 PL_sub_generation++;
2465 SAVESPTR(GvCV(dstr));
2468 dref = (SV*)GvCV(dstr);
2469 if (GvCV(dstr) != (CV*)sref) {
2470 CV* cv = GvCV(dstr);
2472 if (!GvCVGEN((GV*)dstr) &&
2473 (CvROOT(cv) || CvXSUB(cv)))
2475 SV *const_sv = cv_const_sv(cv);
2476 bool const_changed = TRUE;
2478 const_changed = sv_cmp(const_sv,
2479 op_const_sv(CvSTART((CV*)sref),
2481 /* ahem, death to those who redefine
2482 * active sort subs */
2483 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2484 PL_sortcop == CvSTART(cv))
2486 "Can't redefine active sort subroutine %s",
2487 GvENAME((GV*)dstr));
2488 if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) {
2489 if (!(CvGV(cv) && GvSTASH(CvGV(cv))
2490 && HvNAME(GvSTASH(CvGV(cv)))
2491 && strEQ(HvNAME(GvSTASH(CvGV(cv))),
2493 Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
2494 "Constant subroutine %s redefined"
2495 : "Subroutine %s redefined",
2496 GvENAME((GV*)dstr));
2499 cv_ckproto(cv, (GV*)dstr,
2500 SvPOK(sref) ? SvPVX(sref) : Nullch);
2502 GvCV(dstr) = (CV*)sref;
2503 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2504 GvASSUMECV_on(dstr);
2505 PL_sub_generation++;
2507 if (GvIMPORTED_CV_off(dstr)
2508 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2510 GvIMPORTED_CV_on(dstr);
2515 SAVESPTR(GvIOp(dstr));
2517 dref = (SV*)GvIOp(dstr);
2518 GvIOp(dstr) = (IO*)sref;
2522 SAVESPTR(GvSV(dstr));
2524 dref = (SV*)GvSV(dstr);
2526 if (GvIMPORTED_SV_off(dstr)
2527 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2529 GvIMPORTED_SV_on(dstr);
2541 (void)SvOOK_off(dstr); /* backoff */
2543 Safefree(SvPVX(dstr));
2544 SvLEN(dstr)=SvCUR(dstr)=0;
2547 (void)SvOK_off(dstr);
2548 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2550 if (sflags & SVp_NOK) {
2552 SvNVX(dstr) = SvNVX(sstr);
2554 if (sflags & SVp_IOK) {
2555 (void)SvIOK_on(dstr);
2556 SvIVX(dstr) = SvIVX(sstr);
2560 if (SvAMAGIC(sstr)) {
2564 else if (sflags & SVp_POK) {
2567 * Check to see if we can just swipe the string. If so, it's a
2568 * possible small lose on short strings, but a big win on long ones.
2569 * It might even be a win on short strings if SvPVX(dstr)
2570 * has to be allocated and SvPVX(sstr) has to be freed.
2573 if (SvTEMP(sstr) && /* slated for free anyway? */
2574 SvREFCNT(sstr) == 1 && /* and no other references to it? */
2575 !(sflags & SVf_OOK)) /* and not involved in OOK hack? */
2577 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
2579 SvFLAGS(dstr) &= ~SVf_OOK;
2580 Safefree(SvPVX(dstr) - SvIVX(dstr));
2582 else if (SvLEN(dstr))
2583 Safefree(SvPVX(dstr));
2585 (void)SvPOK_only(dstr);
2586 SvPV_set(dstr, SvPVX(sstr));
2587 SvLEN_set(dstr, SvLEN(sstr));
2588 SvCUR_set(dstr, SvCUR(sstr));
2590 (void)SvOK_off(sstr);
2591 SvPV_set(sstr, Nullch);
2596 else { /* have to copy actual string */
2597 STRLEN len = SvCUR(sstr);
2599 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2600 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2601 SvCUR_set(dstr, len);
2602 *SvEND(dstr) = '\0';
2603 (void)SvPOK_only(dstr);
2608 if (sflags & SVp_NOK) {
2610 SvNVX(dstr) = SvNVX(sstr);
2612 if (sflags & SVp_IOK) {
2613 (void)SvIOK_on(dstr);
2614 SvIVX(dstr) = SvIVX(sstr);
2619 else if (sflags & SVp_NOK) {
2620 SvNVX(dstr) = SvNVX(sstr);
2621 (void)SvNOK_only(dstr);
2623 (void)SvIOK_on(dstr);
2624 SvIVX(dstr) = SvIVX(sstr);
2625 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2630 else if (sflags & SVp_IOK) {
2631 (void)SvIOK_only(dstr);
2632 SvIVX(dstr) = SvIVX(sstr);
2637 if (dtype == SVt_PVGV) {
2638 if (ckWARN(WARN_UNSAFE))
2639 Perl_warner(aTHX_ WARN_UNSAFE, "Undefined value assigned to typeglob");
2642 (void)SvOK_off(dstr);
2648 =for apidoc sv_setsv_mg
2650 Like C<sv_setsv>, but also handles 'set' magic.
2656 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2658 sv_setsv(dstr,sstr);
2663 =for apidoc sv_setpvn
2665 Copies a string into an SV. The C<len> parameter indicates the number of
2666 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
2672 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2674 register char *dptr;
2675 assert(len >= 0); /* STRLEN is probably unsigned, so this may
2676 elicit a warning, but it won't hurt. */
2677 SV_CHECK_THINKFIRST(sv);
2682 (void)SvUPGRADE(sv, SVt_PV);
2684 SvGROW(sv, len + 1);
2686 Move(ptr,dptr,len,char);
2689 (void)SvPOK_only(sv); /* validate pointer */
2694 =for apidoc sv_setpvn_mg
2696 Like C<sv_setpvn>, but also handles 'set' magic.
2702 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2704 sv_setpvn(sv,ptr,len);
2709 =for apidoc sv_setpv
2711 Copies a string into an SV. The string must be null-terminated. Does not
2712 handle 'set' magic. See C<sv_setpv_mg>.
2718 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
2720 register STRLEN len;
2722 SV_CHECK_THINKFIRST(sv);
2728 (void)SvUPGRADE(sv, SVt_PV);
2730 SvGROW(sv, len + 1);
2731 Move(ptr,SvPVX(sv),len+1,char);
2733 (void)SvPOK_only(sv); /* validate pointer */
2738 =for apidoc sv_setpv_mg
2740 Like C<sv_setpv>, but also handles 'set' magic.
2746 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
2753 =for apidoc sv_usepvn
2755 Tells an SV to use C<ptr> to find its string value. Normally the string is
2756 stored inside the SV but sv_usepvn allows the SV to use an outside string.
2757 The C<ptr> should point to memory that was allocated by C<malloc>. The
2758 string length, C<len>, must be supplied. This function will realloc the
2759 memory pointed to by C<ptr>, so that pointer should not be freed or used by
2760 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
2761 See C<sv_usepvn_mg>.
2767 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2769 SV_CHECK_THINKFIRST(sv);
2770 (void)SvUPGRADE(sv, SVt_PV);
2775 (void)SvOOK_off(sv);
2776 if (SvPVX(sv) && SvLEN(sv))
2777 Safefree(SvPVX(sv));
2778 Renew(ptr, len+1, char);
2781 SvLEN_set(sv, len+1);
2783 (void)SvPOK_only(sv); /* validate pointer */
2788 =for apidoc sv_usepvn_mg
2790 Like C<sv_usepvn>, but also handles 'set' magic.
2796 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2798 sv_usepvn(sv,ptr,len);
2803 Perl_sv_force_normal(pTHX_ register SV *sv)
2805 if (SvREADONLY(sv)) {
2807 if (PL_curcop != &PL_compiling)
2808 Perl_croak(aTHX_ PL_no_modify);
2812 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2819 Efficient removal of characters from the beginning of the string buffer.
2820 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
2821 the string buffer. The C<ptr> becomes the first character of the adjusted
2828 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
2832 register STRLEN delta;
2834 if (!ptr || !SvPOKp(sv))
2836 SV_CHECK_THINKFIRST(sv);
2837 if (SvTYPE(sv) < SVt_PVIV)
2838 sv_upgrade(sv,SVt_PVIV);
2841 if (!SvLEN(sv)) { /* make copy of shared string */
2842 char *pvx = SvPVX(sv);
2843 STRLEN len = SvCUR(sv);
2844 SvGROW(sv, len + 1);
2845 Move(pvx,SvPVX(sv),len,char);
2849 SvFLAGS(sv) |= SVf_OOK;
2851 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
2852 delta = ptr - SvPVX(sv);
2860 =for apidoc sv_catpvn
2862 Concatenates the string onto the end of the string which is in the SV. The
2863 C<len> indicates number of bytes to copy. Handles 'get' magic, but not
2864 'set' magic. See C<sv_catpvn_mg>.
2870 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2875 junk = SvPV_force(sv, tlen);
2876 SvGROW(sv, tlen + len + 1);
2879 Move(ptr,SvPVX(sv)+tlen,len,char);
2882 (void)SvPOK_only_UTF8(sv); /* validate pointer */
2887 =for apidoc sv_catpvn_mg
2889 Like C<sv_catpvn>, but also handles 'set' magic.
2895 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2897 sv_catpvn(sv,ptr,len);
2902 =for apidoc sv_catsv
2904 Concatenates the string from SV C<ssv> onto the end of the string in SV
2905 C<dsv>. Handles 'get' magic, but not 'set' magic. See C<sv_catsv_mg>.
2911 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
2917 if (s = SvPV(sstr, len))
2918 sv_catpvn(dstr,s,len);
2924 =for apidoc sv_catsv_mg
2926 Like C<sv_catsv>, but also handles 'set' magic.
2932 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
2934 sv_catsv(dstr,sstr);
2939 =for apidoc sv_catpv
2941 Concatenates the string onto the end of the string which is in the SV.
2942 Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
2948 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
2950 register STRLEN len;
2956 junk = SvPV_force(sv, tlen);
2958 SvGROW(sv, tlen + len + 1);
2961 Move(ptr,SvPVX(sv)+tlen,len+1,char);
2963 (void)SvPOK_only_UTF8(sv); /* validate pointer */
2968 =for apidoc sv_catpv_mg
2970 Like C<sv_catpv>, but also handles 'set' magic.
2976 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
2983 Perl_newSV(pTHX_ STRLEN len)
2989 sv_upgrade(sv, SVt_PV);
2990 SvGROW(sv, len + 1);
2995 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
2998 =for apidoc sv_magic
3000 Adds magic to an SV.
3006 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3010 if (SvREADONLY(sv)) {
3012 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
3013 Perl_croak(aTHX_ PL_no_modify);
3015 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
3016 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3023 (void)SvUPGRADE(sv, SVt_PVMG);
3025 Newz(702,mg, 1, MAGIC);
3026 mg->mg_moremagic = SvMAGIC(sv);
3029 if (!obj || obj == sv || how == '#' || how == 'r')
3033 mg->mg_obj = SvREFCNT_inc(obj);
3034 mg->mg_flags |= MGf_REFCOUNTED;
3037 mg->mg_len = namlen;
3040 mg->mg_ptr = savepvn(name, namlen);
3041 else if (namlen == HEf_SVKEY)
3042 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
3046 mg->mg_virtual = &PL_vtbl_sv;
3049 mg->mg_virtual = &PL_vtbl_amagic;
3052 mg->mg_virtual = &PL_vtbl_amagicelem;
3058 mg->mg_virtual = &PL_vtbl_bm;
3061 mg->mg_virtual = &PL_vtbl_regdata;
3064 mg->mg_virtual = &PL_vtbl_regdatum;
3067 mg->mg_virtual = &PL_vtbl_env;
3070 mg->mg_virtual = &PL_vtbl_fm;
3073 mg->mg_virtual = &PL_vtbl_envelem;
3076 mg->mg_virtual = &PL_vtbl_mglob;
3079 mg->mg_virtual = &PL_vtbl_isa;
3082 mg->mg_virtual = &PL_vtbl_isaelem;
3085 mg->mg_virtual = &PL_vtbl_nkeys;
3092 mg->mg_virtual = &PL_vtbl_dbline;
3096 mg->mg_virtual = &PL_vtbl_mutex;
3098 #endif /* USE_THREADS */
3099 #ifdef USE_LOCALE_COLLATE
3101 mg->mg_virtual = &PL_vtbl_collxfrm;
3103 #endif /* USE_LOCALE_COLLATE */
3105 mg->mg_virtual = &PL_vtbl_pack;
3109 mg->mg_virtual = &PL_vtbl_packelem;
3112 mg->mg_virtual = &PL_vtbl_regexp;
3115 mg->mg_virtual = &PL_vtbl_sig;
3118 mg->mg_virtual = &PL_vtbl_sigelem;
3121 mg->mg_virtual = &PL_vtbl_taint;
3125 mg->mg_virtual = &PL_vtbl_uvar;
3128 mg->mg_virtual = &PL_vtbl_vec;
3131 mg->mg_virtual = &PL_vtbl_substr;
3134 mg->mg_virtual = &PL_vtbl_defelem;
3137 mg->mg_virtual = &PL_vtbl_glob;
3140 mg->mg_virtual = &PL_vtbl_arylen;
3143 mg->mg_virtual = &PL_vtbl_pos;
3146 mg->mg_virtual = &PL_vtbl_backref;
3148 case '~': /* Reserved for use by extensions not perl internals. */
3149 /* Useful for attaching extension internal data to perl vars. */
3150 /* Note that multiple extensions may clash if magical scalars */
3151 /* etc holding private data from one are passed to another. */
3155 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
3159 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
3163 Perl_sv_unmagic(pTHX_ SV *sv, int type)
3167 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
3170 for (mg = *mgp; mg; mg = *mgp) {
3171 if (mg->mg_type == type) {
3172 MGVTBL* vtbl = mg->mg_virtual;
3173 *mgp = mg->mg_moremagic;
3174 if (vtbl && vtbl->svt_free)
3175 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
3176 if (mg->mg_ptr && mg->mg_type != 'g')
3177 if (mg->mg_len >= 0)
3178 Safefree(mg->mg_ptr);
3179 else if (mg->mg_len == HEf_SVKEY)
3180 SvREFCNT_dec((SV*)mg->mg_ptr);
3181 if (mg->mg_flags & MGf_REFCOUNTED)
3182 SvREFCNT_dec(mg->mg_obj);
3186 mgp = &mg->mg_moremagic;
3190 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
3197 Perl_sv_rvweaken(pTHX_ SV *sv)
3200 if (!SvOK(sv)) /* let undefs pass */
3203 Perl_croak(aTHX_ "Can't weaken a nonreference");
3204 else if (SvWEAKREF(sv)) {
3206 if (ckWARN(WARN_MISC))
3207 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
3211 sv_add_backref(tsv, sv);
3218 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
3222 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
3223 av = (AV*)mg->mg_obj;
3226 sv_magic(tsv, (SV*)av, '<', NULL, 0);
3227 SvREFCNT_dec(av); /* for sv_magic */
3233 S_sv_del_backref(pTHX_ SV *sv)
3240 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
3241 Perl_croak(aTHX_ "panic: del_backref");
3242 av = (AV *)mg->mg_obj;
3247 svp[i] = &PL_sv_undef; /* XXX */
3254 =for apidoc sv_insert
3256 Inserts a string at the specified offset/length within the SV. Similar to
3257 the Perl substr() function.
3263 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
3267 register char *midend;
3268 register char *bigend;
3274 Perl_croak(aTHX_ "Can't modify non-existent substring");
3275 SvPV_force(bigstr, curlen);
3276 if (offset + len > curlen) {
3277 SvGROW(bigstr, offset+len+1);
3278 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
3279 SvCUR_set(bigstr, offset+len);
3283 i = littlelen - len;
3284 if (i > 0) { /* string might grow */
3285 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
3286 mid = big + offset + len;
3287 midend = bigend = big + SvCUR(bigstr);
3290 while (midend > mid) /* shove everything down */
3291 *--bigend = *--midend;
3292 Move(little,big+offset,littlelen,char);
3298 Move(little,SvPVX(bigstr)+offset,len,char);
3303 big = SvPVX(bigstr);
3306 bigend = big + SvCUR(bigstr);
3308 if (midend > bigend)
3309 Perl_croak(aTHX_ "panic: sv_insert");
3311 if (mid - big > bigend - midend) { /* faster to shorten from end */
3313 Move(little, mid, littlelen,char);
3316 i = bigend - midend;
3318 Move(midend, mid, i,char);
3322 SvCUR_set(bigstr, mid - big);
3325 else if (i = mid - big) { /* faster from front */
3326 midend -= littlelen;
3328 sv_chop(bigstr,midend-i);
3333 Move(little, mid, littlelen,char);
3335 else if (littlelen) {
3336 midend -= littlelen;
3337 sv_chop(bigstr,midend);
3338 Move(little,midend,littlelen,char);
3341 sv_chop(bigstr,midend);
3346 /* make sv point to what nstr did */
3349 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
3352 U32 refcnt = SvREFCNT(sv);
3353 SV_CHECK_THINKFIRST(sv);
3354 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
3355 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
3356 if (SvMAGICAL(sv)) {
3360 sv_upgrade(nsv, SVt_PVMG);
3361 SvMAGIC(nsv) = SvMAGIC(sv);
3362 SvFLAGS(nsv) |= SvMAGICAL(sv);
3368 assert(!SvREFCNT(sv));
3369 StructCopy(nsv,sv,SV);
3370 SvREFCNT(sv) = refcnt;
3371 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
3376 Perl_sv_clear(pTHX_ register SV *sv)
3380 assert(SvREFCNT(sv) == 0);
3384 if (PL_defstash) { /* Still have a symbol table? */
3389 Zero(&tmpref, 1, SV);
3390 sv_upgrade(&tmpref, SVt_RV);
3392 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
3393 SvREFCNT(&tmpref) = 1;
3396 stash = SvSTASH(sv);
3397 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3400 PUSHSTACKi(PERLSI_DESTROY);
3401 SvRV(&tmpref) = SvREFCNT_inc(sv);
3406 call_sv((SV*)GvCV(destructor),
3407 G_DISCARD|G_EVAL|G_KEEPERR);
3413 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3415 del_XRV(SvANY(&tmpref));
3418 if (PL_in_clean_objs)
3419 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
3421 /* DESTROY gave object new lease on life */
3427 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
3428 SvOBJECT_off(sv); /* Curse the object. */
3429 if (SvTYPE(sv) != SVt_PVIO)
3430 --PL_sv_objcount; /* XXX Might want something more general */
3433 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3436 switch (SvTYPE(sv)) {
3439 IoIFP(sv) != PerlIO_stdin() &&
3440 IoIFP(sv) != PerlIO_stdout() &&
3441 IoIFP(sv) != PerlIO_stderr())
3443 io_close((IO*)sv, FALSE);
3445 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
3446 PerlDir_close(IoDIRP(sv));
3447 IoDIRP(sv) = (DIR*)NULL;
3448 Safefree(IoTOP_NAME(sv));
3449 Safefree(IoFMT_NAME(sv));
3450 Safefree(IoBOTTOM_NAME(sv));
3465 SvREFCNT_dec(LvTARG(sv));
3469 Safefree(GvNAME(sv));
3470 /* cannot decrease stash refcount yet, as we might recursively delete
3471 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3472 of stash until current sv is completely gone.
3473 -- JohnPC, 27 Mar 1998 */
3474 stash = GvSTASH(sv);
3480 (void)SvOOK_off(sv);
3488 SvREFCNT_dec(SvRV(sv));
3490 else if (SvPVX(sv) && SvLEN(sv))
3491 Safefree(SvPVX(sv));
3501 switch (SvTYPE(sv)) {
3517 del_XPVIV(SvANY(sv));
3520 del_XPVNV(SvANY(sv));
3523 del_XPVMG(SvANY(sv));
3526 del_XPVLV(SvANY(sv));
3529 del_XPVAV(SvANY(sv));
3532 del_XPVHV(SvANY(sv));
3535 del_XPVCV(SvANY(sv));
3538 del_XPVGV(SvANY(sv));
3539 /* code duplication for increased performance. */
3540 SvFLAGS(sv) &= SVf_BREAK;
3541 SvFLAGS(sv) |= SVTYPEMASK;
3542 /* decrease refcount of the stash that owns this GV, if any */
3544 SvREFCNT_dec(stash);
3545 return; /* not break, SvFLAGS reset already happened */
3547 del_XPVBM(SvANY(sv));
3550 del_XPVFM(SvANY(sv));
3553 del_XPVIO(SvANY(sv));
3556 SvFLAGS(sv) &= SVf_BREAK;
3557 SvFLAGS(sv) |= SVTYPEMASK;
3561 Perl_sv_newref(pTHX_ SV *sv)
3564 ATOMIC_INC(SvREFCNT(sv));
3569 Perl_sv_free(pTHX_ SV *sv)
3572 int refcount_is_zero;
3576 if (SvREFCNT(sv) == 0) {
3577 if (SvFLAGS(sv) & SVf_BREAK)
3579 if (PL_in_clean_all) /* All is fair */
3581 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3582 /* make sure SvREFCNT(sv)==0 happens very seldom */
3583 SvREFCNT(sv) = (~(U32)0)/2;
3586 if (ckWARN_d(WARN_INTERNAL))
3587 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
3590 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3591 if (!refcount_is_zero)
3595 if (ckWARN_d(WARN_DEBUGGING))
3596 Perl_warner(aTHX_ WARN_DEBUGGING,
3597 "Attempt to free temp prematurely: SV 0x%"UVxf,
3602 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3603 /* make sure SvREFCNT(sv)==0 happens very seldom */
3604 SvREFCNT(sv) = (~(U32)0)/2;
3615 Returns the length of the string in the SV. See also C<SvCUR>.
3621 Perl_sv_len(pTHX_ register SV *sv)
3630 len = mg_length(sv);
3632 junk = SvPV(sv, len);
3637 Perl_sv_len_utf8(pTHX_ register SV *sv)
3648 len = mg_length(sv);
3651 s = (U8*)SvPV(sv, len);
3662 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
3667 I32 uoffset = *offsetp;
3673 start = s = (U8*)SvPV(sv, len);
3675 while (s < send && uoffset--)
3679 *offsetp = s - start;
3683 while (s < send && ulen--)
3693 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
3702 s = (U8*)SvPV(sv, len);
3704 Perl_croak(aTHX_ "panic: bad byte offset");
3705 send = s + *offsetp;
3713 if (ckWARN_d(WARN_UTF8))
3714 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
3724 Returns a boolean indicating whether the strings in the two SVs are
3731 Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
3743 pv1 = SvPV(str1, cur1);
3748 pv2 = SvPV(str2, cur2);
3753 return memEQ(pv1, pv2, cur1);
3759 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
3760 string in C<sv1> is less than, equal to, or greater than the string in
3767 Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
3770 char *pv1 = str1 ? SvPV(str1, cur1) : (char *) NULL;
3772 char *pv2 = str2 ? SvPV(str2, cur2) : (char *) NULL;
3776 return cur2 ? -1 : 0;
3781 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
3784 return retval < 0 ? -1 : 1;
3789 return cur1 < cur2 ? -1 : 1;
3793 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
3795 #ifdef USE_LOCALE_COLLATE
3801 if (PL_collation_standard)
3805 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
3807 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
3809 if (!pv1 || !len1) {
3820 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
3823 return retval < 0 ? -1 : 1;
3826 * When the result of collation is equality, that doesn't mean
3827 * that there are no differences -- some locales exclude some
3828 * characters from consideration. So to avoid false equalities,
3829 * we use the raw string as a tiebreaker.
3835 #endif /* USE_LOCALE_COLLATE */
3837 return sv_cmp(sv1, sv2);
3840 #ifdef USE_LOCALE_COLLATE
3842 * Any scalar variable may carry an 'o' magic that contains the
3843 * scalar data of the variable transformed to such a format that
3844 * a normal memory comparison can be used to compare the data
3845 * according to the locale settings.
3848 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
3852 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
3853 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
3858 Safefree(mg->mg_ptr);
3860 if ((xf = mem_collxfrm(s, len, &xlen))) {
3861 if (SvREADONLY(sv)) {
3864 return xf + sizeof(PL_collation_ix);
3867 sv_magic(sv, 0, 'o', 0, 0);
3868 mg = mg_find(sv, 'o');
3881 if (mg && mg->mg_ptr) {
3883 return mg->mg_ptr + sizeof(PL_collation_ix);
3891 #endif /* USE_LOCALE_COLLATE */
3894 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
3899 register STDCHAR rslast;
3900 register STDCHAR *bp;
3904 SV_CHECK_THINKFIRST(sv);
3905 (void)SvUPGRADE(sv, SVt_PV);
3909 if (RsSNARF(PL_rs)) {
3913 else if (RsRECORD(PL_rs)) {
3914 I32 recsize, bytesread;
3917 /* Grab the size of the record we're getting */
3918 recsize = SvIV(SvRV(PL_rs));
3919 (void)SvPOK_only(sv); /* Validate pointer */
3920 buffer = SvGROW(sv, recsize + 1);
3923 /* VMS wants read instead of fread, because fread doesn't respect */
3924 /* RMS record boundaries. This is not necessarily a good thing to be */
3925 /* doing, but we've got no other real choice */
3926 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
3928 bytesread = PerlIO_read(fp, buffer, recsize);
3930 SvCUR_set(sv, bytesread);
3931 buffer[bytesread] = '\0';
3932 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
3934 else if (RsPARA(PL_rs)) {
3939 rsptr = SvPV(PL_rs, rslen);
3940 rslast = rslen ? rsptr[rslen - 1] : '\0';
3942 if (RsPARA(PL_rs)) { /* have to do this both before and after */
3943 do { /* to make sure file boundaries work right */
3946 i = PerlIO_getc(fp);
3950 PerlIO_ungetc(fp,i);
3956 /* See if we know enough about I/O mechanism to cheat it ! */
3958 /* This used to be #ifdef test - it is made run-time test for ease
3959 of abstracting out stdio interface. One call should be cheap
3960 enough here - and may even be a macro allowing compile
3964 if (PerlIO_fast_gets(fp)) {
3967 * We're going to steal some values from the stdio struct
3968 * and put EVERYTHING in the innermost loop into registers.
3970 register STDCHAR *ptr;
3974 #if defined(VMS) && defined(PERLIO_IS_STDIO)
3975 /* An ungetc()d char is handled separately from the regular
3976 * buffer, so we getc() it back out and stuff it in the buffer.
3978 i = PerlIO_getc(fp);
3979 if (i == EOF) return 0;
3980 *(--((*fp)->_ptr)) = (unsigned char) i;
3984 /* Here is some breathtakingly efficient cheating */
3986 cnt = PerlIO_get_cnt(fp); /* get count into register */
3987 (void)SvPOK_only(sv); /* validate pointer */
3988 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
3989 if (cnt > 80 && SvLEN(sv) > append) {
3990 shortbuffered = cnt - SvLEN(sv) + append + 1;
3991 cnt -= shortbuffered;
3995 /* remember that cnt can be negative */
3996 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
4001 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
4002 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
4003 DEBUG_P(PerlIO_printf(Perl_debug_log,
4004 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4005 DEBUG_P(PerlIO_printf(Perl_debug_log,
4006 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4007 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4008 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
4013 while (cnt > 0) { /* this | eat */
4015 if ((*bp++ = *ptr++) == rslast) /* really | dust */
4016 goto thats_all_folks; /* screams | sed :-) */
4020 Copy(ptr, bp, cnt, char); /* this | eat */
4021 bp += cnt; /* screams | dust */
4022 ptr += cnt; /* louder | sed :-) */
4027 if (shortbuffered) { /* oh well, must extend */
4028 cnt = shortbuffered;
4030 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4032 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
4033 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4037 DEBUG_P(PerlIO_printf(Perl_debug_log,
4038 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
4039 PTR2UV(ptr),(long)cnt));
4040 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
4041 DEBUG_P(PerlIO_printf(Perl_debug_log,
4042 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4043 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4044 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4045 /* This used to call 'filbuf' in stdio form, but as that behaves like
4046 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
4047 another abstraction. */
4048 i = PerlIO_getc(fp); /* get more characters */
4049 DEBUG_P(PerlIO_printf(Perl_debug_log,
4050 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4051 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4052 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4053 cnt = PerlIO_get_cnt(fp);
4054 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
4055 DEBUG_P(PerlIO_printf(Perl_debug_log,
4056 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4058 if (i == EOF) /* all done for ever? */
4059 goto thats_really_all_folks;
4061 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4063 SvGROW(sv, bpx + cnt + 2);
4064 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4066 *bp++ = i; /* store character from PerlIO_getc */
4068 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
4069 goto thats_all_folks;
4073 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
4074 memNE((char*)bp - rslen, rsptr, rslen))
4075 goto screamer; /* go back to the fray */
4076 thats_really_all_folks:
4078 cnt += shortbuffered;
4079 DEBUG_P(PerlIO_printf(Perl_debug_log,
4080 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4081 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
4082 DEBUG_P(PerlIO_printf(Perl_debug_log,
4083 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4084 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4085 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4087 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
4088 DEBUG_P(PerlIO_printf(Perl_debug_log,
4089 "Screamer: done, len=%ld, string=|%.*s|\n",
4090 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
4095 /*The big, slow, and stupid way */
4098 /* Need to work around EPOC SDK features */
4099 /* On WINS: MS VC5 generates calls to _chkstk, */
4100 /* if a `large' stack frame is allocated */
4101 /* gcc on MARM does not generate calls like these */
4107 register STDCHAR *bpe = buf + sizeof(buf);
4109 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
4110 ; /* keep reading */
4114 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
4115 /* Accomodate broken VAXC compiler, which applies U8 cast to
4116 * both args of ?: operator, causing EOF to change into 255
4118 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
4122 sv_catpvn(sv, (char *) buf, cnt);
4124 sv_setpvn(sv, (char *) buf, cnt);
4126 if (i != EOF && /* joy */
4128 SvCUR(sv) < rslen ||
4129 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
4133 * If we're reading from a TTY and we get a short read,
4134 * indicating that the user hit his EOF character, we need
4135 * to notice it now, because if we try to read from the TTY
4136 * again, the EOF condition will disappear.
4138 * The comparison of cnt to sizeof(buf) is an optimization
4139 * that prevents unnecessary calls to feof().
4143 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
4148 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4149 while (i != EOF) { /* to make sure file boundaries work right */
4150 i = PerlIO_getc(fp);
4152 PerlIO_ungetc(fp,i);
4158 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
4165 Auto-increment of the value in the SV.
4171 Perl_sv_inc(pTHX_ register SV *sv)
4180 if (SvTHINKFIRST(sv)) {
4181 if (SvREADONLY(sv)) {
4183 if (PL_curcop != &PL_compiling)
4184 Perl_croak(aTHX_ PL_no_modify);
4188 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
4190 i = PTR2IV(SvRV(sv));
4195 flags = SvFLAGS(sv);
4196 if (flags & SVp_NOK) {
4197 (void)SvNOK_only(sv);
4201 if (flags & SVp_IOK) {
4203 if (SvUVX(sv) == UV_MAX)
4204 sv_setnv(sv, (NV)UV_MAX + 1.0);
4206 (void)SvIOK_only_UV(sv);
4209 if (SvIVX(sv) == IV_MAX)
4210 sv_setnv(sv, (NV)IV_MAX + 1.0);
4212 (void)SvIOK_only(sv);
4218 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
4219 if ((flags & SVTYPEMASK) < SVt_PVNV)
4220 sv_upgrade(sv, SVt_NV);
4222 (void)SvNOK_only(sv);
4226 while (isALPHA(*d)) d++;
4227 while (isDIGIT(*d)) d++;
4229 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
4233 while (d >= SvPVX(sv)) {
4241 /* MKS: The original code here died if letters weren't consecutive.
4242 * at least it didn't have to worry about non-C locales. The
4243 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
4244 * arranged in order (although not consecutively) and that only
4245 * [A-Za-z] are accepted by isALPHA in the C locale.
4247 if (*d != 'z' && *d != 'Z') {
4248 do { ++*d; } while (!isALPHA(*d));
4251 *(d--) -= 'z' - 'a';
4256 *(d--) -= 'z' - 'a' + 1;
4260 /* oh,oh, the number grew */
4261 SvGROW(sv, SvCUR(sv) + 2);
4263 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
4274 Auto-decrement of the value in the SV.
4280 Perl_sv_dec(pTHX_ register SV *sv)
4288 if (SvTHINKFIRST(sv)) {
4289 if (SvREADONLY(sv)) {
4291 if (PL_curcop != &PL_compiling)
4292 Perl_croak(aTHX_ PL_no_modify);
4296 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
4298 i = PTR2IV(SvRV(sv));
4303 flags = SvFLAGS(sv);
4304 if (flags & SVp_NOK) {
4306 (void)SvNOK_only(sv);
4309 if (flags & SVp_IOK) {
4311 if (SvUVX(sv) == 0) {
4312 (void)SvIOK_only(sv);
4316 (void)SvIOK_only_UV(sv);
4320 if (SvIVX(sv) == IV_MIN)
4321 sv_setnv(sv, (NV)IV_MIN - 1.0);
4323 (void)SvIOK_only(sv);
4329 if (!(flags & SVp_POK)) {
4330 if ((flags & SVTYPEMASK) < SVt_PVNV)
4331 sv_upgrade(sv, SVt_NV);
4333 (void)SvNOK_only(sv);
4336 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
4340 =for apidoc sv_mortalcopy
4342 Creates a new SV which is a copy of the original SV. The new SV is marked
4348 /* Make a string that will exist for the duration of the expression
4349 * evaluation. Actually, it may have to last longer than that, but
4350 * hopefully we won't free it until it has been assigned to a
4351 * permanent location. */
4354 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
4360 sv_setsv(sv,oldstr);
4362 PL_tmps_stack[++PL_tmps_ix] = sv;
4368 =for apidoc sv_newmortal
4370 Creates a new SV which is mortal. The reference count of the SV is set to 1.
4376 Perl_sv_newmortal(pTHX)
4382 SvFLAGS(sv) = SVs_TEMP;
4384 PL_tmps_stack[++PL_tmps_ix] = sv;
4389 =for apidoc sv_2mortal
4391 Marks an SV as mortal. The SV will be destroyed when the current context
4397 /* same thing without the copying */
4400 Perl_sv_2mortal(pTHX_ register SV *sv)
4405 if (SvREADONLY(sv) && SvIMMORTAL(sv))
4408 PL_tmps_stack[++PL_tmps_ix] = sv;
4416 Creates a new SV and copies a string into it. The reference count for the
4417 SV is set to 1. If C<len> is zero, Perl will compute the length using
4418 strlen(). For efficiency, consider using C<newSVpvn> instead.
4424 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
4431 sv_setpvn(sv,s,len);
4436 =for apidoc newSVpvn
4438 Creates a new SV and copies a string into it. The reference count for the
4439 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
4440 string. You are responsible for ensuring that the source string is at least
4447 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
4452 sv_setpvn(sv,s,len);
4456 #if defined(PERL_IMPLICIT_CONTEXT)
4458 Perl_newSVpvf_nocontext(const char* pat, ...)
4463 va_start(args, pat);
4464 sv = vnewSVpvf(pat, &args);
4471 =for apidoc newSVpvf
4473 Creates a new SV an initialize it with the string formatted like
4480 Perl_newSVpvf(pTHX_ const char* pat, ...)
4484 va_start(args, pat);
4485 sv = vnewSVpvf(pat, &args);
4491 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
4495 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4502 Creates a new SV and copies a floating point value into it.
4503 The reference count for the SV is set to 1.
4509 Perl_newSVnv(pTHX_ NV n)
4521 Creates a new SV and copies an integer into it. The reference count for the
4528 Perl_newSViv(pTHX_ IV i)
4538 =for apidoc newRV_noinc
4540 Creates an RV wrapper for an SV. The reference count for the original
4541 SV is B<not> incremented.
4547 Perl_newRV_noinc(pTHX_ SV *tmpRef)
4553 sv_upgrade(sv, SVt_RV);
4560 /* newRV_inc is #defined to newRV in sv.h */
4562 Perl_newRV(pTHX_ SV *tmpRef)
4564 return newRV_noinc(SvREFCNT_inc(tmpRef));
4570 Creates a new SV which is an exact duplicate of the original SV.
4575 /* make an exact duplicate of old */
4578 Perl_newSVsv(pTHX_ register SV *old)
4585 if (SvTYPE(old) == SVTYPEMASK) {
4586 if (ckWARN_d(WARN_INTERNAL))
4587 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
4602 Perl_sv_reset(pTHX_ register char *s, HV *stash)
4610 char todo[PERL_UCHAR_MAX+1];
4615 if (!*s) { /* reset ?? searches */
4616 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4617 pm->op_pmdynflags &= ~PMdf_USED;
4622 /* reset variables */
4624 if (!HvARRAY(stash))
4627 Zero(todo, 256, char);
4629 i = (unsigned char)*s;
4633 max = (unsigned char)*s++;
4634 for ( ; i <= max; i++) {
4637 for (i = 0; i <= (I32) HvMAX(stash); i++) {
4638 for (entry = HvARRAY(stash)[i];
4640 entry = HeNEXT(entry))
4642 if (!todo[(U8)*HeKEY(entry)])
4644 gv = (GV*)HeVAL(entry);
4646 if (SvTHINKFIRST(sv)) {
4647 if (!SvREADONLY(sv) && SvROK(sv))
4652 if (SvTYPE(sv) >= SVt_PV) {
4654 if (SvPVX(sv) != Nullch)
4661 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4663 #ifndef VMS /* VMS has no environ array */
4665 environ[0] = Nullch;
4674 Perl_sv_2io(pTHX_ SV *sv)
4680 switch (SvTYPE(sv)) {
4688 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
4692 Perl_croak(aTHX_ PL_no_usym, "filehandle");
4694 return sv_2io(SvRV(sv));
4695 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4701 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
4708 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
4715 return *gvp = Nullgv, Nullcv;
4716 switch (SvTYPE(sv)) {
4736 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
4737 tryAMAGICunDEREF(to_cv);
4740 if (SvTYPE(sv) == SVt_PVCV) {
4749 Perl_croak(aTHX_ "Not a subroutine reference");
4754 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
4760 if (lref && !GvCVu(gv)) {
4763 tmpsv = NEWSV(704,0);
4764 gv_efullname3(tmpsv, gv, Nullch);
4765 /* XXX this is probably not what they think they're getting.
4766 * It has the same effect as "sub name;", i.e. just a forward
4768 newSUB(start_subparse(FALSE, 0),
4769 newSVOP(OP_CONST, 0, tmpsv),
4774 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
4781 Perl_sv_true(pTHX_ register SV *sv)
4788 if ((tXpv = (XPV*)SvANY(sv)) &&
4789 (tXpv->xpv_cur > 1 ||
4790 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
4797 return SvIVX(sv) != 0;
4800 return SvNVX(sv) != 0.0;
4802 return sv_2bool(sv);
4808 Perl_sv_iv(pTHX_ register SV *sv)
4812 return (IV)SvUVX(sv);
4819 Perl_sv_uv(pTHX_ register SV *sv)
4824 return (UV)SvIVX(sv);
4830 Perl_sv_nv(pTHX_ register SV *sv)
4838 Perl_sv_pv(pTHX_ SV *sv)
4845 return sv_2pv(sv, &n_a);
4849 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
4855 return sv_2pv(sv, lp);
4859 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
4863 if (SvTHINKFIRST(sv) && !SvROK(sv))
4864 sv_force_normal(sv);
4870 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
4872 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
4873 PL_op_name[PL_op->op_type]);
4877 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
4882 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
4883 SvGROW(sv, len + 1);
4884 Move(s,SvPVX(sv),len,char);
4889 SvPOK_on(sv); /* validate pointer */
4891 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
4892 PTR2UV(sv),SvPVX(sv)));
4899 Perl_sv_pvbyte(pTHX_ SV *sv)
4905 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
4907 return sv_pvn(sv,lp);
4911 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
4913 return sv_pvn_force(sv,lp);
4917 Perl_sv_pvutf8(pTHX_ SV *sv)
4923 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
4925 return sv_pvn(sv,lp);
4929 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
4931 return sv_pvn_force(sv,lp);
4935 Perl_sv_reftype(pTHX_ SV *sv, int ob)
4937 if (ob && SvOBJECT(sv))
4938 return HvNAME(SvSTASH(sv));
4940 switch (SvTYPE(sv)) {
4954 case SVt_PVLV: return "LVALUE";
4955 case SVt_PVAV: return "ARRAY";
4956 case SVt_PVHV: return "HASH";
4957 case SVt_PVCV: return "CODE";
4958 case SVt_PVGV: return "GLOB";
4959 case SVt_PVFM: return "FORMAT";
4960 default: return "UNKNOWN";
4966 =for apidoc sv_isobject
4968 Returns a boolean indicating whether the SV is an RV pointing to a blessed
4969 object. If the SV is not an RV, or if the object is not blessed, then this
4976 Perl_sv_isobject(pTHX_ SV *sv)
4993 Returns a boolean indicating whether the SV is blessed into the specified
4994 class. This does not check for subtypes; use C<sv_derived_from> to verify
4995 an inheritance relationship.
5001 Perl_sv_isa(pTHX_ SV *sv, const char *name)
5013 return strEQ(HvNAME(SvSTASH(sv)), name);
5019 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
5020 it will be upgraded to one. If C<classname> is non-null then the new SV will
5021 be blessed in the specified package. The new SV is returned and its
5022 reference count is 1.
5028 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
5035 SV_CHECK_THINKFIRST(rv);
5038 if (SvTYPE(rv) < SVt_RV)
5039 sv_upgrade(rv, SVt_RV);
5046 HV* stash = gv_stashpv(classname, TRUE);
5047 (void)sv_bless(rv, stash);
5053 =for apidoc sv_setref_pv
5055 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
5056 argument will be upgraded to an RV. That RV will be modified to point to
5057 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
5058 into the SV. The C<classname> argument indicates the package for the
5059 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5060 will be returned and will have a reference count of 1.
5062 Do not use with other Perl types such as HV, AV, SV, CV, because those
5063 objects will become corrupted by the pointer copy process.
5065 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
5071 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
5074 sv_setsv(rv, &PL_sv_undef);
5078 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
5083 =for apidoc sv_setref_iv
5085 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
5086 argument will be upgraded to an RV. That RV will be modified to point to
5087 the new SV. The C<classname> argument indicates the package for the
5088 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5089 will be returned and will have a reference count of 1.
5095 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
5097 sv_setiv(newSVrv(rv,classname), iv);
5102 =for apidoc sv_setref_nv
5104 Copies a double into a new SV, optionally blessing the SV. The C<rv>
5105 argument will be upgraded to an RV. That RV will be modified to point to
5106 the new SV. The C<classname> argument indicates the package for the
5107 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5108 will be returned and will have a reference count of 1.
5114 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
5116 sv_setnv(newSVrv(rv,classname), nv);
5121 =for apidoc sv_setref_pvn
5123 Copies a string into a new SV, optionally blessing the SV. The length of the
5124 string must be specified with C<n>. The C<rv> argument will be upgraded to
5125 an RV. That RV will be modified to point to the new SV. The C<classname>
5126 argument indicates the package for the blessing. Set C<classname> to
5127 C<Nullch> to avoid the blessing. The new SV will be returned and will have
5128 a reference count of 1.
5130 Note that C<sv_setref_pv> copies the pointer while this copies the string.
5136 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
5138 sv_setpvn(newSVrv(rv,classname), pv, n);
5143 =for apidoc sv_bless
5145 Blesses an SV into a specified package. The SV must be an RV. The package
5146 must be designated by its stash (see C<gv_stashpv()>). The reference count
5147 of the SV is unaffected.
5153 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
5158 Perl_croak(aTHX_ "Can't bless non-reference value");
5160 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
5161 if (SvREADONLY(tmpRef))
5162 Perl_croak(aTHX_ PL_no_modify);
5163 if (SvOBJECT(tmpRef)) {
5164 if (SvTYPE(tmpRef) != SVt_PVIO)
5166 SvREFCNT_dec(SvSTASH(tmpRef));
5169 SvOBJECT_on(tmpRef);
5170 if (SvTYPE(tmpRef) != SVt_PVIO)
5172 (void)SvUPGRADE(tmpRef, SVt_PVMG);
5173 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
5184 S_sv_unglob(pTHX_ SV *sv)
5186 assert(SvTYPE(sv) == SVt_PVGV);
5191 SvREFCNT_dec(GvSTASH(sv));
5192 GvSTASH(sv) = Nullhv;
5194 sv_unmagic(sv, '*');
5195 Safefree(GvNAME(sv));
5197 SvFLAGS(sv) &= ~SVTYPEMASK;
5198 SvFLAGS(sv) |= SVt_PVMG;
5202 =for apidoc sv_unref
5204 Unsets the RV status of the SV, and decrements the reference count of
5205 whatever was being referenced by the RV. This can almost be thought of
5206 as a reversal of C<newSVrv>. See C<SvROK_off>.
5212 Perl_sv_unref(pTHX_ SV *sv)
5216 if (SvWEAKREF(sv)) {
5224 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
5227 sv_2mortal(rv); /* Schedule for freeing later */
5231 Perl_sv_taint(pTHX_ SV *sv)
5233 sv_magic((sv), Nullsv, 't', Nullch, 0);
5237 Perl_sv_untaint(pTHX_ SV *sv)
5239 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5240 MAGIC *mg = mg_find(sv, 't');
5247 Perl_sv_tainted(pTHX_ SV *sv)
5249 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5250 MAGIC *mg = mg_find(sv, 't');
5251 if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
5258 =for apidoc sv_setpviv
5260 Copies an integer into the given SV, also updating its string value.
5261 Does not handle 'set' magic. See C<sv_setpviv_mg>.
5267 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
5269 char buf[TYPE_CHARS(UV)];
5271 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5273 sv_setpvn(sv, ptr, ebuf - ptr);
5278 =for apidoc sv_setpviv_mg
5280 Like C<sv_setpviv>, but also handles 'set' magic.
5286 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
5288 char buf[TYPE_CHARS(UV)];
5290 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5292 sv_setpvn(sv, ptr, ebuf - ptr);
5296 #if defined(PERL_IMPLICIT_CONTEXT)
5298 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
5302 va_start(args, pat);
5303 sv_vsetpvf(sv, pat, &args);
5309 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
5313 va_start(args, pat);
5314 sv_vsetpvf_mg(sv, pat, &args);
5320 =for apidoc sv_setpvf
5322 Processes its arguments like C<sprintf> and sets an SV to the formatted
5323 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
5329 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
5332 va_start(args, pat);
5333 sv_vsetpvf(sv, pat, &args);
5338 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5340 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5344 =for apidoc sv_setpvf_mg
5346 Like C<sv_setpvf>, but also handles 'set' magic.
5352 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5355 va_start(args, pat);
5356 sv_vsetpvf_mg(sv, pat, &args);
5361 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5363 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5367 #if defined(PERL_IMPLICIT_CONTEXT)
5369 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
5373 va_start(args, pat);
5374 sv_vcatpvf(sv, pat, &args);
5379 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
5383 va_start(args, pat);
5384 sv_vcatpvf_mg(sv, pat, &args);
5390 =for apidoc sv_catpvf
5392 Processes its arguments like C<sprintf> and appends the formatted output
5393 to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
5394 typically be called after calling this function to handle 'set' magic.
5400 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
5403 va_start(args, pat);
5404 sv_vcatpvf(sv, pat, &args);
5409 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5411 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5415 =for apidoc sv_catpvf_mg
5417 Like C<sv_catpvf>, but also handles 'set' magic.
5423 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5426 va_start(args, pat);
5427 sv_vcatpvf_mg(sv, pat, &args);
5432 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5434 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5439 =for apidoc sv_vsetpvfn
5441 Works like C<vcatpvfn> but copies the text into the SV instead of
5448 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5450 sv_setpvn(sv, "", 0);
5451 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
5455 =for apidoc sv_vcatpvfn
5457 Processes its arguments like C<vsprintf> and appends the formatted output
5458 to an SV. Uses an array of SVs if the C style variable argument list is
5459 missing (NULL). When running with taint checks enabled, indicates via
5460 C<maybe_tainted> if results are untrustworthy (often due to the use of
5467 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5475 static char nullstr[] = "(null)";
5478 /* no matter what, this is a string now */
5479 (void)SvPV_force(sv, origlen);
5481 /* special-case "", "%s", and "%_" */
5484 if (patlen == 2 && pat[0] == '%') {
5488 char *s = va_arg(*args, char*);
5489 sv_catpv(sv, s ? s : nullstr);
5491 else if (svix < svmax) {
5492 sv_catsv(sv, *svargs);
5493 if (DO_UTF8(*svargs))
5499 argsv = va_arg(*args, SV*);
5500 sv_catsv(sv, argsv);
5505 /* See comment on '_' below */
5510 patend = (char*)pat + patlen;
5511 for (p = (char*)pat; p < patend; p = q) {
5519 bool has_precis = FALSE;
5521 bool is_utf = FALSE;
5525 STRLEN esignlen = 0;
5527 char *eptr = Nullch;
5529 /* Times 4: a decimal digit takes more than 3 binary digits.
5530 * NV_DIG: mantissa takes than many decimal digits.
5531 * Plus 32: Playing safe. */
5532 char ebuf[IV_DIG * 4 + NV_DIG + 32];
5533 /* large enough for "%#.#f" --chip */
5534 /* what about long double NVs? --jhi */
5545 for (q = p; q < patend && *q != '%'; ++q) ;
5547 sv_catpvn(sv, p, q - p);
5585 case '1': case '2': case '3':
5586 case '4': case '5': case '6':
5587 case '7': case '8': case '9':
5590 width = width * 10 + (*q++ - '0');
5595 i = va_arg(*args, int);
5597 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5599 width = (i < 0) ? -i : i;
5610 i = va_arg(*args, int);
5612 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5613 precis = (i < 0) ? 0 : i;
5619 precis = precis * 10 + (*q++ - '0');
5636 if (*(q + 1) == 'l') { /* lld */
5663 uv = va_arg(*args, int);
5665 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5666 if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
5667 eptr = (char*)utf8buf;
5668 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
5680 eptr = va_arg(*args, char*);
5682 #ifdef MACOS_TRADITIONAL
5683 /* On MacOS, %#s format is used for Pascal strings */
5688 elen = strlen(eptr);
5691 elen = sizeof nullstr - 1;
5694 else if (svix < svmax) {
5695 argsv = svargs[svix++];
5696 eptr = SvPVx(argsv, elen);
5697 if (DO_UTF8(argsv)) {
5698 if (has_precis && precis < elen) {
5700 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
5703 if (width) { /* fudge width (can't fudge elen) */
5704 width += elen - sv_len_utf8(argsv);
5713 argsv = va_arg(*args, SV*);
5714 else if (svix < svmax)
5715 argsv = svargs[svix++];
5718 U8 *str = (U8*)SvPVx(argsv,len);
5720 SV *vsv = NEWSV(73,vlen);
5723 U8 *vptr = (U8*)SvPVX(vsv);
5725 bool utf = DO_UTF8(argsv);
5733 uv = utf8_to_uv(str, &ulen);
5740 eptr = ebuf + sizeof ebuf;
5742 *--eptr = '0' + uv % 10;
5744 elen = (ebuf + sizeof ebuf) - eptr;
5745 while (elen >= vfree-1) {
5746 STRLEN off = vptr - (U8*)SvPVX(vsv);
5750 vptr = (U8*)SvPVX(vsv) + off;
5752 memcpy(vptr, eptr, elen);
5762 SvCUR_set(vsv,vcur);
5770 * The "%_" hack might have to be changed someday,
5771 * if ISO or ANSI decide to use '_' for something.
5772 * So we keep it hidden from users' code.
5776 argsv = va_arg(*args,SV*);
5777 eptr = SvPVx(argsv, elen);
5782 if (has_precis && elen > precis)
5790 uv = PTR2UV(va_arg(*args, void*));
5792 uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
5807 case 'h': iv = (short)va_arg(*args, int); break;
5808 default: iv = va_arg(*args, int); break;
5809 case 'l': iv = va_arg(*args, long); break;
5810 case 'V': iv = va_arg(*args, IV); break;
5812 case 'q': iv = va_arg(*args, Quad_t); break;
5817 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5819 case 'h': iv = (short)iv; break;
5820 default: iv = (int)iv; break;
5821 case 'l': iv = (long)iv; break;
5824 case 'q': iv = (Quad_t)iv; break;
5831 esignbuf[esignlen++] = plus;
5835 esignbuf[esignlen++] = '-';
5873 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
5874 default: uv = va_arg(*args, unsigned); break;
5875 case 'l': uv = va_arg(*args, unsigned long); break;
5876 case 'V': uv = va_arg(*args, UV); break;
5878 case 'q': uv = va_arg(*args, Quad_t); break;
5883 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
5885 case 'h': uv = (unsigned short)uv; break;
5886 default: uv = (unsigned)uv; break;
5887 case 'l': uv = (unsigned long)uv; break;
5890 case 'q': uv = (Quad_t)uv; break;
5896 eptr = ebuf + sizeof ebuf;
5902 p = (char*)((c == 'X')
5903 ? "0123456789ABCDEF" : "0123456789abcdef");
5909 esignbuf[esignlen++] = '0';
5910 esignbuf[esignlen++] = c; /* 'x' or 'X' */
5916 *--eptr = '0' + dig;
5918 if (alt && *eptr != '0')
5924 *--eptr = '0' + dig;
5927 esignbuf[esignlen++] = '0';
5928 esignbuf[esignlen++] = 'b';
5931 default: /* it had better be ten or less */
5932 #if defined(PERL_Y2KWARN)
5933 if (ckWARN(WARN_MISC)) {
5935 char *s = SvPV(sv,n);
5936 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
5937 && (n == 2 || !isDIGIT(s[n-3])))
5939 Perl_warner(aTHX_ WARN_MISC,
5940 "Possible Y2K bug: %%%c %s",
5941 c, "format string following '19'");
5947 *--eptr = '0' + dig;
5948 } while (uv /= base);
5951 elen = (ebuf + sizeof ebuf) - eptr;
5954 zeros = precis - elen;
5955 else if (precis == 0 && elen == 1 && *eptr == '0')
5960 /* FLOATING POINT */
5963 c = 'f'; /* maybe %F isn't supported here */
5969 /* This is evil, but floating point is even more evil */
5972 nv = va_arg(*args, NV);
5974 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
5977 if (c != 'e' && c != 'E') {
5979 (void)frexp(nv, &i);
5980 if (i == PERL_INT_MIN)
5981 Perl_die(aTHX_ "panic: frexp");
5983 need = BIT_DIGITS(i);
5985 need += has_precis ? precis : 6; /* known default */
5989 need += 20; /* fudge factor */
5990 if (PL_efloatsize < need) {
5991 Safefree(PL_efloatbuf);
5992 PL_efloatsize = need + 20; /* more fudge */
5993 New(906, PL_efloatbuf, PL_efloatsize, char);
5994 PL_efloatbuf[0] = '\0';
5997 eptr = ebuf + sizeof ebuf;
6000 #ifdef USE_LONG_DOUBLE
6002 char* p = PERL_PRIfldbl + sizeof(PERL_PRIfldbl) - 3;
6003 while (p >= PERL_PRIfldbl) { *--eptr = *p--; }
6008 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6013 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6026 RESTORE_NUMERIC_STANDARD();
6027 (void)sprintf(PL_efloatbuf, eptr, nv);
6028 RESTORE_NUMERIC_LOCAL();
6031 eptr = PL_efloatbuf;
6032 elen = strlen(PL_efloatbuf);
6038 i = SvCUR(sv) - origlen;
6041 case 'h': *(va_arg(*args, short*)) = i; break;
6042 default: *(va_arg(*args, int*)) = i; break;
6043 case 'l': *(va_arg(*args, long*)) = i; break;
6044 case 'V': *(va_arg(*args, IV*)) = i; break;
6046 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
6050 else if (svix < svmax)
6051 sv_setuv(svargs[svix++], (UV)i);
6052 continue; /* not "break" */
6058 if (!args && ckWARN(WARN_PRINTF) &&
6059 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
6060 SV *msg = sv_newmortal();
6061 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
6062 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
6065 Perl_sv_catpvf(aTHX_ msg,
6066 "\"%%%c\"", c & 0xFF);
6068 Perl_sv_catpvf(aTHX_ msg,
6069 "\"%%\\%03"UVof"\"",
6072 sv_catpv(msg, "end of string");
6073 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
6076 /* output mangled stuff ... */
6082 /* ... right here, because formatting flags should not apply */
6083 SvGROW(sv, SvCUR(sv) + elen + 1);
6085 memcpy(p, eptr, elen);
6088 SvCUR(sv) = p - SvPVX(sv);
6089 continue; /* not "break" */
6092 have = esignlen + zeros + elen;
6093 need = (have > width ? have : width);
6096 SvGROW(sv, SvCUR(sv) + need + 1);
6098 if (esignlen && fill == '0') {
6099 for (i = 0; i < esignlen; i++)
6103 memset(p, fill, gap);
6106 if (esignlen && fill != '0') {
6107 for (i = 0; i < esignlen; i++)
6111 for (i = zeros; i; i--)
6115 memcpy(p, eptr, elen);
6119 memset(p, ' ', gap);
6125 SvCUR(sv) = p - SvPVX(sv);
6129 #if defined(USE_ITHREADS)
6131 #if defined(USE_THREADS)
6132 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
6135 #ifndef OpREFCNT_inc
6136 # define OpREFCNT_inc(o) ((o) ? (++(o)->op_targ, (o)) : Nullop)
6139 #ifndef GpREFCNT_inc
6140 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
6144 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
6145 #define av_dup(s) (AV*)sv_dup((SV*)s)
6146 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
6147 #define hv_dup(s) (HV*)sv_dup((SV*)s)
6148 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
6149 #define cv_dup(s) (CV*)sv_dup((SV*)s)
6150 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
6151 #define io_dup(s) (IO*)sv_dup((SV*)s)
6152 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
6153 #define gv_dup(s) (GV*)sv_dup((SV*)s)
6154 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
6155 #define SAVEPV(p) (p ? savepv(p) : Nullch)
6156 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
6159 Perl_re_dup(pTHX_ REGEXP *r)
6161 /* XXX fix when pmop->op_pmregexp becomes shared */
6162 return ReREFCNT_inc(r);
6166 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
6170 return (PerlIO*)NULL;
6172 /* look for it in the table first */
6173 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
6177 /* create anew and remember what it is */
6178 ret = PerlIO_fdupopen(fp);
6179 ptr_table_store(PL_ptr_table, fp, ret);
6184 Perl_dirp_dup(pTHX_ DIR *dp)
6193 Perl_gp_dup(pTHX_ GP *gp)
6198 /* look for it in the table first */
6199 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
6203 /* create anew and remember what it is */
6204 Newz(0, ret, 1, GP);
6205 ptr_table_store(PL_ptr_table, gp, ret);
6208 ret->gp_refcnt = 0; /* must be before any other dups! */
6209 ret->gp_sv = sv_dup_inc(gp->gp_sv);
6210 ret->gp_io = io_dup_inc(gp->gp_io);
6211 ret->gp_form = cv_dup_inc(gp->gp_form);
6212 ret->gp_av = av_dup_inc(gp->gp_av);
6213 ret->gp_hv = hv_dup_inc(gp->gp_hv);
6214 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
6215 ret->gp_cv = cv_dup_inc(gp->gp_cv);
6216 ret->gp_cvgen = gp->gp_cvgen;
6217 ret->gp_flags = gp->gp_flags;
6218 ret->gp_line = gp->gp_line;
6219 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
6224 Perl_mg_dup(pTHX_ MAGIC *mg)
6226 MAGIC *mgret = (MAGIC*)NULL;
6229 return (MAGIC*)NULL;
6230 /* look for it in the table first */
6231 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
6235 for (; mg; mg = mg->mg_moremagic) {
6237 Newz(0, nmg, 1, MAGIC);
6241 mgprev->mg_moremagic = nmg;
6242 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
6243 nmg->mg_private = mg->mg_private;
6244 nmg->mg_type = mg->mg_type;
6245 nmg->mg_flags = mg->mg_flags;
6246 if (mg->mg_type == 'r') {
6247 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
6250 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
6251 ? sv_dup_inc(mg->mg_obj)
6252 : sv_dup(mg->mg_obj);
6254 nmg->mg_len = mg->mg_len;
6255 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
6256 if (mg->mg_ptr && mg->mg_type != 'g') {
6257 if (mg->mg_len >= 0) {
6258 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
6259 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
6260 AMT *amtp = (AMT*)mg->mg_ptr;
6261 AMT *namtp = (AMT*)nmg->mg_ptr;
6263 for (i = 1; i < NofAMmeth; i++) {
6264 namtp->table[i] = cv_dup_inc(amtp->table[i]);
6268 else if (mg->mg_len == HEf_SVKEY)
6269 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
6277 Perl_ptr_table_new(pTHX)
6280 Newz(0, tbl, 1, PTR_TBL_t);
6283 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
6288 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
6290 PTR_TBL_ENT_t *tblent;
6291 UV hash = PTR2UV(sv);
6293 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
6294 for (; tblent; tblent = tblent->next) {
6295 if (tblent->oldval == sv)
6296 return tblent->newval;
6302 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
6304 PTR_TBL_ENT_t *tblent, **otblent;
6305 /* XXX this may be pessimal on platforms where pointers aren't good
6306 * hash values e.g. if they grow faster in the most significant
6308 UV hash = PTR2UV(oldv);
6312 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
6313 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
6314 if (tblent->oldval == oldv) {
6315 tblent->newval = newv;
6320 Newz(0, tblent, 1, PTR_TBL_ENT_t);
6321 tblent->oldval = oldv;
6322 tblent->newval = newv;
6323 tblent->next = *otblent;
6326 if (i && tbl->tbl_items > tbl->tbl_max)
6327 ptr_table_split(tbl);
6331 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
6333 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
6334 UV oldsize = tbl->tbl_max + 1;
6335 UV newsize = oldsize * 2;
6338 Renew(ary, newsize, PTR_TBL_ENT_t*);
6339 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
6340 tbl->tbl_max = --newsize;
6342 for (i=0; i < oldsize; i++, ary++) {
6343 PTR_TBL_ENT_t **curentp, **entp, *ent;
6346 curentp = ary + oldsize;
6347 for (entp = ary, ent = *ary; ent; ent = *entp) {
6348 if ((newsize & PTR2UV(ent->oldval)) != i) {
6350 ent->next = *curentp;
6365 Perl_sv_dup(pTHX_ SV *sstr)
6372 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
6374 /* look for it in the table first */
6375 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
6379 /* create anew and remember what it is */
6381 ptr_table_store(PL_ptr_table, sstr, dstr);
6384 SvFLAGS(dstr) = SvFLAGS(sstr);
6385 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
6386 SvREFCNT(dstr) = 0; /* must be before any other dups! */
6389 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
6390 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
6391 PL_watch_pvx, SvPVX(sstr));
6394 switch (SvTYPE(sstr)) {
6399 SvANY(dstr) = new_XIV();
6400 SvIVX(dstr) = SvIVX(sstr);
6403 SvANY(dstr) = new_XNV();
6404 SvNVX(dstr) = SvNVX(sstr);
6407 SvANY(dstr) = new_XRV();
6408 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6411 SvANY(dstr) = new_XPV();
6412 SvCUR(dstr) = SvCUR(sstr);
6413 SvLEN(dstr) = SvLEN(sstr);
6415 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6416 else if (SvPVX(sstr) && SvLEN(sstr))
6417 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6419 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6422 SvANY(dstr) = new_XPVIV();
6423 SvCUR(dstr) = SvCUR(sstr);
6424 SvLEN(dstr) = SvLEN(sstr);
6425 SvIVX(dstr) = SvIVX(sstr);
6427 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6428 else if (SvPVX(sstr) && SvLEN(sstr))
6429 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6431 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6434 SvANY(dstr) = new_XPVNV();
6435 SvCUR(dstr) = SvCUR(sstr);
6436 SvLEN(dstr) = SvLEN(sstr);
6437 SvIVX(dstr) = SvIVX(sstr);
6438 SvNVX(dstr) = SvNVX(sstr);
6440 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6441 else if (SvPVX(sstr) && SvLEN(sstr))
6442 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6444 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6447 SvANY(dstr) = new_XPVMG();
6448 SvCUR(dstr) = SvCUR(sstr);
6449 SvLEN(dstr) = SvLEN(sstr);
6450 SvIVX(dstr) = SvIVX(sstr);
6451 SvNVX(dstr) = SvNVX(sstr);
6452 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6453 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6455 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6456 else if (SvPVX(sstr) && SvLEN(sstr))
6457 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6459 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6462 SvANY(dstr) = new_XPVBM();
6463 SvCUR(dstr) = SvCUR(sstr);
6464 SvLEN(dstr) = SvLEN(sstr);
6465 SvIVX(dstr) = SvIVX(sstr);
6466 SvNVX(dstr) = SvNVX(sstr);
6467 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6468 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6470 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6471 else if (SvPVX(sstr) && SvLEN(sstr))
6472 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6474 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6475 BmRARE(dstr) = BmRARE(sstr);
6476 BmUSEFUL(dstr) = BmUSEFUL(sstr);
6477 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
6480 SvANY(dstr) = new_XPVLV();
6481 SvCUR(dstr) = SvCUR(sstr);
6482 SvLEN(dstr) = SvLEN(sstr);
6483 SvIVX(dstr) = SvIVX(sstr);
6484 SvNVX(dstr) = SvNVX(sstr);
6485 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6486 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6488 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6489 else if (SvPVX(sstr) && SvLEN(sstr))
6490 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6492 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6493 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
6494 LvTARGLEN(dstr) = LvTARGLEN(sstr);
6495 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
6496 LvTYPE(dstr) = LvTYPE(sstr);
6499 SvANY(dstr) = new_XPVGV();
6500 SvCUR(dstr) = SvCUR(sstr);
6501 SvLEN(dstr) = SvLEN(sstr);
6502 SvIVX(dstr) = SvIVX(sstr);
6503 SvNVX(dstr) = SvNVX(sstr);
6504 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6505 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6507 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6508 else if (SvPVX(sstr) && SvLEN(sstr))
6509 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6511 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6512 GvNAMELEN(dstr) = GvNAMELEN(sstr);
6513 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
6514 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
6515 GvFLAGS(dstr) = GvFLAGS(sstr);
6516 GvGP(dstr) = gp_dup(GvGP(sstr));
6517 (void)GpREFCNT_inc(GvGP(dstr));
6520 SvANY(dstr) = new_XPVIO();
6521 SvCUR(dstr) = SvCUR(sstr);
6522 SvLEN(dstr) = SvLEN(sstr);
6523 SvIVX(dstr) = SvIVX(sstr);
6524 SvNVX(dstr) = SvNVX(sstr);
6525 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6526 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6528 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6529 else if (SvPVX(sstr) && SvLEN(sstr))
6530 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6532 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6533 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
6534 if (IoOFP(sstr) == IoIFP(sstr))
6535 IoOFP(dstr) = IoIFP(dstr);
6537 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
6538 /* PL_rsfp_filters entries have fake IoDIRP() */
6539 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
6540 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
6542 IoDIRP(dstr) = IoDIRP(sstr);
6543 IoLINES(dstr) = IoLINES(sstr);
6544 IoPAGE(dstr) = IoPAGE(sstr);
6545 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
6546 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
6547 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
6548 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
6549 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
6550 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
6551 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
6552 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
6553 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
6554 IoTYPE(dstr) = IoTYPE(sstr);
6555 IoFLAGS(dstr) = IoFLAGS(sstr);
6558 SvANY(dstr) = new_XPVAV();
6559 SvCUR(dstr) = SvCUR(sstr);
6560 SvLEN(dstr) = SvLEN(sstr);
6561 SvIVX(dstr) = SvIVX(sstr);
6562 SvNVX(dstr) = SvNVX(sstr);
6563 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6564 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6565 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
6566 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
6567 if (AvARRAY((AV*)sstr)) {
6568 SV **dst_ary, **src_ary;
6569 SSize_t items = AvFILLp((AV*)sstr) + 1;
6571 src_ary = AvARRAY((AV*)sstr);
6572 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
6573 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
6574 SvPVX(dstr) = (char*)dst_ary;
6575 AvALLOC((AV*)dstr) = dst_ary;
6576 if (AvREAL((AV*)sstr)) {
6578 *dst_ary++ = sv_dup_inc(*src_ary++);
6582 *dst_ary++ = sv_dup(*src_ary++);
6584 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
6585 while (items-- > 0) {
6586 *dst_ary++ = &PL_sv_undef;
6590 SvPVX(dstr) = Nullch;
6591 AvALLOC((AV*)dstr) = (SV**)NULL;
6595 SvANY(dstr) = new_XPVHV();
6596 SvCUR(dstr) = SvCUR(sstr);
6597 SvLEN(dstr) = SvLEN(sstr);
6598 SvIVX(dstr) = SvIVX(sstr);
6599 SvNVX(dstr) = SvNVX(sstr);
6600 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6601 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6602 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
6603 if (HvARRAY((HV*)sstr)) {
6606 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
6607 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
6608 Newz(0, dxhv->xhv_array,
6609 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
6610 while (i <= sxhv->xhv_max) {
6611 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
6612 !!HvSHAREKEYS(sstr));
6615 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
6618 SvPVX(dstr) = Nullch;
6619 HvEITER((HV*)dstr) = (HE*)NULL;
6621 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
6622 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
6625 SvANY(dstr) = new_XPVFM();
6626 FmLINES(dstr) = FmLINES(sstr);
6630 SvANY(dstr) = new_XPVCV();
6632 SvCUR(dstr) = SvCUR(sstr);
6633 SvLEN(dstr) = SvLEN(sstr);
6634 SvIVX(dstr) = SvIVX(sstr);
6635 SvNVX(dstr) = SvNVX(sstr);
6636 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6637 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6638 if (SvPVX(sstr) && SvLEN(sstr))
6639 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6641 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6642 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
6643 CvSTART(dstr) = CvSTART(sstr);
6644 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
6645 CvXSUB(dstr) = CvXSUB(sstr);
6646 CvXSUBANY(dstr) = CvXSUBANY(sstr);
6647 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
6648 CvDEPTH(dstr) = CvDEPTH(sstr);
6649 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
6650 /* XXX padlists are real, but pretend to be not */
6651 AvREAL_on(CvPADLIST(sstr));
6652 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
6653 AvREAL_off(CvPADLIST(sstr));
6654 AvREAL_off(CvPADLIST(dstr));
6657 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
6658 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
6659 CvFLAGS(dstr) = CvFLAGS(sstr);
6662 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
6666 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
6673 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
6678 return (PERL_CONTEXT*)NULL;
6680 /* look for it in the table first */
6681 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
6685 /* create anew and remember what it is */
6686 Newz(56, ncxs, max + 1, PERL_CONTEXT);
6687 ptr_table_store(PL_ptr_table, cxs, ncxs);
6690 PERL_CONTEXT *cx = &cxs[ix];
6691 PERL_CONTEXT *ncx = &ncxs[ix];
6692 ncx->cx_type = cx->cx_type;
6693 if (CxTYPE(cx) == CXt_SUBST) {
6694 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
6697 ncx->blk_oldsp = cx->blk_oldsp;
6698 ncx->blk_oldcop = cx->blk_oldcop;
6699 ncx->blk_oldretsp = cx->blk_oldretsp;
6700 ncx->blk_oldmarksp = cx->blk_oldmarksp;
6701 ncx->blk_oldscopesp = cx->blk_oldscopesp;
6702 ncx->blk_oldpm = cx->blk_oldpm;
6703 ncx->blk_gimme = cx->blk_gimme;
6704 switch (CxTYPE(cx)) {
6706 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
6707 ? cv_dup_inc(cx->blk_sub.cv)
6708 : cv_dup(cx->blk_sub.cv));
6709 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
6710 ? av_dup_inc(cx->blk_sub.argarray)
6712 ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
6713 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
6714 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
6715 ncx->blk_sub.lval = cx->blk_sub.lval;
6718 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
6719 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
6720 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
6721 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
6722 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
6725 ncx->blk_loop.label = cx->blk_loop.label;
6726 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
6727 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
6728 ncx->blk_loop.next_op = cx->blk_loop.next_op;
6729 ncx->blk_loop.last_op = cx->blk_loop.last_op;
6730 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
6731 ? cx->blk_loop.iterdata
6732 : gv_dup((GV*)cx->blk_loop.iterdata));
6733 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
6734 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
6735 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
6736 ncx->blk_loop.iterix = cx->blk_loop.iterix;
6737 ncx->blk_loop.itermax = cx->blk_loop.itermax;
6740 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
6741 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
6742 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
6743 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
6756 Perl_si_dup(pTHX_ PERL_SI *si)
6761 return (PERL_SI*)NULL;
6763 /* look for it in the table first */
6764 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
6768 /* create anew and remember what it is */
6769 Newz(56, nsi, 1, PERL_SI);
6770 ptr_table_store(PL_ptr_table, si, nsi);
6772 nsi->si_stack = av_dup_inc(si->si_stack);
6773 nsi->si_cxix = si->si_cxix;
6774 nsi->si_cxmax = si->si_cxmax;
6775 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
6776 nsi->si_type = si->si_type;
6777 nsi->si_prev = si_dup(si->si_prev);
6778 nsi->si_next = si_dup(si->si_next);
6779 nsi->si_markoff = si->si_markoff;
6784 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
6785 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
6786 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
6787 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
6788 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
6789 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
6790 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
6791 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
6792 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
6793 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
6794 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
6795 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
6798 #define pv_dup_inc(p) SAVEPV(p)
6799 #define pv_dup(p) SAVEPV(p)
6800 #define svp_dup_inc(p,pp) any_dup(p,pp)
6803 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
6810 /* look for it in the table first */
6811 ret = ptr_table_fetch(PL_ptr_table, v);
6815 /* see if it is part of the interpreter structure */
6816 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
6817 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
6825 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
6827 ANY *ss = proto_perl->Tsavestack;
6828 I32 ix = proto_perl->Tsavestack_ix;
6829 I32 max = proto_perl->Tsavestack_max;
6842 void (*dptr) (void*);
6843 void (*dxptr) (pTHXo_ void*);
6845 Newz(54, nss, max, ANY);
6851 case SAVEt_ITEM: /* normal string */
6852 sv = (SV*)POPPTR(ss,ix);
6853 TOPPTR(nss,ix) = sv_dup_inc(sv);
6854 sv = (SV*)POPPTR(ss,ix);
6855 TOPPTR(nss,ix) = sv_dup_inc(sv);
6857 case SAVEt_SV: /* scalar reference */
6858 sv = (SV*)POPPTR(ss,ix);
6859 TOPPTR(nss,ix) = sv_dup_inc(sv);
6860 gv = (GV*)POPPTR(ss,ix);
6861 TOPPTR(nss,ix) = gv_dup_inc(gv);
6863 case SAVEt_GENERIC_SVREF: /* generic sv */
6864 case SAVEt_SVREF: /* scalar reference */
6865 sv = (SV*)POPPTR(ss,ix);
6866 TOPPTR(nss,ix) = sv_dup_inc(sv);
6867 ptr = POPPTR(ss,ix);
6868 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
6870 case SAVEt_AV: /* array reference */
6871 av = (AV*)POPPTR(ss,ix);
6872 TOPPTR(nss,ix) = av_dup_inc(av);
6873 gv = (GV*)POPPTR(ss,ix);
6874 TOPPTR(nss,ix) = gv_dup(gv);
6876 case SAVEt_HV: /* hash reference */
6877 hv = (HV*)POPPTR(ss,ix);
6878 TOPPTR(nss,ix) = hv_dup_inc(hv);
6879 gv = (GV*)POPPTR(ss,ix);
6880 TOPPTR(nss,ix) = gv_dup(gv);
6882 case SAVEt_INT: /* int reference */
6883 ptr = POPPTR(ss,ix);
6884 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6885 intval = (int)POPINT(ss,ix);
6886 TOPINT(nss,ix) = intval;
6888 case SAVEt_LONG: /* long reference */
6889 ptr = POPPTR(ss,ix);
6890 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6891 longval = (long)POPLONG(ss,ix);
6892 TOPLONG(nss,ix) = longval;
6894 case SAVEt_I32: /* I32 reference */
6895 case SAVEt_I16: /* I16 reference */
6896 case SAVEt_I8: /* I8 reference */
6897 ptr = POPPTR(ss,ix);
6898 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6902 case SAVEt_IV: /* IV reference */
6903 ptr = POPPTR(ss,ix);
6904 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6908 case SAVEt_SPTR: /* SV* reference */
6909 ptr = POPPTR(ss,ix);
6910 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6911 sv = (SV*)POPPTR(ss,ix);
6912 TOPPTR(nss,ix) = sv_dup(sv);
6914 case SAVEt_VPTR: /* random* reference */
6915 ptr = POPPTR(ss,ix);
6916 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6917 ptr = POPPTR(ss,ix);
6918 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6920 case SAVEt_PPTR: /* char* reference */
6921 ptr = POPPTR(ss,ix);
6922 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6923 c = (char*)POPPTR(ss,ix);
6924 TOPPTR(nss,ix) = pv_dup(c);
6926 case SAVEt_HPTR: /* HV* reference */
6927 ptr = POPPTR(ss,ix);
6928 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6929 hv = (HV*)POPPTR(ss,ix);
6930 TOPPTR(nss,ix) = hv_dup(hv);
6932 case SAVEt_APTR: /* AV* reference */
6933 ptr = POPPTR(ss,ix);
6934 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6935 av = (AV*)POPPTR(ss,ix);
6936 TOPPTR(nss,ix) = av_dup(av);
6939 gv = (GV*)POPPTR(ss,ix);
6940 TOPPTR(nss,ix) = gv_dup(gv);
6942 case SAVEt_GP: /* scalar reference */
6943 gp = (GP*)POPPTR(ss,ix);
6944 TOPPTR(nss,ix) = gp = gp_dup(gp);
6945 (void)GpREFCNT_inc(gp);
6946 gv = (GV*)POPPTR(ss,ix);
6947 TOPPTR(nss,ix) = gv_dup_inc(c);
6948 c = (char*)POPPTR(ss,ix);
6949 TOPPTR(nss,ix) = pv_dup(c);
6956 sv = (SV*)POPPTR(ss,ix);
6957 TOPPTR(nss,ix) = sv_dup_inc(sv);
6960 ptr = POPPTR(ss,ix);
6961 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
6962 /* these are assumed to be refcounted properly */
6963 switch (((OP*)ptr)->op_type) {
6970 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6973 TOPPTR(nss,ix) = Nullop;
6978 TOPPTR(nss,ix) = Nullop;
6981 c = (char*)POPPTR(ss,ix);
6982 TOPPTR(nss,ix) = pv_dup_inc(c);
6985 longval = POPLONG(ss,ix);
6986 TOPLONG(nss,ix) = longval;
6989 hv = (HV*)POPPTR(ss,ix);
6990 TOPPTR(nss,ix) = hv_dup_inc(hv);
6991 c = (char*)POPPTR(ss,ix);
6992 TOPPTR(nss,ix) = pv_dup_inc(c);
6996 case SAVEt_DESTRUCTOR:
6997 ptr = POPPTR(ss,ix);
6998 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
6999 dptr = POPDPTR(ss,ix);
7000 TOPDPTR(nss,ix) = (void (*)(void*))any_dup(dptr, proto_perl);
7002 case SAVEt_DESTRUCTOR_X:
7003 ptr = POPPTR(ss,ix);
7004 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7005 dxptr = POPDXPTR(ss,ix);
7006 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup(dxptr, proto_perl);
7008 case SAVEt_REGCONTEXT:
7014 case SAVEt_STACK_POS: /* Position on Perl stack */
7018 case SAVEt_AELEM: /* array element */
7019 sv = (SV*)POPPTR(ss,ix);
7020 TOPPTR(nss,ix) = sv_dup_inc(sv);
7023 av = (AV*)POPPTR(ss,ix);
7024 TOPPTR(nss,ix) = av_dup_inc(av);
7026 case SAVEt_HELEM: /* hash element */
7027 sv = (SV*)POPPTR(ss,ix);
7028 TOPPTR(nss,ix) = sv_dup_inc(sv);
7029 sv = (SV*)POPPTR(ss,ix);
7030 TOPPTR(nss,ix) = sv_dup_inc(sv);
7031 hv = (HV*)POPPTR(ss,ix);
7032 TOPPTR(nss,ix) = hv_dup_inc(hv);
7035 ptr = POPPTR(ss,ix);
7036 TOPPTR(nss,ix) = ptr;
7043 av = (AV*)POPPTR(ss,ix);
7044 TOPPTR(nss,ix) = av_dup(av);
7047 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
7059 perl_clone(PerlInterpreter *proto_perl, UV flags)
7062 CPerlObj *pPerl = (CPerlObj*)proto_perl;
7065 #ifdef PERL_IMPLICIT_SYS
7066 return perl_clone_using(proto_perl, flags,
7068 proto_perl->IMemShared,
7069 proto_perl->IMemParse,
7079 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
7080 struct IPerlMem* ipM, struct IPerlMem* ipMS,
7081 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
7082 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
7083 struct IPerlDir* ipD, struct IPerlSock* ipS,
7084 struct IPerlProc* ipP)
7086 /* XXX many of the string copies here can be optimized if they're
7087 * constants; they need to be allocated as common memory and just
7088 * their pointers copied. */
7094 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
7096 PERL_SET_INTERP(pPerl);
7097 # else /* !PERL_OBJECT */
7098 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
7099 PERL_SET_INTERP(my_perl);
7102 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7107 # else /* !DEBUGGING */
7108 Zero(my_perl, 1, PerlInterpreter);
7109 # endif /* DEBUGGING */
7113 PL_MemShared = ipMS;
7121 # endif /* PERL_OBJECT */
7122 #else /* !PERL_IMPLICIT_SYS */
7126 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
7127 PERL_SET_INTERP(my_perl);
7130 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7135 # else /* !DEBUGGING */
7136 Zero(my_perl, 1, PerlInterpreter);
7137 # endif /* DEBUGGING */
7138 #endif /* PERL_IMPLICIT_SYS */
7141 PL_xiv_arenaroot = NULL;
7146 PL_xpviv_root = NULL;
7147 PL_xpvnv_root = NULL;
7148 PL_xpvcv_root = NULL;
7149 PL_xpvav_root = NULL;
7150 PL_xpvhv_root = NULL;
7151 PL_xpvmg_root = NULL;
7152 PL_xpvlv_root = NULL;
7153 PL_xpvbm_root = NULL;
7155 PL_nice_chunk = NULL;
7156 PL_nice_chunk_size = 0;
7159 PL_sv_root = Nullsv;
7160 PL_sv_arenaroot = Nullsv;
7162 PL_debug = proto_perl->Idebug;
7164 /* create SV map for pointer relocation */
7165 PL_ptr_table = ptr_table_new();
7167 /* initialize these special pointers as early as possible */
7168 SvANY(&PL_sv_undef) = NULL;
7169 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
7170 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
7171 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
7174 SvUPGRADE(&PL_sv_no, SVt_PVNV);
7176 SvANY(&PL_sv_no) = new_XPVNV();
7178 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
7179 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7180 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
7181 SvCUR(&PL_sv_no) = 0;
7182 SvLEN(&PL_sv_no) = 1;
7183 SvNVX(&PL_sv_no) = 0;
7184 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
7187 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
7189 SvANY(&PL_sv_yes) = new_XPVNV();
7191 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
7192 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7193 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
7194 SvCUR(&PL_sv_yes) = 1;
7195 SvLEN(&PL_sv_yes) = 2;
7196 SvNVX(&PL_sv_yes) = 1;
7197 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
7199 /* create shared string table */
7200 PL_strtab = newHV();
7201 HvSHAREKEYS_off(PL_strtab);
7202 hv_ksplit(PL_strtab, 512);
7203 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
7205 PL_compiling = proto_perl->Icompiling;
7206 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
7207 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
7208 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
7209 if (!specialWARN(PL_compiling.cop_warnings))
7210 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
7211 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
7213 /* pseudo environmental stuff */
7214 PL_origargc = proto_perl->Iorigargc;
7216 New(0, PL_origargv, i+1, char*);
7217 PL_origargv[i] = '\0';
7219 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
7221 PL_envgv = gv_dup(proto_perl->Ienvgv);
7222 PL_incgv = gv_dup(proto_perl->Iincgv);
7223 PL_hintgv = gv_dup(proto_perl->Ihintgv);
7224 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
7225 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
7226 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
7229 PL_minus_c = proto_perl->Iminus_c;
7230 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
7231 PL_localpatches = proto_perl->Ilocalpatches;
7232 PL_splitstr = proto_perl->Isplitstr;
7233 PL_preprocess = proto_perl->Ipreprocess;
7234 PL_minus_n = proto_perl->Iminus_n;
7235 PL_minus_p = proto_perl->Iminus_p;
7236 PL_minus_l = proto_perl->Iminus_l;
7237 PL_minus_a = proto_perl->Iminus_a;
7238 PL_minus_F = proto_perl->Iminus_F;
7239 PL_doswitches = proto_perl->Idoswitches;
7240 PL_dowarn = proto_perl->Idowarn;
7241 PL_doextract = proto_perl->Idoextract;
7242 PL_sawampersand = proto_perl->Isawampersand;
7243 PL_unsafe = proto_perl->Iunsafe;
7244 PL_inplace = SAVEPV(proto_perl->Iinplace);
7245 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
7246 PL_perldb = proto_perl->Iperldb;
7247 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
7249 /* magical thingies */
7250 /* XXX time(&PL_basetime) when asked for? */
7251 PL_basetime = proto_perl->Ibasetime;
7252 PL_formfeed = sv_dup(proto_perl->Iformfeed);
7254 PL_maxsysfd = proto_perl->Imaxsysfd;
7255 PL_multiline = proto_perl->Imultiline;
7256 PL_statusvalue = proto_perl->Istatusvalue;
7258 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
7261 /* shortcuts to various I/O objects */
7262 PL_stdingv = gv_dup(proto_perl->Istdingv);
7263 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
7264 PL_defgv = gv_dup(proto_perl->Idefgv);
7265 PL_argvgv = gv_dup(proto_perl->Iargvgv);
7266 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
7267 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
7269 /* shortcuts to regexp stuff */
7270 PL_replgv = gv_dup(proto_perl->Ireplgv);
7272 /* shortcuts to misc objects */
7273 PL_errgv = gv_dup(proto_perl->Ierrgv);
7275 /* shortcuts to debugging objects */
7276 PL_DBgv = gv_dup(proto_perl->IDBgv);
7277 PL_DBline = gv_dup(proto_perl->IDBline);
7278 PL_DBsub = gv_dup(proto_perl->IDBsub);
7279 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
7280 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
7281 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
7282 PL_lineary = av_dup(proto_perl->Ilineary);
7283 PL_dbargs = av_dup(proto_perl->Idbargs);
7286 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
7287 PL_curstash = hv_dup(proto_perl->Tcurstash);
7288 PL_debstash = hv_dup(proto_perl->Idebstash);
7289 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
7290 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
7292 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
7293 PL_endav = av_dup_inc(proto_perl->Iendav);
7294 PL_checkav = av_dup_inc(proto_perl->Icheckav);
7295 PL_initav = av_dup_inc(proto_perl->Iinitav);
7297 PL_sub_generation = proto_perl->Isub_generation;
7299 /* funky return mechanisms */
7300 PL_forkprocess = proto_perl->Iforkprocess;
7302 /* subprocess state */
7303 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
7305 /* internal state */
7306 PL_tainting = proto_perl->Itainting;
7307 PL_maxo = proto_perl->Imaxo;
7308 if (proto_perl->Iop_mask)
7309 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
7311 PL_op_mask = Nullch;
7313 /* current interpreter roots */
7314 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
7315 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
7316 PL_main_start = proto_perl->Imain_start;
7317 PL_eval_root = OpREFCNT_inc(proto_perl->Ieval_root);
7318 PL_eval_start = proto_perl->Ieval_start;
7320 /* runtime control stuff */
7321 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
7322 PL_copline = proto_perl->Icopline;
7324 PL_filemode = proto_perl->Ifilemode;
7325 PL_lastfd = proto_perl->Ilastfd;
7326 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
7329 PL_gensym = proto_perl->Igensym;
7330 PL_preambled = proto_perl->Ipreambled;
7331 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
7332 PL_laststatval = proto_perl->Ilaststatval;
7333 PL_laststype = proto_perl->Ilaststype;
7334 PL_mess_sv = Nullsv;
7336 PL_orslen = proto_perl->Iorslen;
7337 PL_ors = SAVEPVN(proto_perl->Iors, PL_orslen);
7338 PL_ofmt = SAVEPV(proto_perl->Iofmt);
7340 /* interpreter atexit processing */
7341 PL_exitlistlen = proto_perl->Iexitlistlen;
7342 if (PL_exitlistlen) {
7343 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7344 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7347 PL_exitlist = (PerlExitListEntry*)NULL;
7348 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
7350 PL_profiledata = NULL;
7351 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
7352 /* PL_rsfp_filters entries have fake IoDIRP() */
7353 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
7355 PL_compcv = cv_dup(proto_perl->Icompcv);
7356 PL_comppad = av_dup(proto_perl->Icomppad);
7357 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
7358 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
7359 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
7360 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
7361 proto_perl->Tcurpad);
7363 #ifdef HAVE_INTERP_INTERN
7364 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
7367 /* more statics moved here */
7368 PL_generation = proto_perl->Igeneration;
7369 PL_DBcv = cv_dup(proto_perl->IDBcv);
7371 PL_in_clean_objs = proto_perl->Iin_clean_objs;
7372 PL_in_clean_all = proto_perl->Iin_clean_all;
7374 PL_uid = proto_perl->Iuid;
7375 PL_euid = proto_perl->Ieuid;
7376 PL_gid = proto_perl->Igid;
7377 PL_egid = proto_perl->Iegid;
7378 PL_nomemok = proto_perl->Inomemok;
7379 PL_an = proto_perl->Ian;
7380 PL_cop_seqmax = proto_perl->Icop_seqmax;
7381 PL_op_seqmax = proto_perl->Iop_seqmax;
7382 PL_evalseq = proto_perl->Ievalseq;
7383 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
7384 PL_origalen = proto_perl->Iorigalen;
7385 PL_pidstatus = newHV(); /* XXX flag for cloning? */
7386 PL_osname = SAVEPV(proto_perl->Iosname);
7387 PL_sh_path = SAVEPV(proto_perl->Ish_path);
7388 PL_sighandlerp = proto_perl->Isighandlerp;
7391 PL_runops = proto_perl->Irunops;
7393 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
7396 PL_cshlen = proto_perl->Icshlen;
7397 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
7400 PL_lex_state = proto_perl->Ilex_state;
7401 PL_lex_defer = proto_perl->Ilex_defer;
7402 PL_lex_expect = proto_perl->Ilex_expect;
7403 PL_lex_formbrack = proto_perl->Ilex_formbrack;
7404 PL_lex_dojoin = proto_perl->Ilex_dojoin;
7405 PL_lex_starts = proto_perl->Ilex_starts;
7406 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
7407 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
7408 PL_lex_op = proto_perl->Ilex_op;
7409 PL_lex_inpat = proto_perl->Ilex_inpat;
7410 PL_lex_inwhat = proto_perl->Ilex_inwhat;
7411 PL_lex_brackets = proto_perl->Ilex_brackets;
7412 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
7413 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
7414 PL_lex_casemods = proto_perl->Ilex_casemods;
7415 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
7416 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
7418 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
7419 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
7420 PL_nexttoke = proto_perl->Inexttoke;
7422 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
7423 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
7424 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7425 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
7426 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7427 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
7428 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7429 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7430 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
7431 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7432 PL_pending_ident = proto_perl->Ipending_ident;
7433 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
7435 PL_expect = proto_perl->Iexpect;
7437 PL_multi_start = proto_perl->Imulti_start;
7438 PL_multi_end = proto_perl->Imulti_end;
7439 PL_multi_open = proto_perl->Imulti_open;
7440 PL_multi_close = proto_perl->Imulti_close;
7442 PL_error_count = proto_perl->Ierror_count;
7443 PL_subline = proto_perl->Isubline;
7444 PL_subname = sv_dup_inc(proto_perl->Isubname);
7446 PL_min_intro_pending = proto_perl->Imin_intro_pending;
7447 PL_max_intro_pending = proto_perl->Imax_intro_pending;
7448 PL_padix = proto_perl->Ipadix;
7449 PL_padix_floor = proto_perl->Ipadix_floor;
7450 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
7452 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
7453 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7454 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
7455 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7456 PL_last_lop_op = proto_perl->Ilast_lop_op;
7457 PL_in_my = proto_perl->Iin_my;
7458 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
7460 PL_cryptseen = proto_perl->Icryptseen;
7463 PL_hints = proto_perl->Ihints;
7465 PL_amagic_generation = proto_perl->Iamagic_generation;
7467 #ifdef USE_LOCALE_COLLATE
7468 PL_collation_ix = proto_perl->Icollation_ix;
7469 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
7470 PL_collation_standard = proto_perl->Icollation_standard;
7471 PL_collxfrm_base = proto_perl->Icollxfrm_base;
7472 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
7473 #endif /* USE_LOCALE_COLLATE */
7475 #ifdef USE_LOCALE_NUMERIC
7476 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
7477 PL_numeric_standard = proto_perl->Inumeric_standard;
7478 PL_numeric_local = proto_perl->Inumeric_local;
7479 PL_numeric_radix = proto_perl->Inumeric_radix;
7480 #endif /* !USE_LOCALE_NUMERIC */
7482 /* utf8 character classes */
7483 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
7484 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
7485 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
7486 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
7487 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
7488 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
7489 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
7490 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
7491 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
7492 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
7493 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
7494 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
7495 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
7496 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
7497 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
7498 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
7499 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
7502 PL_last_swash_hv = Nullhv; /* reinits on demand */
7503 PL_last_swash_klen = 0;
7504 PL_last_swash_key[0]= '\0';
7505 PL_last_swash_tmps = (U8*)NULL;
7506 PL_last_swash_slen = 0;
7508 /* perly.c globals */
7509 PL_yydebug = proto_perl->Iyydebug;
7510 PL_yynerrs = proto_perl->Iyynerrs;
7511 PL_yyerrflag = proto_perl->Iyyerrflag;
7512 PL_yychar = proto_perl->Iyychar;
7513 PL_yyval = proto_perl->Iyyval;
7514 PL_yylval = proto_perl->Iyylval;
7516 PL_glob_index = proto_perl->Iglob_index;
7517 PL_srand_called = proto_perl->Isrand_called;
7518 PL_uudmap['M'] = 0; /* reinits on demand */
7519 PL_bitcount = Nullch; /* reinits on demand */
7521 if (proto_perl->Ipsig_ptr) {
7522 int sig_num[] = { SIG_NUM };
7523 Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
7524 Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
7525 for (i = 1; PL_sig_name[i]; i++) {
7526 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
7527 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
7531 PL_psig_ptr = (SV**)NULL;
7532 PL_psig_name = (SV**)NULL;
7535 /* thrdvar.h stuff */
7538 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
7539 PL_tmps_ix = proto_perl->Ttmps_ix;
7540 PL_tmps_max = proto_perl->Ttmps_max;
7541 PL_tmps_floor = proto_perl->Ttmps_floor;
7542 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
7544 while (i <= PL_tmps_ix) {
7545 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
7549 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
7550 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
7551 Newz(54, PL_markstack, i, I32);
7552 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
7553 - proto_perl->Tmarkstack);
7554 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
7555 - proto_perl->Tmarkstack);
7556 Copy(proto_perl->Tmarkstack, PL_markstack,
7557 PL_markstack_ptr - PL_markstack + 1, I32);
7559 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
7560 * NOTE: unlike the others! */
7561 PL_scopestack_ix = proto_perl->Tscopestack_ix;
7562 PL_scopestack_max = proto_perl->Tscopestack_max;
7563 Newz(54, PL_scopestack, PL_scopestack_max, I32);
7564 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
7566 /* next push_return() sets PL_retstack[PL_retstack_ix]
7567 * NOTE: unlike the others! */
7568 PL_retstack_ix = proto_perl->Tretstack_ix;
7569 PL_retstack_max = proto_perl->Tretstack_max;
7570 Newz(54, PL_retstack, PL_retstack_max, OP*);
7571 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
7573 /* NOTE: si_dup() looks at PL_markstack */
7574 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
7576 /* PL_curstack = PL_curstackinfo->si_stack; */
7577 PL_curstack = av_dup(proto_perl->Tcurstack);
7578 PL_mainstack = av_dup(proto_perl->Tmainstack);
7580 /* next PUSHs() etc. set *(PL_stack_sp+1) */
7581 PL_stack_base = AvARRAY(PL_curstack);
7582 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
7583 - proto_perl->Tstack_base);
7584 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
7586 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
7587 * NOTE: unlike the others! */
7588 PL_savestack_ix = proto_perl->Tsavestack_ix;
7589 PL_savestack_max = proto_perl->Tsavestack_max;
7590 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
7591 PL_savestack = ss_dup(proto_perl);
7597 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
7598 PL_top_env = &PL_start_env;
7600 PL_op = proto_perl->Top;
7603 PL_Xpv = (XPV*)NULL;
7604 PL_na = proto_perl->Tna;
7606 PL_statbuf = proto_perl->Tstatbuf;
7607 PL_statcache = proto_perl->Tstatcache;
7608 PL_statgv = gv_dup(proto_perl->Tstatgv);
7609 PL_statname = sv_dup_inc(proto_perl->Tstatname);
7611 PL_timesbuf = proto_perl->Ttimesbuf;
7614 PL_tainted = proto_perl->Ttainted;
7615 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
7616 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
7617 PL_rs = sv_dup_inc(proto_perl->Trs);
7618 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
7619 PL_ofslen = proto_perl->Tofslen;
7620 PL_ofs = SAVEPVN(proto_perl->Tofs, PL_ofslen);
7621 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
7622 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
7623 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
7624 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
7625 PL_formtarget = sv_dup(proto_perl->Tformtarget);
7627 PL_restartop = proto_perl->Trestartop;
7628 PL_in_eval = proto_perl->Tin_eval;
7629 PL_delaymagic = proto_perl->Tdelaymagic;
7630 PL_dirty = proto_perl->Tdirty;
7631 PL_localizing = proto_perl->Tlocalizing;
7633 PL_protect = proto_perl->Tprotect;
7634 PL_errors = sv_dup_inc(proto_perl->Terrors);
7635 PL_av_fetch_sv = Nullsv;
7636 PL_hv_fetch_sv = Nullsv;
7637 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
7638 PL_modcount = proto_perl->Tmodcount;
7639 PL_lastgotoprobe = Nullop;
7640 PL_dumpindent = proto_perl->Tdumpindent;
7642 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
7643 PL_sortstash = hv_dup(proto_perl->Tsortstash);
7644 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
7645 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
7646 PL_sortcxix = proto_perl->Tsortcxix;
7647 PL_efloatbuf = Nullch; /* reinits on demand */
7648 PL_efloatsize = 0; /* reinits on demand */
7652 PL_screamfirst = NULL;
7653 PL_screamnext = NULL;
7654 PL_maxscream = -1; /* reinits on demand */
7655 PL_lastscream = Nullsv;
7657 PL_watchaddr = NULL;
7658 PL_watchok = Nullch;
7660 PL_regdummy = proto_perl->Tregdummy;
7661 PL_regcomp_parse = Nullch;
7662 PL_regxend = Nullch;
7663 PL_regcode = (regnode*)NULL;
7666 PL_regprecomp = Nullch;
7671 PL_seen_zerolen = 0;
7673 PL_regcomp_rx = (regexp*)NULL;
7675 PL_colorset = 0; /* reinits PL_colors[] */
7676 /*PL_colors[6] = {0,0,0,0,0,0};*/
7677 PL_reg_whilem_seen = 0;
7678 PL_reginput = Nullch;
7681 PL_regstartp = (I32*)NULL;
7682 PL_regendp = (I32*)NULL;
7683 PL_reglastparen = (U32*)NULL;
7684 PL_regtill = Nullch;
7686 PL_reg_start_tmp = (char**)NULL;
7687 PL_reg_start_tmpl = 0;
7688 PL_regdata = (struct reg_data*)NULL;
7691 PL_reg_eval_set = 0;
7693 PL_regprogram = (regnode*)NULL;
7695 PL_regcc = (CURCUR*)NULL;
7696 PL_reg_call_cc = (struct re_cc_state*)NULL;
7697 PL_reg_re = (regexp*)NULL;
7698 PL_reg_ganch = Nullch;
7700 PL_reg_magic = (MAGIC*)NULL;
7702 PL_reg_oldcurpm = (PMOP*)NULL;
7703 PL_reg_curpm = (PMOP*)NULL;
7704 PL_reg_oldsaved = Nullch;
7705 PL_reg_oldsavedlen = 0;
7707 PL_reg_leftiter = 0;
7708 PL_reg_poscache = Nullch;
7709 PL_reg_poscache_size= 0;
7711 /* RE engine - function pointers */
7712 PL_regcompp = proto_perl->Tregcompp;
7713 PL_regexecp = proto_perl->Tregexecp;
7714 PL_regint_start = proto_perl->Tregint_start;
7715 PL_regint_string = proto_perl->Tregint_string;
7716 PL_regfree = proto_perl->Tregfree;
7718 PL_reginterp_cnt = 0;
7719 PL_reg_starttry = 0;
7722 return (PerlInterpreter*)pPerl;
7728 #else /* !USE_ITHREADS */
7734 #endif /* USE_ITHREADS */
7737 do_report_used(pTHXo_ SV *sv)
7739 if (SvTYPE(sv) != SVTYPEMASK) {
7740 PerlIO_printf(Perl_debug_log, "****\n");
7746 do_clean_objs(pTHXo_ SV *sv)
7750 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
7751 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
7757 /* XXX Might want to check arrays, etc. */
7760 #ifndef DISABLE_DESTRUCTOR_KLUDGE
7762 do_clean_named_objs(pTHXo_ SV *sv)
7764 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
7765 if ( SvOBJECT(GvSV(sv)) ||
7766 GvAV(sv) && SvOBJECT(GvAV(sv)) ||
7767 GvHV(sv) && SvOBJECT(GvHV(sv)) ||
7768 GvIO(sv) && SvOBJECT(GvIO(sv)) ||
7769 GvCV(sv) && SvOBJECT(GvCV(sv)) )
7771 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
7779 do_clean_all(pTHXo_ SV *sv)
7781 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
7782 SvFLAGS(sv) |= SVf_BREAK;