This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Do not assume sign propagation.
[perl5.git] / sv.c
CommitLineData
a0d0e21e 1/* sv.c
79072805 2 *
3818b22b 3 * Copyright (c) 1991-2000, Larry Wall
79072805
LW		 4 *
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.
7 *
a0d0e21e
LW		 8 */
9
10/*
11 * "I wonder what the Entish is for 'yes' and 'no'," he thought.
79072805
LW		 12 */
13
14#include "EXTERN.h"
864dbfa3 15#define PERL_IN_SV_C
79072805 16#include "perl.h"
79072805 17
51371543 18#define FCALL *f
6fc92669 19#define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
2c5424a7 20
51371543
GS		 21static void do_report_used(pTHXo_ SV *sv);
22static void do_clean_objs(pTHXo_ SV *sv);
23#ifndef DISABLE_DESTRUCTOR_KLUDGE
24static void do_clean_named_objs(pTHXo_ SV *sv);
25#endif
26static void do_clean_all(pTHXo_ SV *sv);
27
4561caa4
CS		 28/*
29 * "A time to plant, and a time to uproot what was planted..."
30 */
31
053fc874
GS		 32#define plant_SV(p) \
33 STMT_START { \
34 SvANY(p) = (void *)PL_sv_root; \
35 SvFLAGS(p) = SVTYPEMASK; \
36 PL_sv_root = (p); \
37 --PL_sv_count; \
38 } STMT_END
a0d0e21e 39
fba3b22e 40/* sv_mutex must be held while calling uproot_SV() */
053fc874
GS		 41#define uproot_SV(p) \
42 STMT_START { \
43 (p) = PL_sv_root; \
44 PL_sv_root = (SV*)SvANY(p); \
45 ++PL_sv_count; \
46 } STMT_END
47
48#define new_SV(p) \
49 STMT_START { \
50 LOCK_SV_MUTEX; \
51 if (PL_sv_root) \
52 uproot_SV(p); \
53 else \
54 (p) = more_sv(); \
55 UNLOCK_SV_MUTEX; \
56 SvANY(p) = 0; \
57 SvREFCNT(p) = 1; \
58 SvFLAGS(p) = 0; \
59 } STMT_END
463ee0b2 60
a0d0e21e 61#ifdef DEBUGGING
4561caa4 62
053fc874
GS		 63#define del_SV(p) \
64 STMT_START { \
65 LOCK_SV_MUTEX; \
66 if (PL_debug & 32768) \
67 del_sv(p); \
68 else \
69 plant_SV(p); \
70 UNLOCK_SV_MUTEX; \
71 } STMT_END
a0d0e21e 72
76e3520e 73STATIC void
cea2e8a9 74S_del_sv(pTHX_ SV *p)
463ee0b2 75{
3280af22 76 if (PL_debug & 32768) {
4633a7c4 77 SV* sva;
a0d0e21e
LW		 78 SV* sv;
79 SV* svend;
80 int ok = 0;
3280af22 81 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
4633a7c4
LW		 82 sv = sva + 1;
83 svend = &sva[SvREFCNT(sva)];
a0d0e21e
LW		 84 if (p >= sv && p < svend)
85 ok = 1;
86 }
87 if (!ok) {
0453d815
PM		 88 if (ckWARN_d(WARN_INTERNAL))
89 Perl_warner(aTHX_ WARN_INTERNAL,
1d7c1841
GS		 90 "Attempt to free non-arena SV: 0x%"UVxf,
91 PTR2UV(p));
a0d0e21e
LW		 92 return;
93 }
94 }
4561caa4 95 plant_SV(p);
463ee0b2 96}
a0d0e21e 97
4561caa4
CS		 98#else /* ! DEBUGGING */
99
100#define del_SV(p) plant_SV(p)
101
102#endif /* DEBUGGING */
463ee0b2 103
4633a7c4 104void
864dbfa3 105Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
463ee0b2 106{
4633a7c4 107 SV* sva = (SV*)ptr;
463ee0b2
LW		 108 register SV* sv;
109 register SV* svend;
14dd3ad8 110 Zero(ptr, size, char);
4633a7c4
LW		 111
112 /* The first SV in an arena isn't an SV. */
3280af22 113 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
4633a7c4
LW		 114 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
115 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
116
3280af22
NIS		 117 PL_sv_arenaroot = sva;
118 PL_sv_root = sva + 1;
4633a7c4
LW		 119
120 svend = &sva[SvREFCNT(sva) - 1];
121 sv = sva + 1;
463ee0b2 122 while (sv < svend) {
a0d0e21e 123 SvANY(sv) = (void *)(SV*)(sv + 1);
8990e307 124 SvFLAGS(sv) = SVTYPEMASK;
463ee0b2
LW		 125 sv++;
126 }
127 SvANY(sv) = 0;
4633a7c4
LW		 128 SvFLAGS(sv) = SVTYPEMASK;
129}
130
fba3b22e 131/* sv_mutex must be held while calling more_sv() */
76e3520e 132STATIC SV*
cea2e8a9 133S_more_sv(pTHX)
4633a7c4 134{
4561caa4
CS		 135 register SV* sv;
136
3280af22
NIS		 137 if (PL_nice_chunk) {
138 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
139 PL_nice_chunk = Nullch;
c07a80fd 140 }
1edc1566 141 else {
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);
145 }
4561caa4
CS		 146 uproot_SV(sv);
147 return sv;
463ee0b2
LW		 148}
149
76e3520e 150STATIC void
cea2e8a9 151S_visit(pTHX_ SVFUNC_t f)
8990e307 152{
4633a7c4 153 SV* sva;
8990e307
LW		 154 SV* sv;
155 register SV* svend;
156
3280af22 157 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
4633a7c4 158 svend = &sva[SvREFCNT(sva)];
4561caa4
CS		 159 for (sv = sva + 1; sv < svend; ++sv) {
160 if (SvTYPE(sv) != SVTYPEMASK)
51371543 161 (FCALL)(aTHXo_ sv);
8990e307
LW		 162 }
163 }
164}
165
166void
864dbfa3 167Perl_sv_report_used(pTHX)
4561caa4 168{
0b94c7bb 169 visit(do_report_used);
4561caa4
CS		 170}
171
4561caa4 172void
864dbfa3 173Perl_sv_clean_objs(pTHX)
4561caa4 174{
3280af22 175 PL_in_clean_objs = TRUE;
0b94c7bb 176 visit(do_clean_objs);
4561caa4 177#ifndef DISABLE_DESTRUCTOR_KLUDGE
2d0f3c12 178 /* some barnacles may yet remain, clinging to typeglobs */
0b94c7bb 179 visit(do_clean_named_objs);
4561caa4 180#endif
3280af22 181 PL_in_clean_objs = FALSE;
4561caa4
CS		 182}
183
8990e307 184void
864dbfa3 185Perl_sv_clean_all(pTHX)
8990e307 186{
3280af22 187 PL_in_clean_all = TRUE;
0b94c7bb 188 visit(do_clean_all);
3280af22 189 PL_in_clean_all = FALSE;
8990e307 190}
463ee0b2 191
4633a7c4 192void
864dbfa3 193Perl_sv_free_arenas(pTHX)
4633a7c4
LW		 194{
195 SV* sva;
196 SV* svanext;
197
198 /* Free arenas here, but be careful about fake ones. (We assume
199 contiguity of the fake ones with the corresponding real ones.) */
200
3280af22 201 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
4633a7c4
LW		 202 svanext = (SV*) SvANY(sva);
203 while (svanext && SvFAKE(svanext))
204 svanext = (SV*) SvANY(svanext);
205
206 if (!SvFAKE(sva))
1edc1566 207 Safefree((void *)sva);
4633a7c4 208 }
5f05dabc 209
3280af22
NIS		 210 if (PL_nice_chunk)
211 Safefree(PL_nice_chunk);
212 PL_nice_chunk = Nullch;
213 PL_nice_chunk_size = 0;
214 PL_sv_arenaroot = 0;
215 PL_sv_root = 0;
4633a7c4
LW		 216}
217
1d7c1841
GS		 218void
219Perl_report_uninit(pTHX)
220{
221 if (PL_op)
222 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit,
223 " in ", PL_op_desc[PL_op->op_type]);
224 else
225 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", "");
226}
227
76e3520e 228STATIC XPVIV*
cea2e8a9 229S_new_xiv(pTHX)
463ee0b2 230{
ea7c11a3 231 IV* xiv;
cbe51380
GS		 232 LOCK_SV_MUTEX;
233 if (!PL_xiv_root)
234 more_xiv();
235 xiv = PL_xiv_root;
236 /*
237 * See comment in more_xiv() -- RAM.
238 */
239 PL_xiv_root = *(IV**)xiv;
240 UNLOCK_SV_MUTEX;
241 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
463ee0b2
LW		 242}
243
76e3520e 244STATIC void
cea2e8a9 245S_del_xiv(pTHX_ XPVIV *p)
463ee0b2 246{
23e6a22f 247 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
cbe51380 248 LOCK_SV_MUTEX;
3280af22
NIS		 249 *(IV**)xiv = PL_xiv_root;
250 PL_xiv_root = xiv;
cbe51380 251 UNLOCK_SV_MUTEX;
463ee0b2
LW		 252}
253
cbe51380 254STATIC void
cea2e8a9 255S_more_xiv(pTHX)
463ee0b2 256{
ea7c11a3
SM		 257 register IV* xiv;
258 register IV* xivend;
8c52afec
IZ		 259 XPV* ptr;
260 New(705, ptr, 1008/sizeof(XPV), XPV);
3280af22
NIS		 261 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
262 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
a0d0e21e 263
ea7c11a3
SM		 264 xiv = (IV*) ptr;
265 xivend = &xiv[1008 / sizeof(IV) - 1];
266 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
3280af22 267 PL_xiv_root = xiv;
463ee0b2 268 while (xiv < xivend) {
ea7c11a3 269 *(IV**)xiv = (IV *)(xiv + 1);
463ee0b2
LW		 270 xiv++;
271 }
ea7c11a3 272 *(IV**)xiv = 0;
463ee0b2
LW		 273}
274
76e3520e 275STATIC XPVNV*
cea2e8a9 276S_new_xnv(pTHX)
463ee0b2 277{
65202027 278 NV* xnv;
cbe51380
GS		 279 LOCK_SV_MUTEX;
280 if (!PL_xnv_root)
281 more_xnv();
282 xnv = PL_xnv_root;
65202027 283 PL_xnv_root = *(NV**)xnv;
cbe51380
GS		 284 UNLOCK_SV_MUTEX;
285 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
463ee0b2
LW		 286}
287
76e3520e 288STATIC void
cea2e8a9 289S_del_xnv(pTHX_ XPVNV *p)
463ee0b2 290{
65202027 291 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
cbe51380 292 LOCK_SV_MUTEX;
65202027 293 *(NV**)xnv = PL_xnv_root;
3280af22 294 PL_xnv_root = xnv;
cbe51380 295 UNLOCK_SV_MUTEX;
463ee0b2
LW		 296}
297
cbe51380 298STATIC void
cea2e8a9 299S_more_xnv(pTHX)
463ee0b2 300{
65202027
DS		 301 register NV* xnv;
302 register NV* xnvend;
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 */
3280af22 306 PL_xnv_root = xnv;
463ee0b2 307 while (xnv < xnvend) {
65202027 308 *(NV**)xnv = (NV*)(xnv + 1);
463ee0b2
LW		 309 xnv++;
310 }
65202027 311 *(NV**)xnv = 0;
463ee0b2
LW		 312}
313
76e3520e 314STATIC XRV*
cea2e8a9 315S_new_xrv(pTHX)
ed6116ce
LW		 316{
317 XRV* xrv;
cbe51380
GS		 318 LOCK_SV_MUTEX;
319 if (!PL_xrv_root)
320 more_xrv();
321 xrv = PL_xrv_root;
322 PL_xrv_root = (XRV*)xrv->xrv_rv;
323 UNLOCK_SV_MUTEX;
324 return xrv;
ed6116ce
LW		 325}
326
76e3520e 327STATIC void
cea2e8a9 328S_del_xrv(pTHX_ XRV *p)
ed6116ce 329{
cbe51380 330 LOCK_SV_MUTEX;
3280af22
NIS		 331 p->xrv_rv = (SV*)PL_xrv_root;
332 PL_xrv_root = p;
cbe51380 333 UNLOCK_SV_MUTEX;
ed6116ce
LW		 334}
335
cbe51380 336STATIC void
cea2e8a9 337S_more_xrv(pTHX)
ed6116ce 338{
ed6116ce
LW		 339 register XRV* xrv;
340 register XRV* xrvend;
3280af22
NIS		 341 New(712, PL_xrv_root, 1008/sizeof(XRV), XRV);
342 xrv = PL_xrv_root;
ed6116ce
LW		 343 xrvend = &xrv[1008 / sizeof(XRV) - 1];
344 while (xrv < xrvend) {
345 xrv->xrv_rv = (SV*)(xrv + 1);
346 xrv++;
347 }
348 xrv->xrv_rv = 0;
ed6116ce
LW		 349}
350
76e3520e 351STATIC XPV*
cea2e8a9 352S_new_xpv(pTHX)
463ee0b2
LW		 353{
354 XPV* xpv;
cbe51380
GS		 355 LOCK_SV_MUTEX;
356 if (!PL_xpv_root)
357 more_xpv();
358 xpv = PL_xpv_root;
359 PL_xpv_root = (XPV*)xpv->xpv_pv;
360 UNLOCK_SV_MUTEX;
361 return xpv;
463ee0b2
LW		 362}
363
76e3520e 364STATIC void
cea2e8a9 365S_del_xpv(pTHX_ XPV *p)
463ee0b2 366{
cbe51380 367 LOCK_SV_MUTEX;
3280af22
NIS		 368 p->xpv_pv = (char*)PL_xpv_root;
369 PL_xpv_root = p;
cbe51380 370 UNLOCK_SV_MUTEX;
463ee0b2
LW		 371}
372
cbe51380 373STATIC void
cea2e8a9 374S_more_xpv(pTHX)
463ee0b2 375{
463ee0b2
LW		 376 register XPV* xpv;
377 register XPV* xpvend;
3280af22
NIS		 378 New(713, PL_xpv_root, 1008/sizeof(XPV), XPV);
379 xpv = PL_xpv_root;
463ee0b2
LW		 380 xpvend = &xpv[1008 / sizeof(XPV) - 1];
381 while (xpv < xpvend) {
382 xpv->xpv_pv = (char*)(xpv + 1);
383 xpv++;
384 }
385 xpv->xpv_pv = 0;
463ee0b2
LW		 386}
387
932e9ff9
VB		 388STATIC XPVIV*
389S_new_xpviv(pTHX)
390{
391 XPVIV* xpviv;
392 LOCK_SV_MUTEX;
393 if (!PL_xpviv_root)
394 more_xpviv();
395 xpviv = PL_xpviv_root;
396 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
397 UNLOCK_SV_MUTEX;
398 return xpviv;
399}
400
401STATIC void
402S_del_xpviv(pTHX_ XPVIV *p)
403{
404 LOCK_SV_MUTEX;
405 p->xpv_pv = (char*)PL_xpviv_root;
406 PL_xpviv_root = p;
407 UNLOCK_SV_MUTEX;
408}
409
410
411STATIC void
412S_more_xpviv(pTHX)
413{
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);
421 xpviv++;
422 }
423 xpviv->xpv_pv = 0;
424}
425
426
427STATIC XPVNV*
428S_new_xpvnv(pTHX)
429{
430 XPVNV* xpvnv;
431 LOCK_SV_MUTEX;
432 if (!PL_xpvnv_root)
433 more_xpvnv();
434 xpvnv = PL_xpvnv_root;
435 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
436 UNLOCK_SV_MUTEX;
437 return xpvnv;
438}
439
440STATIC void
441S_del_xpvnv(pTHX_ XPVNV *p)
442{
443 LOCK_SV_MUTEX;
444 p->xpv_pv = (char*)PL_xpvnv_root;
445 PL_xpvnv_root = p;
446 UNLOCK_SV_MUTEX;
447}
448
449
450STATIC void
451S_more_xpvnv(pTHX)
452{
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);
460 xpvnv++;
461 }
462 xpvnv->xpv_pv = 0;
463}
464
465
466
467STATIC XPVCV*
468S_new_xpvcv(pTHX)
469{
470 XPVCV* xpvcv;
471 LOCK_SV_MUTEX;
472 if (!PL_xpvcv_root)
473 more_xpvcv();
474 xpvcv = PL_xpvcv_root;
475 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
476 UNLOCK_SV_MUTEX;
477 return xpvcv;
478}
479
480STATIC void
481S_del_xpvcv(pTHX_ XPVCV *p)
482{
483 LOCK_SV_MUTEX;
484 p->xpv_pv = (char*)PL_xpvcv_root;
485 PL_xpvcv_root = p;
486 UNLOCK_SV_MUTEX;
487}
488
489
490STATIC void
491S_more_xpvcv(pTHX)
492{
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);
500 xpvcv++;
501 }
502 xpvcv->xpv_pv = 0;
503}
504
505
506
507STATIC XPVAV*
508S_new_xpvav(pTHX)
509{
510 XPVAV* xpvav;
511 LOCK_SV_MUTEX;
512 if (!PL_xpvav_root)
513 more_xpvav();
514 xpvav = PL_xpvav_root;
515 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
516 UNLOCK_SV_MUTEX;
517 return xpvav;
518}
519
520STATIC void
521S_del_xpvav(pTHX_ XPVAV *p)
522{
523 LOCK_SV_MUTEX;
524 p->xav_array = (char*)PL_xpvav_root;
525 PL_xpvav_root = p;
526 UNLOCK_SV_MUTEX;
527}
528
529
530STATIC void
531S_more_xpvav(pTHX)
532{
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);
540 xpvav++;
541 }
542 xpvav->xav_array = 0;
543}
544
545
546
547STATIC XPVHV*
548S_new_xpvhv(pTHX)
549{
550 XPVHV* xpvhv;
551 LOCK_SV_MUTEX;
552 if (!PL_xpvhv_root)
553 more_xpvhv();
554 xpvhv = PL_xpvhv_root;
555 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
556 UNLOCK_SV_MUTEX;
557 return xpvhv;
558}
559
560STATIC void
561S_del_xpvhv(pTHX_ XPVHV *p)
562{
563 LOCK_SV_MUTEX;
564 p->xhv_array = (char*)PL_xpvhv_root;
565 PL_xpvhv_root = p;
566 UNLOCK_SV_MUTEX;
567}
568
569
570STATIC void
571S_more_xpvhv(pTHX)
572{
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);
580 xpvhv++;
581 }
582 xpvhv->xhv_array = 0;
583}
584
585
586STATIC XPVMG*
587S_new_xpvmg(pTHX)
588{
589 XPVMG* xpvmg;
590 LOCK_SV_MUTEX;
591 if (!PL_xpvmg_root)
592 more_xpvmg();
593 xpvmg = PL_xpvmg_root;
594 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
595 UNLOCK_SV_MUTEX;
596 return xpvmg;
597}
598
599STATIC void
600S_del_xpvmg(pTHX_ XPVMG *p)
601{
602 LOCK_SV_MUTEX;
603 p->xpv_pv = (char*)PL_xpvmg_root;
604 PL_xpvmg_root = p;
605 UNLOCK_SV_MUTEX;
606}
607
608
609STATIC void
610S_more_xpvmg(pTHX)
611{
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);
619 xpvmg++;
620 }
621 xpvmg->xpv_pv = 0;
622}
623
624
625
626STATIC XPVLV*
627S_new_xpvlv(pTHX)
628{
629 XPVLV* xpvlv;
630 LOCK_SV_MUTEX;
631 if (!PL_xpvlv_root)
632 more_xpvlv();
633 xpvlv = PL_xpvlv_root;
634 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
635 UNLOCK_SV_MUTEX;
636 return xpvlv;
637}
638
639STATIC void
640S_del_xpvlv(pTHX_ XPVLV *p)
641{
642 LOCK_SV_MUTEX;
643 p->xpv_pv = (char*)PL_xpvlv_root;
644 PL_xpvlv_root = p;
645 UNLOCK_SV_MUTEX;
646}
647
648
649STATIC void
650S_more_xpvlv(pTHX)
651{
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);
659 xpvlv++;
660 }
661 xpvlv->xpv_pv = 0;
662}
663
664
665STATIC XPVBM*
666S_new_xpvbm(pTHX)
667{
668 XPVBM* xpvbm;
669 LOCK_SV_MUTEX;
670 if (!PL_xpvbm_root)
671 more_xpvbm();
672 xpvbm = PL_xpvbm_root;
673 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
674 UNLOCK_SV_MUTEX;
675 return xpvbm;
676}
677
678STATIC void
679S_del_xpvbm(pTHX_ XPVBM *p)
680{
681 LOCK_SV_MUTEX;
682 p->xpv_pv = (char*)PL_xpvbm_root;
683 PL_xpvbm_root = p;
684 UNLOCK_SV_MUTEX;
685}
686
687
688STATIC void
689S_more_xpvbm(pTHX)
690{
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);
698 xpvbm++;
699 }
700 xpvbm->xpv_pv = 0;
701}
702
d33b2eba
GS		 703#ifdef LEAKTEST
704# define my_safemalloc(s) (void*)safexmalloc(717,s)
705# define my_safefree(p) safexfree((char*)p)
706#else
707# define my_safemalloc(s) (void*)safemalloc(s)
708# define my_safefree(p) safefree((char*)p)
709#endif
463ee0b2 710
d33b2eba 711#ifdef PURIFY
463ee0b2 712
d33b2eba
GS		 713#define new_XIV() my_safemalloc(sizeof(XPVIV))
714#define del_XIV(p) my_safefree(p)
ed6116ce 715
d33b2eba
GS		 716#define new_XNV() my_safemalloc(sizeof(XPVNV))
717#define del_XNV(p) my_safefree(p)
463ee0b2 718
d33b2eba
GS		 719#define new_XRV() my_safemalloc(sizeof(XRV))
720#define del_XRV(p) my_safefree(p)
8c52afec 721
d33b2eba
GS		 722#define new_XPV() my_safemalloc(sizeof(XPV))
723#define del_XPV(p) my_safefree(p)
9b94d1dd 724
d33b2eba
GS		 725#define new_XPVIV() my_safemalloc(sizeof(XPVIV))
726#define del_XPVIV(p) my_safefree(p)
932e9ff9 727
d33b2eba
GS		 728#define new_XPVNV() my_safemalloc(sizeof(XPVNV))
729#define del_XPVNV(p) my_safefree(p)
932e9ff9 730
d33b2eba
GS		 731#define new_XPVCV() my_safemalloc(sizeof(XPVCV))
732#define del_XPVCV(p) my_safefree(p)
932e9ff9 733
d33b2eba
GS		 734#define new_XPVAV() my_safemalloc(sizeof(XPVAV))
735#define del_XPVAV(p) my_safefree(p)
736
737#define new_XPVHV() my_safemalloc(sizeof(XPVHV))
738#define del_XPVHV(p) my_safefree(p)
8c52afec 739
d33b2eba
GS		 740#define new_XPVMG() my_safemalloc(sizeof(XPVMG))
741#define del_XPVMG(p) my_safefree(p)
742
743#define new_XPVLV() my_safemalloc(sizeof(XPVLV))
744#define del_XPVLV(p) my_safefree(p)
745
746#define new_XPVBM() my_safemalloc(sizeof(XPVBM))
747#define del_XPVBM(p) my_safefree(p)
748
749#else /* !PURIFY */
750
751#define new_XIV() (void*)new_xiv()
752#define del_XIV(p) del_xiv((XPVIV*) p)
753
754#define new_XNV() (void*)new_xnv()
755#define del_XNV(p) del_xnv((XPVNV*) p)
9b94d1dd 756
d33b2eba
GS		 757#define new_XRV() (void*)new_xrv()
758#define del_XRV(p) del_xrv((XRV*) p)
9b94d1dd 759
d33b2eba
GS		 760#define new_XPV() (void*)new_xpv()
761#define del_XPV(p) del_xpv((XPV *)p)
762
763#define new_XPVIV() (void*)new_xpviv()
764#define del_XPVIV(p) del_xpviv((XPVIV *)p)
765
766#define new_XPVNV() (void*)new_xpvnv()
767#define del_XPVNV(p) del_xpvnv((XPVNV *)p)
768
769#define new_XPVCV() (void*)new_xpvcv()
770#define del_XPVCV(p) del_xpvcv((XPVCV *)p)
771
772#define new_XPVAV() (void*)new_xpvav()
773#define del_XPVAV(p) del_xpvav((XPVAV *)p)
774
775#define new_XPVHV() (void*)new_xpvhv()
776#define del_XPVHV(p) del_xpvhv((XPVHV *)p)
8c52afec 777
d33b2eba
GS		 778#define new_XPVMG() (void*)new_xpvmg()
779#define del_XPVMG(p) del_xpvmg((XPVMG *)p)
780
781#define new_XPVLV() (void*)new_xpvlv()
782#define del_XPVLV(p) del_xpvlv((XPVLV *)p)
783
784#define new_XPVBM() (void*)new_xpvbm()
785#define del_XPVBM(p) del_xpvbm((XPVBM *)p)
786
787#endif /* PURIFY */
9b94d1dd 788
d33b2eba
GS		 789#define new_XPVGV() my_safemalloc(sizeof(XPVGV))
790#define del_XPVGV(p) my_safefree(p)
791
792#define new_XPVFM() my_safemalloc(sizeof(XPVFM))
793#define del_XPVFM(p) my_safefree(p)
8c52afec 794
d33b2eba
GS		 795#define new_XPVIO() my_safemalloc(sizeof(XPVIO))
796#define del_XPVIO(p) my_safefree(p)
8990e307 797
954c1994
GS		 798/*
799=for apidoc sv_upgrade
800
801Upgrade an SV to a more complex form. Use C<SvUPGRADE>. See
802C<svtype>.
803
804=cut
805*/
806
79072805 807bool
864dbfa3 808Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
79072805
LW		 809{
810 char* pv;
811 U32 cur;
812 U32 len;
a0d0e21e 813 IV iv;
65202027 814 NV nv;
79072805
LW		 815 MAGIC* magic;
816 HV* stash;
817
818 if (SvTYPE(sv) == mt)
819 return TRUE;
820
a5f75d66
AD		 821 if (mt < SVt_PVIV)
822 (void)SvOOK_off(sv);
823
79072805
LW		 824 switch (SvTYPE(sv)) {
825 case SVt_NULL:
826 pv = 0;
827 cur = 0;
828 len = 0;
829 iv = 0;
830 nv = 0.0;
831 magic = 0;
832 stash = 0;
833 break;
79072805
LW		 834 case SVt_IV:
835 pv = 0;
836 cur = 0;
837 len = 0;
463ee0b2 838 iv = SvIVX(sv);
65202027 839 nv = (NV)SvIVX(sv);
79072805
LW		 840 del_XIV(SvANY(sv));
841 magic = 0;
842 stash = 0;
ed6116ce 843 if (mt == SVt_NV)
463ee0b2 844 mt = SVt_PVNV;
ed6116ce
LW		 845 else if (mt < SVt_PVIV)
846 mt = SVt_PVIV;
79072805
LW		 847 break;
848 case SVt_NV:
849 pv = 0;
850 cur = 0;
851 len = 0;
463ee0b2 852 nv = SvNVX(sv);
1bd302c3 853 iv = I_V(nv);
79072805
LW		 854 magic = 0;
855 stash = 0;
856 del_XNV(SvANY(sv));
857 SvANY(sv) = 0;
ed6116ce 858 if (mt < SVt_PVNV)
79072805
LW		 859 mt = SVt_PVNV;
860 break;
ed6116ce
LW		 861 case SVt_RV:
862 pv = (char*)SvRV(sv);
863 cur = 0;
864 len = 0;
56431972
RB		 865 iv = PTR2IV(pv);
866 nv = PTR2NV(pv);
ed6116ce
LW		 867 del_XRV(SvANY(sv));
868 magic = 0;
869 stash = 0;
870 break;
79072805 871 case SVt_PV:
463ee0b2 872 pv = SvPVX(sv);
79072805
LW		 873 cur = SvCUR(sv);
874 len = SvLEN(sv);
875 iv = 0;
876 nv = 0.0;
877 magic = 0;
878 stash = 0;
879 del_XPV(SvANY(sv));
748a9306
LW		 880 if (mt <= SVt_IV)
881 mt = SVt_PVIV;
882 else if (mt == SVt_NV)
883 mt = SVt_PVNV;
79072805
LW		 884 break;
885 case SVt_PVIV:
463ee0b2 886 pv = SvPVX(sv);
79072805
LW		 887 cur = SvCUR(sv);
888 len = SvLEN(sv);
463ee0b2 889 iv = SvIVX(sv);
79072805
LW		 890 nv = 0.0;
891 magic = 0;
892 stash = 0;
893 del_XPVIV(SvANY(sv));
894 break;
895 case SVt_PVNV:
463ee0b2 896 pv = SvPVX(sv);
79072805
LW		 897 cur = SvCUR(sv);
898 len = SvLEN(sv);
463ee0b2
LW		 899 iv = SvIVX(sv);
900 nv = SvNVX(sv);
79072805
LW		 901 magic = 0;
902 stash = 0;
903 del_XPVNV(SvANY(sv));
904 break;
905 case SVt_PVMG:
463ee0b2 906 pv = SvPVX(sv);
79072805
LW		 907 cur = SvCUR(sv);
908 len = SvLEN(sv);
463ee0b2
LW		 909 iv = SvIVX(sv);
910 nv = SvNVX(sv);
79072805
LW		 911 magic = SvMAGIC(sv);
912 stash = SvSTASH(sv);
913 del_XPVMG(SvANY(sv));
914 break;
915 default:
cea2e8a9 916 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
79072805
LW		 917 }
918
919 switch (mt) {
920 case SVt_NULL:
cea2e8a9 921 Perl_croak(aTHX_ "Can't upgrade to undef");
79072805
LW		 922 case SVt_IV:
923 SvANY(sv) = new_XIV();
463ee0b2 924 SvIVX(sv) = iv;
79072805
LW		 925 break;
926 case SVt_NV:
927 SvANY(sv) = new_XNV();
463ee0b2 928 SvNVX(sv) = nv;
79072805 929 break;
ed6116ce
LW		 930 case SVt_RV:
931 SvANY(sv) = new_XRV();
932 SvRV(sv) = (SV*)pv;
ed6116ce 933 break;
79072805
LW		 934 case SVt_PV:
935 SvANY(sv) = new_XPV();
463ee0b2 936 SvPVX(sv) = pv;
79072805
LW		 937 SvCUR(sv) = cur;
938 SvLEN(sv) = len;
939 break;
940 case SVt_PVIV:
941 SvANY(sv) = new_XPVIV();
463ee0b2 942 SvPVX(sv) = pv;
79072805
LW		 943 SvCUR(sv) = cur;
944 SvLEN(sv) = len;
463ee0b2 945 SvIVX(sv) = iv;
79072805 946 if (SvNIOK(sv))
a0d0e21e 947 (void)SvIOK_on(sv);
79072805
LW		 948 SvNOK_off(sv);
949 break;
950 case SVt_PVNV:
951 SvANY(sv) = new_XPVNV();
463ee0b2 952 SvPVX(sv) = pv;
79072805
LW		 953 SvCUR(sv) = cur;
954 SvLEN(sv) = len;
463ee0b2
LW		 955 SvIVX(sv) = iv;
956 SvNVX(sv) = nv;
79072805
LW		 957 break;
958 case SVt_PVMG:
959 SvANY(sv) = new_XPVMG();
463ee0b2 960 SvPVX(sv) = pv;
79072805
LW		 961 SvCUR(sv) = cur;
962 SvLEN(sv) = len;
463ee0b2
LW		 963 SvIVX(sv) = iv;
964 SvNVX(sv) = nv;
79072805
LW		 965 SvMAGIC(sv) = magic;
966 SvSTASH(sv) = stash;
967 break;
968 case SVt_PVLV:
969 SvANY(sv) = new_XPVLV();
463ee0b2 970 SvPVX(sv) = pv;
79072805
LW		 971 SvCUR(sv) = cur;
972 SvLEN(sv) = len;
463ee0b2
LW		 973 SvIVX(sv) = iv;
974 SvNVX(sv) = nv;
79072805
LW		 975 SvMAGIC(sv) = magic;
976 SvSTASH(sv) = stash;
977 LvTARGOFF(sv) = 0;
978 LvTARGLEN(sv) = 0;
979 LvTARG(sv) = 0;
980 LvTYPE(sv) = 0;
981 break;
982 case SVt_PVAV:
983 SvANY(sv) = new_XPVAV();
463ee0b2
LW		 984 if (pv)
985 Safefree(pv);
2304df62 986 SvPVX(sv) = 0;
d1bf51dd 987 AvMAX(sv) = -1;
93965878 988 AvFILLp(sv) = -1;
463ee0b2
LW		 989 SvIVX(sv) = 0;
990 SvNVX(sv) = 0.0;
991 SvMAGIC(sv) = magic;
992 SvSTASH(sv) = stash;
993 AvALLOC(sv) = 0;
79072805
LW		 994 AvARYLEN(sv) = 0;
995 AvFLAGS(sv) = 0;
996 break;
997 case SVt_PVHV:
998 SvANY(sv) = new_XPVHV();
463ee0b2
LW		 999 if (pv)
1000 Safefree(pv);
1001 SvPVX(sv) = 0;
1002 HvFILL(sv) = 0;
1003 HvMAX(sv) = 0;
1004 HvKEYS(sv) = 0;
1005 SvNVX(sv) = 0.0;
79072805
LW		 1006 SvMAGIC(sv) = magic;
1007 SvSTASH(sv) = stash;
79072805
LW		 1008 HvRITER(sv) = 0;
1009 HvEITER(sv) = 0;
1010 HvPMROOT(sv) = 0;
1011 HvNAME(sv) = 0;
79072805
LW		 1012 break;
1013 case SVt_PVCV:
1014 SvANY(sv) = new_XPVCV();
748a9306 1015 Zero(SvANY(sv), 1, XPVCV);
463ee0b2 1016 SvPVX(sv) = pv;
79072805
LW		 1017 SvCUR(sv) = cur;
1018 SvLEN(sv) = len;
463ee0b2
LW		 1019 SvIVX(sv) = iv;
1020 SvNVX(sv) = nv;
79072805
LW		 1021 SvMAGIC(sv) = magic;
1022 SvSTASH(sv) = stash;
79072805
LW		 1023 break;
1024 case SVt_PVGV:
1025 SvANY(sv) = new_XPVGV();
463ee0b2 1026 SvPVX(sv) = pv;
79072805
LW		 1027 SvCUR(sv) = cur;
1028 SvLEN(sv) = len;
463ee0b2
LW		 1029 SvIVX(sv) = iv;
1030 SvNVX(sv) = nv;
79072805
LW		 1031 SvMAGIC(sv) = magic;
1032 SvSTASH(sv) = stash;
93a17b20 1033 GvGP(sv) = 0;
79072805
LW		 1034 GvNAME(sv) = 0;
1035 GvNAMELEN(sv) = 0;
1036 GvSTASH(sv) = 0;
a5f75d66 1037 GvFLAGS(sv) = 0;
79072805
LW		 1038 break;
1039 case SVt_PVBM:
1040 SvANY(sv) = new_XPVBM();
463ee0b2 1041 SvPVX(sv) = pv;
79072805
LW		 1042 SvCUR(sv) = cur;
1043 SvLEN(sv) = len;
463ee0b2
LW		 1044 SvIVX(sv) = iv;
1045 SvNVX(sv) = nv;
79072805
LW		 1046 SvMAGIC(sv) = magic;
1047 SvSTASH(sv) = stash;
1048 BmRARE(sv) = 0;
1049 BmUSEFUL(sv) = 0;
1050 BmPREVIOUS(sv) = 0;
1051 break;
1052 case SVt_PVFM:
1053 SvANY(sv) = new_XPVFM();
748a9306 1054 Zero(SvANY(sv), 1, XPVFM);
463ee0b2 1055 SvPVX(sv) = pv;
79072805
LW		 1056 SvCUR(sv) = cur;
1057 SvLEN(sv) = len;
463ee0b2
LW		 1058 SvIVX(sv) = iv;
1059 SvNVX(sv) = nv;
79072805
LW		 1060 SvMAGIC(sv) = magic;
1061 SvSTASH(sv) = stash;
79072805 1062 break;
8990e307
LW		 1063 case SVt_PVIO:
1064 SvANY(sv) = new_XPVIO();
748a9306 1065 Zero(SvANY(sv), 1, XPVIO);
8990e307
LW		 1066 SvPVX(sv) = pv;
1067 SvCUR(sv) = cur;
1068 SvLEN(sv) = len;
1069 SvIVX(sv) = iv;
1070 SvNVX(sv) = nv;
1071 SvMAGIC(sv) = magic;
1072 SvSTASH(sv) = stash;
85e6fe83 1073 IoPAGE_LEN(sv) = 60;
8990e307
LW		 1074 break;
1075 }
1076 SvFLAGS(sv) &= ~SVTYPEMASK;
1077 SvFLAGS(sv) |= mt;
79072805
LW		 1078 return TRUE;
1079}
1080
79072805 1081int
864dbfa3 1082Perl_sv_backoff(pTHX_ register SV *sv)
79072805
LW		 1083{
1084 assert(SvOOK(sv));
463ee0b2
LW		 1085 if (SvIVX(sv)) {
1086 char *s = SvPVX(sv);
1087 SvLEN(sv) += SvIVX(sv);
1088 SvPVX(sv) -= SvIVX(sv);
79072805 1089 SvIV_set(sv, 0);
463ee0b2 1090 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
79072805
LW		 1091 }
1092 SvFLAGS(sv) &= ~SVf_OOK;
a0d0e21e 1093 return 0;
79072805
LW		 1094}
1095
954c1994
GS		 1096/*
1097=for apidoc sv_grow
1098
1099Expands the character buffer in the SV. This will use C<sv_unref> and will
1100upgrade the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1101Use C<SvGROW>.
1102
1103=cut
1104*/
1105
79072805 1106char *
864dbfa3 1107Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
79072805
LW		 1108{
1109 register char *s;
1110
55497cff 1111#ifdef HAS_64K_LIMIT
79072805 1112 if (newlen >= 0x10000) {
1d7c1841
GS		 1113 PerlIO_printf(Perl_debug_log,
1114 "Allocation too large: %"UVxf"\n", (UV)newlen);
79072805
LW		 1115 my_exit(1);
1116 }
55497cff 1117#endif /* HAS_64K_LIMIT */
a0d0e21e
LW		 1118 if (SvROK(sv))
1119 sv_unref(sv);
79072805
LW		 1120 if (SvTYPE(sv) < SVt_PV) {
1121 sv_upgrade(sv, SVt_PV);
463ee0b2 1122 s = SvPVX(sv);
79072805
LW		 1123 }
1124 else if (SvOOK(sv)) { /* pv is offset? */
1125 sv_backoff(sv);
463ee0b2 1126 s = SvPVX(sv);
79072805
LW		 1127 if (newlen > SvLEN(sv))
1128 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
c6f8c383
GA		 1129#ifdef HAS_64K_LIMIT
1130 if (newlen >= 0x10000)
1131 newlen = 0xFFFF;
1132#endif
79072805
LW		 1133 }
1134 else
463ee0b2 1135 s = SvPVX(sv);
79072805 1136 if (newlen > SvLEN(sv)) { /* need more room? */
8d6dde3e 1137 if (SvLEN(sv) && s) {
f5a32c7f 1138#if defined(MYMALLOC) && !defined(LEAKTEST)
8d6dde3e
IZ		 1139 STRLEN l = malloced_size((void*)SvPVX(sv));
1140 if (newlen <= l) {
1141 SvLEN_set(sv, l);
1142 return s;
1143 } else
c70c8a0a 1144#endif
79072805 1145 Renew(s,newlen,char);
8d6dde3e 1146 }
79072805
LW		 1147 else
1148 New(703,s,newlen,char);
1149 SvPV_set(sv, s);
1150 SvLEN_set(sv, newlen);
1151 }
1152 return s;
1153}
1154
954c1994
GS		 1155/*
1156=for apidoc sv_setiv
1157
1158Copies an integer into the given SV. Does not handle 'set' magic. See
1159C<sv_setiv_mg>.
1160
1161=cut
1162*/
1163
79072805 1164void
864dbfa3 1165Perl_sv_setiv(pTHX_ register SV *sv, IV i)
79072805 1166{
2213622d 1167 SV_CHECK_THINKFIRST(sv);
463ee0b2
LW		 1168 switch (SvTYPE(sv)) {
1169 case SVt_NULL:
79072805 1170 sv_upgrade(sv, SVt_IV);
463ee0b2
LW		 1171 break;
1172 case SVt_NV:
1173 sv_upgrade(sv, SVt_PVNV);
1174 break;
ed6116ce 1175 case SVt_RV:
463ee0b2 1176 case SVt_PV:
79072805 1177 sv_upgrade(sv, SVt_PVIV);
463ee0b2 1178 break;
a0d0e21e
LW		 1179
1180 case SVt_PVGV:
a0d0e21e
LW		 1181 case SVt_PVAV:
1182 case SVt_PVHV:
1183 case SVt_PVCV:
1184 case SVt_PVFM:
1185 case SVt_PVIO:
11343788
MB		 1186 {
1187 dTHR;
cea2e8a9 1188 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
22c35a8c 1189 PL_op_desc[PL_op->op_type]);
11343788 1190 }
463ee0b2 1191 }
a0d0e21e 1192 (void)SvIOK_only(sv); /* validate number */
a5f75d66 1193 SvIVX(sv) = i;
463ee0b2 1194 SvTAINT(sv);
79072805
LW		 1195}
1196
954c1994
GS		 1197/*
1198=for apidoc sv_setiv_mg
1199
1200Like C<sv_setiv>, but also handles 'set' magic.
1201
1202=cut
1203*/
1204
79072805 1205void
864dbfa3 1206Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
ef50df4b
GS		 1207{
1208 sv_setiv(sv,i);
1209 SvSETMAGIC(sv);
1210}
1211
954c1994
GS		 1212/*
1213=for apidoc sv_setuv
1214
1215Copies an unsigned integer into the given SV. Does not handle 'set' magic.
1216See C<sv_setuv_mg>.
1217
1218=cut
1219*/
1220
ef50df4b 1221void
864dbfa3 1222Perl_sv_setuv(pTHX_ register SV *sv, UV u)
55497cff 1223{
25da4f38
IZ		 1224 sv_setiv(sv, 0);
1225 SvIsUV_on(sv);
1226 SvUVX(sv) = u;
55497cff 1227}
1228
954c1994
GS		 1229/*
1230=for apidoc sv_setuv_mg
1231
1232Like C<sv_setuv>, but also handles 'set' magic.
1233
1234=cut
1235*/
1236
55497cff 1237void
864dbfa3 1238Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
ef50df4b
GS		 1239{
1240 sv_setuv(sv,u);
1241 SvSETMAGIC(sv);
1242}
1243
954c1994
GS		 1244/*
1245=for apidoc sv_setnv
1246
1247Copies a double into the given SV. Does not handle 'set' magic. See
1248C<sv_setnv_mg>.
1249
1250=cut
1251*/
1252
ef50df4b 1253void
65202027 1254Perl_sv_setnv(pTHX_ register SV *sv, NV num)
79072805 1255{
2213622d 1256 SV_CHECK_THINKFIRST(sv);
a0d0e21e
LW		 1257 switch (SvTYPE(sv)) {
1258 case SVt_NULL:
1259 case SVt_IV:
79072805 1260 sv_upgrade(sv, SVt_NV);
a0d0e21e 1261 break;
a0d0e21e
LW		 1262 case SVt_RV:
1263 case SVt_PV:
1264 case SVt_PVIV:
79072805 1265 sv_upgrade(sv, SVt_PVNV);
a0d0e21e 1266 break;
827b7e14 1267
a0d0e21e 1268 case SVt_PVGV:
a0d0e21e
LW		 1269 case SVt_PVAV:
1270 case SVt_PVHV:
1271 case SVt_PVCV:
1272 case SVt_PVFM:
1273 case SVt_PVIO:
11343788
MB		 1274 {
1275 dTHR;
cea2e8a9 1276 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
22c35a8c 1277 PL_op_name[PL_op->op_type]);
11343788 1278 }
79072805 1279 }
463ee0b2 1280 SvNVX(sv) = num;
a0d0e21e 1281 (void)SvNOK_only(sv); /* validate number */
463ee0b2 1282 SvTAINT(sv);
79072805
LW		 1283}
1284
954c1994
GS		 1285/*
1286=for apidoc sv_setnv_mg
1287
1288Like C<sv_setnv>, but also handles 'set' magic.
1289
1290=cut
1291*/
1292
ef50df4b 1293void
65202027 1294Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
ef50df4b
GS		 1295{
1296 sv_setnv(sv,num);
1297 SvSETMAGIC(sv);
1298}
1299
76e3520e 1300STATIC void
cea2e8a9 1301S_not_a_number(pTHX_ SV *sv)
a0d0e21e 1302{
11343788 1303 dTHR;
a0d0e21e
LW		 1304 char tmpbuf[64];
1305 char *d = tmpbuf;
1306 char *s;
dc28f22b
GA		 1307 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1308 /* each *s can expand to 4 chars + "...\0",
1309 i.e. need room for 8 chars */
a0d0e21e 1310
dc28f22b 1311 for (s = SvPVX(sv); *s && d < limit; s++) {
bbce6d69 1312 int ch = *s & 0xFF;
1313 if (ch & 128 && !isPRINT_LC(ch)) {
a0d0e21e
LW		 1314 *d++ = 'M';
1315 *d++ = '-';
1316 ch &= 127;
1317 }
bbce6d69 1318 if (ch == '\n') {
1319 *d++ = '\\';
1320 *d++ = 'n';
1321 }
1322 else if (ch == '\r') {
1323 *d++ = '\\';
1324 *d++ = 'r';
1325 }
1326 else if (ch == '\f') {
1327 *d++ = '\\';
1328 *d++ = 'f';
1329 }
1330 else if (ch == '\\') {
1331 *d++ = '\\';
1332 *d++ = '\\';
1333 }
1334 else if (isPRINT_LC(ch))
a0d0e21e
LW		 1335 *d++ = ch;
1336 else {
1337 *d++ = '^';
bbce6d69 1338 *d++ = toCTRL(ch);
a0d0e21e
LW		 1339 }
1340 }
1341 if (*s) {
1342 *d++ = '.';
1343 *d++ = '.';
1344 *d++ = '.';
1345 }
1346 *d = '\0';
1347
533c011a 1348 if (PL_op)
42d38218
MS		 1349 Perl_warner(aTHX_ WARN_NUMERIC,
1350 "Argument \"%s\" isn't numeric in %s", tmpbuf,
1351 PL_op_desc[PL_op->op_type]);
a0d0e21e 1352 else
42d38218
MS		 1353 Perl_warner(aTHX_ WARN_NUMERIC,
1354 "Argument \"%s\" isn't numeric", tmpbuf);
a0d0e21e
LW		 1355}
1356
cf2093f6 1357/* the number can be converted to integer with atol() or atoll() */
25da4f38
IZ		 1358#define IS_NUMBER_TO_INT_BY_ATOL 0x01
1359#define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
1360#define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */
1361#define IS_NUMBER_NEG 0x08 /* not good to cache UV */
1362
1363/* Actually, ISO C leaves conversion of UV to IV undefined, but
1364 until proven guilty, assume that things are not that bad... */
1365
a0d0e21e 1366IV
864dbfa3 1367Perl_sv_2iv(pTHX_ register SV *sv)
79072805
LW		 1368{
1369 if (!sv)
1370 return 0;
8990e307 1371 if (SvGMAGICAL(sv)) {
463ee0b2
LW		 1372 mg_get(sv);
1373 if (SvIOKp(sv))
1374 return SvIVX(sv);
748a9306 1375 if (SvNOKp(sv)) {
25da4f38 1376 return I_V(SvNVX(sv));
748a9306 1377 }
36477c24 1378 if (SvPOKp(sv) && SvLEN(sv))
1379 return asIV(sv);
3fe9a6f1 1380 if (!SvROK(sv)) {
d008e5eb 1381 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
c6ee37c5 1382 dTHR;
d008e5eb 1383 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1d7c1841 1384 report_uninit();
c6ee37c5 1385 }
36477c24 1386 return 0;
3fe9a6f1 1387 }
463ee0b2 1388 }
ed6116ce 1389 if (SvTHINKFIRST(sv)) {
a0d0e21e 1390 if (SvROK(sv)) {
a0d0e21e
LW		 1391 SV* tmpstr;
1392 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
9e7bc3e8 1393 return SvIV(tmpstr);
56431972 1394 return PTR2IV(SvRV(sv));
a0d0e21e 1395 }
0336b60e
IZ		 1396 if (SvREADONLY(sv) && !SvOK(sv)) {
1397 dTHR;
1398 if (ckWARN(WARN_UNINITIALIZED))
1d7c1841 1399 report_uninit();
ed6116ce
LW		 1400 return 0;
1401 }
79072805 1402 }
25da4f38
IZ		 1403 if (SvIOKp(sv)) {
1404 if (SvIsUV(sv)) {
1405 return (IV)(SvUVX(sv));
1406 }
1407 else {
1408 return SvIVX(sv);
1409 }
463ee0b2 1410 }
748a9306 1411 if (SvNOKp(sv)) {
25da4f38
IZ		 1412 /* We can cache the IV/UV value even if it not good enough
1413 * to reconstruct NV, since the conversion to PV will prefer
cf2093f6 1414 * NV over IV/UV.
25da4f38
IZ		 1415 */
1416
1417 if (SvTYPE(sv) == SVt_NV)
1418 sv_upgrade(sv, SVt_PVNV);
1419
a5f75d66 1420 (void)SvIOK_on(sv);
65202027 1421 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
748a9306 1422 SvIVX(sv) = I_V(SvNVX(sv));
25da4f38 1423 else {
ff68c719 1424 SvUVX(sv) = U_V(SvNVX(sv));
25da4f38
IZ		 1425 SvIsUV_on(sv);
1426 ret_iv_max:
cf2093f6 1427 DEBUG_c(PerlIO_printf(Perl_debug_log,
57def98f 1428 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
56431972 1429 PTR2UV(sv),
57def98f
JH		 1430 SvUVX(sv),
1431 SvUVX(sv)));
25da4f38
IZ		 1432 return (IV)SvUVX(sv);
1433 }
748a9306
LW		 1434 }
1435 else if (SvPOKp(sv) && SvLEN(sv)) {
25da4f38
IZ		 1436 I32 numtype = looks_like_number(sv);
1437
1438 /* We want to avoid a possible problem when we cache an IV which
1439 may be later translated to an NV, and the resulting NV is not
1440 the translation of the initial data.
1441
1442 This means that if we cache such an IV, we need to cache the
1443 NV as well. Moreover, we trade speed for space, and do not
1444 cache the NV if not needed.
1445 */
1446 if (numtype & IS_NUMBER_NOT_IV) {
1447 /* May be not an integer. Need to cache NV if we cache IV
1448 * - otherwise future conversion to NV will be wrong. */
65202027 1449 NV d;
25da4f38 1450
097ee67d 1451 d = Atof(SvPVX(sv));
25da4f38
IZ		 1452
1453 if (SvTYPE(sv) < SVt_PVNV)
1454 sv_upgrade(sv, SVt_PVNV);
1455 SvNVX(sv) = d;
1456 (void)SvNOK_on(sv);
1457 (void)SvIOK_on(sv);
65202027 1458#if defined(USE_LONG_DOUBLE)
1d7c1841
GS		 1459 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1460 PTR2UV(sv), SvNVX(sv)));
65202027 1461#else
1d7c1841
GS		 1462 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%g)\n",
1463 PTR2UV(sv), SvNVX(sv)));
65202027 1464#endif
65202027 1465 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
25da4f38
IZ		 1466 SvIVX(sv) = I_V(SvNVX(sv));
1467 else {
1468 SvUVX(sv) = U_V(SvNVX(sv));
1469 SvIsUV_on(sv);
1470 goto ret_iv_max;
1471 }
1472 }
1473 else if (numtype) {
1474 /* The NV may be reconstructed from IV - safe to cache IV,
1475 which may be calculated by atol(). */
1476 if (SvTYPE(sv) == SVt_PV)
1477 sv_upgrade(sv, SVt_PVIV);
1478 (void)SvIOK_on(sv);
cf2093f6 1479 SvIVX(sv) = Atol(SvPVX(sv));
25da4f38
IZ		 1480 }
1481 else { /* Not a number. Cache 0. */
1482 dTHR;
1483
1484 if (SvTYPE(sv) < SVt_PVIV)
1485 sv_upgrade(sv, SVt_PVIV);
1486 SvIVX(sv) = 0;
1487 (void)SvIOK_on(sv);
1488 if (ckWARN(WARN_NUMERIC))
1489 not_a_number(sv);
1490 }
93a17b20 1491 }
79072805 1492 else {
11343788 1493 dTHR;
599cee73 1494 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1d7c1841 1495 report_uninit();
25da4f38
IZ		 1496 if (SvTYPE(sv) < SVt_IV)
1497 /* Typically the caller expects that sv_any is not NULL now. */
1498 sv_upgrade(sv, SVt_IV);
a0d0e21e 1499 return 0;
79072805 1500 }
1d7c1841
GS		 1501 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1502 PTR2UV(sv),SvIVX(sv)));
25da4f38 1503 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
79072805
LW		 1504}
1505
ff68c719 1506UV
864dbfa3 1507Perl_sv_2uv(pTHX_ register SV *sv)
ff68c719 1508{
1509 if (!sv)
1510 return 0;
1511 if (SvGMAGICAL(sv)) {
1512 mg_get(sv);
1513 if (SvIOKp(sv))
1514 return SvUVX(sv);
1515 if (SvNOKp(sv))
1516 return U_V(SvNVX(sv));
36477c24 1517 if (SvPOKp(sv) && SvLEN(sv))
1518 return asUV(sv);
3fe9a6f1 1519 if (!SvROK(sv)) {
d008e5eb 1520 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
c6ee37c5 1521 dTHR;
d008e5eb 1522 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1d7c1841 1523 report_uninit();
c6ee37c5 1524 }
36477c24 1525 return 0;
3fe9a6f1 1526 }
ff68c719 1527 }
1528 if (SvTHINKFIRST(sv)) {
1529 if (SvROK(sv)) {
ff68c719 1530 SV* tmpstr;
1531 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
9e7bc3e8 1532 return SvUV(tmpstr);
56431972 1533 return PTR2UV(SvRV(sv));
ff68c719 1534 }
0336b60e
IZ		 1535 if (SvREADONLY(sv) && !SvOK(sv)) {
1536 dTHR;
1537 if (ckWARN(WARN_UNINITIALIZED))
1d7c1841 1538 report_uninit();
ff68c719 1539 return 0;
1540 }
1541 }
25da4f38
IZ		 1542 if (SvIOKp(sv)) {
1543 if (SvIsUV(sv)) {
1544 return SvUVX(sv);
1545 }
1546 else {
1547 return (UV)SvIVX(sv);
1548 }
ff68c719 1549 }
1550 if (SvNOKp(sv)) {
25da4f38
IZ		 1551 /* We can cache the IV/UV value even if it not good enough
1552 * to reconstruct NV, since the conversion to PV will prefer
cf2093f6 1553 * NV over IV/UV.
25da4f38
IZ		 1554 */
1555 if (SvTYPE(sv) == SVt_NV)
1556 sv_upgrade(sv, SVt_PVNV);
ff68c719 1557 (void)SvIOK_on(sv);
25da4f38
IZ		 1558 if (SvNVX(sv) >= -0.5) {
1559 SvIsUV_on(sv);
1560 SvUVX(sv) = U_V(SvNVX(sv));
1561 }
1562 else {
1563 SvIVX(sv) = I_V(SvNVX(sv));
1564 ret_zero:
cf2093f6 1565 DEBUG_c(PerlIO_printf(Perl_debug_log,
07270b1a 1566 "0x%"UVxf" 2uv(%"IVdf" => %"IVdf") (as signed)\n",
57def98f
JH		 1567 PTR2UV(sv),
1568 SvIVX(sv),
1569 (IV)(UV)SvIVX(sv)));
25da4f38
IZ		 1570 return (UV)SvIVX(sv);
1571 }
ff68c719 1572 }
1573 else if (SvPOKp(sv) && SvLEN(sv)) {
25da4f38
IZ		 1574 I32 numtype = looks_like_number(sv);
1575
1576 /* We want to avoid a possible problem when we cache a UV which
1577 may be later translated to an NV, and the resulting NV is not
1578 the translation of the initial data.
1579
1580 This means that if we cache such a UV, we need to cache the
1581 NV as well. Moreover, we trade speed for space, and do not
1582 cache the NV if not needed.
1583 */
1584 if (numtype & IS_NUMBER_NOT_IV) {
1585 /* May be not an integer. Need to cache NV if we cache IV
1586 * - otherwise future conversion to NV will be wrong. */
65202027 1587 NV d;
25da4f38 1588
cf2093f6 1589 d = Atof(SvPVX(sv));
25da4f38
IZ		 1590
1591 if (SvTYPE(sv) < SVt_PVNV)
1592 sv_upgrade(sv, SVt_PVNV);
1593 SvNVX(sv) = d;
1594 (void)SvNOK_on(sv);
1595 (void)SvIOK_on(sv);
65202027 1596#if defined(USE_LONG_DOUBLE)
1d7c1841
GS		 1597 DEBUG_c(PerlIO_printf(Perl_debug_log,
1598 "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1599 PTR2UV(sv), SvNVX(sv)));
65202027 1600#else
1d7c1841
GS		 1601 DEBUG_c(PerlIO_printf(Perl_debug_log,
1602 "0x%"UVxf" 2nv(%g)\n",
1603 PTR2UV(sv), SvNVX(sv)));
65202027 1604#endif
25da4f38
IZ		 1605 if (SvNVX(sv) < -0.5) {
1606 SvIVX(sv) = I_V(SvNVX(sv));
1607 goto ret_zero;
1608 } else {
1609 SvUVX(sv) = U_V(SvNVX(sv));
1610 SvIsUV_on(sv);
1611 }
1612 }
1613 else if (numtype & IS_NUMBER_NEG) {
1614 /* The NV may be reconstructed from IV - safe to cache IV,
1615 which may be calculated by atol(). */
1616 if (SvTYPE(sv) == SVt_PV)
1617 sv_upgrade(sv, SVt_PVIV);
1618 (void)SvIOK_on(sv);
cf2093f6 1619 SvIVX(sv) = (IV)Atol(SvPVX(sv));
25da4f38
IZ		 1620 }
1621 else if (numtype) { /* Non-negative */
1622 /* The NV may be reconstructed from UV - safe to cache UV,
1623 which may be calculated by strtoul()/atol. */
1624 if (SvTYPE(sv) == SVt_PV)
1625 sv_upgrade(sv, SVt_PVIV);
1626 (void)SvIOK_on(sv);
1627 (void)SvIsUV_on(sv);
1628#ifdef HAS_STRTOUL
cf2093f6 1629 SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
25da4f38
IZ		 1630#else /* no atou(), but we know the number fits into IV... */
1631 /* The only problem may be if it is negative... */
cf2093f6 1632 SvUVX(sv) = (UV)Atol(SvPVX(sv));
25da4f38
IZ		 1633#endif
1634 }
1635 else { /* Not a number. Cache 0. */
1636 dTHR;
1637
1638 if (SvTYPE(sv) < SVt_PVIV)
1639 sv_upgrade(sv, SVt_PVIV);
1640 SvUVX(sv) = 0; /* We assume that 0s have the
1641 same bitmap in IV and UV. */
1642 (void)SvIOK_on(sv);
1643 (void)SvIsUV_on(sv);
1644 if (ckWARN(WARN_NUMERIC))
1645 not_a_number(sv);
1646 }
ff68c719 1647 }
1648 else {
d008e5eb 1649 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
c6ee37c5 1650 dTHR;
d008e5eb 1651 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1d7c1841 1652 report_uninit();
c6ee37c5 1653 }
25da4f38
IZ		 1654 if (SvTYPE(sv) < SVt_IV)
1655 /* Typically the caller expects that sv_any is not NULL now. */
1656 sv_upgrade(sv, SVt_IV);
ff68c719 1657 return 0;
1658 }
25da4f38 1659
1d7c1841
GS		 1660 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
1661 PTR2UV(sv),SvUVX(sv)));
25da4f38 1662 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
ff68c719 1663}
1664
65202027 1665NV
864dbfa3 1666Perl_sv_2nv(pTHX_ register SV *sv)
79072805
LW		 1667{
1668 if (!sv)
1669 return 0.0;
8990e307 1670 if (SvGMAGICAL(sv)) {
463ee0b2
LW		 1671 mg_get(sv);
1672 if (SvNOKp(sv))
1673 return SvNVX(sv);
a0d0e21e 1674 if (SvPOKp(sv) && SvLEN(sv)) {
d008e5eb 1675 dTHR;
599cee73 1676 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
a0d0e21e 1677 not_a_number(sv);
097ee67d 1678 return Atof(SvPVX(sv));
a0d0e21e 1679 }
25da4f38
IZ		 1680 if (SvIOKp(sv)) {
1681 if (SvIsUV(sv))
65202027 1682 return (NV)SvUVX(sv);
25da4f38 1683 else
65202027 1684 return (NV)SvIVX(sv);
25da4f38 1685 }
16d20bd9 1686 if (!SvROK(sv)) {
d008e5eb 1687 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
c6ee37c5 1688 dTHR;
d008e5eb 1689 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1d7c1841 1690 report_uninit();
c6ee37c5 1691 }
16d20bd9
AD		 1692 return 0;
1693 }
463ee0b2 1694 }
ed6116ce 1695 if (SvTHINKFIRST(sv)) {
a0d0e21e 1696 if (SvROK(sv)) {
a0d0e21e
LW		 1697 SV* tmpstr;
1698 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
9e7bc3e8 1699 return SvNV(tmpstr);
56431972 1700 return PTR2NV(SvRV(sv));
a0d0e21e 1701 }
0336b60e 1702 if (SvREADONLY(sv) && !SvOK(sv)) {
d008e5eb 1703 dTHR;
599cee73 1704 if (ckWARN(WARN_UNINITIALIZED))
1d7c1841 1705 report_uninit();
ed6116ce
LW		 1706 return 0.0;
1707 }
79072805
LW		 1708 }
1709 if (SvTYPE(sv) < SVt_NV) {
463ee0b2
LW		 1710 if (SvTYPE(sv) == SVt_IV)
1711 sv_upgrade(sv, SVt_PVNV);
1712 else
1713 sv_upgrade(sv, SVt_NV);
572bbb43 1714#if defined(USE_LONG_DOUBLE)
097ee67d
JH		 1715 DEBUG_c({
1716 RESTORE_NUMERIC_STANDARD();
1d7c1841
GS		 1717 PerlIO_printf(Perl_debug_log,
1718 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
1719 PTR2UV(sv), SvNVX(sv));
572bbb43
GS		 1720 RESTORE_NUMERIC_LOCAL();
1721 });
65202027 1722#else
572bbb43
GS		 1723 DEBUG_c({
1724 RESTORE_NUMERIC_STANDARD();
1d7c1841
GS		 1725 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
1726 PTR2UV(sv), SvNVX(sv));
097ee67d
JH		 1727 RESTORE_NUMERIC_LOCAL();
1728 });
572bbb43 1729#endif
79072805
LW		 1730 }
1731 else if (SvTYPE(sv) < SVt_PVNV)
1732 sv_upgrade(sv, SVt_PVNV);
748a9306
LW		 1733 if (SvIOKp(sv) &&
1734 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
93a17b20 1735 {
65202027 1736 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
93a17b20 1737 }
748a9306 1738 else if (SvPOKp(sv) && SvLEN(sv)) {
d008e5eb 1739 dTHR;
599cee73 1740 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
a0d0e21e 1741 not_a_number(sv);
097ee67d 1742 SvNVX(sv) = Atof(SvPVX(sv));
93a17b20 1743 }
79072805 1744 else {
11343788 1745 dTHR;
599cee73 1746 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1d7c1841 1747 report_uninit();
25da4f38
IZ		 1748 if (SvTYPE(sv) < SVt_NV)
1749 /* Typically the caller expects that sv_any is not NULL now. */
1750 sv_upgrade(sv, SVt_NV);
a0d0e21e 1751 return 0.0;
79072805
LW		 1752 }
1753 SvNOK_on(sv);
572bbb43 1754#if defined(USE_LONG_DOUBLE)
097ee67d
JH		 1755 DEBUG_c({
1756 RESTORE_NUMERIC_STANDARD();
1d7c1841
GS		 1757 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1758 PTR2UV(sv), SvNVX(sv));
572bbb43
GS		 1759 RESTORE_NUMERIC_LOCAL();
1760 });
65202027 1761#else
572bbb43
GS		 1762 DEBUG_c({
1763 RESTORE_NUMERIC_STANDARD();
1d7c1841
GS		 1764 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
1765 PTR2UV(sv), SvNVX(sv));
097ee67d
JH		 1766 RESTORE_NUMERIC_LOCAL();
1767 });
572bbb43 1768#endif
463ee0b2 1769 return SvNVX(sv);
79072805
LW		 1770}
1771
76e3520e 1772STATIC IV
cea2e8a9 1773S_asIV(pTHX_ SV *sv)
36477c24 1774{
1775 I32 numtype = looks_like_number(sv);
65202027 1776 NV d;
36477c24 1777
25da4f38 1778 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
cf2093f6 1779 return Atol(SvPVX(sv));
d008e5eb
GS		 1780 if (!numtype) {
1781 dTHR;
1782 if (ckWARN(WARN_NUMERIC))
1783 not_a_number(sv);
1784 }
097ee67d 1785 d = Atof(SvPVX(sv));
25da4f38 1786 return I_V(d);
36477c24 1787}
1788
76e3520e 1789STATIC UV
cea2e8a9 1790S_asUV(pTHX_ SV *sv)
36477c24 1791{
1792 I32 numtype = looks_like_number(sv);
1793
84902520 1794#ifdef HAS_STRTOUL
25da4f38 1795 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
cf2093f6 1796 return Strtoul(SvPVX(sv), Null(char**), 10);
84902520 1797#endif
d008e5eb
GS		 1798 if (!numtype) {
1799 dTHR;
1800 if (ckWARN(WARN_NUMERIC))
1801 not_a_number(sv);
1802 }
097ee67d 1803 return U_V(Atof(SvPVX(sv)));
36477c24 1804}
1805
25da4f38
IZ		 1806/*
1807 * Returns a combination of (advisory only - can get false negatives)
1808 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
1809 * IS_NUMBER_NEG
1810 * 0 if does not look like number.
1811 *
1812 * In fact possible values are 0 and
1813 * IS_NUMBER_TO_INT_BY_ATOL 123
1814 * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
1815 * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
1816 * with a possible addition of IS_NUMBER_NEG.
1817 */
1818
954c1994
GS		 1819/*
1820=for apidoc looks_like_number
1821
1822Test if an the content of an SV looks like a number (or is a
1823number).
1824
1825=cut
1826*/
1827
36477c24 1828I32
864dbfa3 1829Perl_looks_like_number(pTHX_ SV *sv)
36477c24 1830{
1831 register char *s;
1832 register char *send;
1833 register char *sbegin;
25da4f38
IZ		 1834 register char *nbegin;
1835 I32 numtype = 0;
36477c24 1836 STRLEN len;
1837
1838 if (SvPOK(sv)) {
1839 sbegin = SvPVX(sv);
1840 len = SvCUR(sv);
1841 }
1842 else if (SvPOKp(sv))
1843 sbegin = SvPV(sv, len);
1844 else
1845 return 1;
1846 send = sbegin + len;
1847
1848 s = sbegin;
1849 while (isSPACE(*s))
1850 s++;
25da4f38
IZ		 1851 if (*s == '-') {
1852 s++;
1853 numtype = IS_NUMBER_NEG;
1854 }
1855 else if (*s == '+')
36477c24 1856 s++;
ff0cee69 1857
25da4f38
IZ		 1858 nbegin = s;
1859 /*
097ee67d
JH		 1860 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
1861 * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
1862 * (int)atof().
25da4f38
IZ		 1863 */
1864
097ee67d 1865 /* next must be digit or the radix separator */
ff0cee69 1866 if (isDIGIT(*s)) {
1867 do {
1868 s++;
1869 } while (isDIGIT(*s));
25da4f38
IZ		 1870
1871 if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */
1872 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1873 else
1874 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
1875
097ee67d
JH		 1876 if (*s == '.'
1877#ifdef USE_LOCALE_NUMERIC
1878 || IS_NUMERIC_RADIX(*s)
1879#endif
1880 ) {
ff0cee69 1881 s++;
25da4f38 1882 numtype |= IS_NUMBER_NOT_IV;
097ee67d 1883 while (isDIGIT(*s)) /* optional digits after the radix */
ff0cee69 1884 s++;
1885 }
36477c24 1886 }
097ee67d
JH		 1887 else if (*s == '.'
1888#ifdef USE_LOCALE_NUMERIC
1889 || IS_NUMERIC_RADIX(*s)
1890#endif
1891 ) {
ff0cee69 1892 s++;
25da4f38 1893 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
097ee67d 1894 /* no digits before the radix means we need digits after it */
ff0cee69 1895 if (isDIGIT(*s)) {
1896 do {
1897 s++;
1898 } while (isDIGIT(*s));
1899 }
1900 else
1901 return 0;
1902 }
1903 else
1904 return 0;
1905
ff0cee69 1906 /* we can have an optional exponent part */
36477c24 1907 if (*s == 'e' || *s == 'E') {
25da4f38
IZ		 1908 numtype &= ~IS_NUMBER_NEG;
1909 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
36477c24 1910 s++;
1911 if (*s == '+' || *s == '-')
1912 s++;
ff0cee69 1913 if (isDIGIT(*s)) {
1914 do {
1915 s++;
1916 } while (isDIGIT(*s));
1917 }
1918 else
1919 return 0;
36477c24 1920 }
1921 while (isSPACE(*s))
1922 s++;
1923 if (s >= send)
1924 return numtype;
1925 if (len == 10 && memEQ(sbegin, "0 but true", 10))
25da4f38 1926 return IS_NUMBER_TO_INT_BY_ATOL;
36477c24 1927 return 0;
1928}
1929
79072805 1930char *
864dbfa3 1931Perl_sv_2pv_nolen(pTHX_ register SV *sv)
1fa8b10d
JD		 1932{
1933 STRLEN n_a;
1934 return sv_2pv(sv, &n_a);
1935}
1936
25da4f38 1937/* We assume that buf is at least TYPE_CHARS(UV) long. */
864dbfa3 1938static char *
25da4f38
IZ		 1939uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
1940{
25da4f38
IZ		 1941 char *ptr = buf + TYPE_CHARS(UV);
1942 char *ebuf = ptr;
1943 int sign;
25da4f38
IZ		 1944
1945 if (is_uv)
1946 sign = 0;
1947 else if (iv >= 0) {
1948 uv = iv;
1949 sign = 0;
1950 } else {
1951 uv = -iv;
1952 sign = 1;
1953 }
1954 do {
1955 *--ptr = '0' + (uv % 10);
1956 } while (uv /= 10);
1957 if (sign)
1958 *--ptr = '-';
1959 *peob = ebuf;
1960 return ptr;
1961}
1962
1fa8b10d 1963char *
864dbfa3 1964Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
79072805
LW		 1965{
1966 register char *s;
1967 int olderrno;
46fc3d4c 1968 SV *tsv;
25da4f38
IZ		 1969 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
1970 char *tmpbuf = tbuf;
79072805 1971
463ee0b2
LW		 1972 if (!sv) {
1973 *lp = 0;
1974 return "";
1975 }
8990e307 1976 if (SvGMAGICAL(sv)) {
463ee0b2
LW		 1977 mg_get(sv);
1978 if (SvPOKp(sv)) {
1979 *lp = SvCUR(sv);
1980 return SvPVX(sv);
1981 }
cf2093f6 1982 if (SvIOKp(sv)) {
cf2093f6 1983 if (SvIsUV(sv))
57def98f 1984 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
cf2093f6 1985 else
57def98f 1986 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
46fc3d4c 1987 tsv = Nullsv;
a0d0e21e 1988 goto tokensave;
463ee0b2
LW		 1989 }
1990 if (SvNOKp(sv)) {
2d4389e4 1991 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
46fc3d4c 1992 tsv = Nullsv;
a0d0e21e 1993 goto tokensave;
463ee0b2 1994 }
16d20bd9 1995 if (!SvROK(sv)) {
d008e5eb 1996 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
c6ee37c5 1997 dTHR;
d008e5eb 1998 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1d7c1841 1999 report_uninit();
c6ee37c5 2000 }
16d20bd9
AD		 2001 *lp = 0;
2002 return "";
2003 }
463ee0b2 2004 }
ed6116ce
LW		 2005 if (SvTHINKFIRST(sv)) {
2006 if (SvROK(sv)) {
a0d0e21e
LW		 2007 SV* tmpstr;
2008 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
9e7bc3e8 2009 return SvPV(tmpstr,*lp);
ed6116ce
LW		 2010 sv = (SV*)SvRV(sv);
2011 if (!sv)
2012 s = "NULLREF";
2013 else {
f9277f47
IZ		 2014 MAGIC *mg;
2015
ed6116ce 2016 switch (SvTYPE(sv)) {
f9277f47
IZ		 2017 case SVt_PVMG:
2018 if ( ((SvFLAGS(sv) &
2019 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
3149a8e4 2020 == (SVs_OBJECT|SVs_RMG))
57668c4d 2021 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
f9277f47 2022 && (mg = mg_find(sv, 'r'))) {
5c0ca799 2023 dTHR;
2cd61cdb 2024 regexp *re = (regexp *)mg->mg_obj;
1bd3ad17 2025
2cd61cdb 2026 if (!mg->mg_ptr) {
8782bef2
GB		 2027 char *fptr = "msix";
2028 char reflags[6];
2029 char ch;
2030 int left = 0;
2031 int right = 4;
2032 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2033
155aba94 2034 while((ch = *fptr++)) {
8782bef2
GB		 2035 if(reganch & 1) {
2036 reflags[left++] = ch;
2037 }
2038 else {
2039 reflags[right--] = ch;
2040 }
2041 reganch >>= 1;
2042 }
2043 if(left != 4) {
2044 reflags[left] = '-';
2045 left = 5;
2046 }
2047
2048 mg->mg_len = re->prelen + 4 + left;
2049 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2050 Copy("(?", mg->mg_ptr, 2, char);
2051 Copy(reflags, mg->mg_ptr+2, left, char);
2052 Copy(":", mg->mg_ptr+left+2, 1, char);
2053 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
1bd3ad17
IZ		 2054 mg->mg_ptr[mg->mg_len - 1] = ')';
2055 mg->mg_ptr[mg->mg_len] = 0;
2056 }
3280af22 2057 PL_reginterp_cnt += re->program[0].next_off;
1bd3ad17
IZ		 2058 *lp = mg->mg_len;
2059 return mg->mg_ptr;
f9277f47
IZ		 2060 }
2061 /* Fall through */
ed6116ce
LW		 2062 case SVt_NULL:
2063 case SVt_IV:
2064 case SVt_NV:
2065 case SVt_RV:
2066 case SVt_PV:
2067 case SVt_PVIV:
2068 case SVt_PVNV:
f9277f47 2069 case SVt_PVBM: s = "SCALAR"; break;
ed6116ce
LW		 2070 case SVt_PVLV: s = "LVALUE"; break;
2071 case SVt_PVAV: s = "ARRAY"; break;
2072 case SVt_PVHV: s = "HASH"; break;
2073 case SVt_PVCV: s = "CODE"; break;
2074 case SVt_PVGV: s = "GLOB"; break;
1d2dff63 2075 case SVt_PVFM: s = "FORMAT"; break;
36477c24 2076 case SVt_PVIO: s = "IO"; break;
ed6116ce
LW		 2077 default: s = "UNKNOWN"; break;
2078 }
46fc3d4c 2079 tsv = NEWSV(0,0);
ed6116ce 2080 if (SvOBJECT(sv))
cea2e8a9 2081 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
ed6116ce 2082 else
46fc3d4c 2083 sv_setpv(tsv, s);
57def98f 2084 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
a0d0e21e 2085 goto tokensaveref;
463ee0b2 2086 }
ed6116ce
LW		 2087 *lp = strlen(s);
2088 return s;
79072805 2089 }
0336b60e
IZ		 2090 if (SvREADONLY(sv) && !SvOK(sv)) {
2091 dTHR;
2092 if (ckWARN(WARN_UNINITIALIZED))
1d7c1841 2093 report_uninit();
ed6116ce
LW		 2094 *lp = 0;
2095 return "";
79072805 2096 }
79072805 2097 }
25da4f38
IZ		 2098 if (SvNOKp(sv)) { /* See note in sv_2uv() */
2099 /* XXXX 64-bit? IV may have better precision... */
34d861e4
JH		 2100 /* I tried changing this for to be 64-bit-aware and
2101 * the t/op/numconvert.t became very, very, angry.
2102 * --jhi Sep 1999 */
79072805
LW		 2103 if (SvTYPE(sv) < SVt_PVNV)
2104 sv_upgrade(sv, SVt_PVNV);
2105 SvGROW(sv, 28);
463ee0b2 2106 s = SvPVX(sv);
79072805 2107 olderrno = errno; /* some Xenix systems wipe out errno here */
79072805 2108#ifdef apollo
463ee0b2 2109 if (SvNVX(sv) == 0.0)
79072805
LW		 2110 (void)strcpy(s,"0");
2111 else
2112#endif /*apollo*/
bbce6d69 2113 {
2d4389e4 2114 Gconvert(SvNVX(sv), NV_DIG, 0, s);
bbce6d69 2115 }
79072805 2116 errno = olderrno;
a0d0e21e
LW		 2117#ifdef FIXNEGATIVEZERO
2118 if (*s == '-' && s[1] == '0' && !s[2])
2119 strcpy(s,"0");
2120#endif
79072805
LW		 2121 while (*s) s++;
2122#ifdef hcx
2123 if (s[-1] == '.')
46fc3d4c 2124 *--s = '\0';
79072805
LW		 2125#endif
2126 }
748a9306 2127 else if (SvIOKp(sv)) {
25da4f38 2128 U32 isIOK = SvIOK(sv);
0336b60e 2129 U32 isUIOK = SvIsUV(sv);
25da4f38
IZ		 2130 char buf[TYPE_CHARS(UV)];
2131 char *ebuf, *ptr;
2132
79072805
LW		 2133 if (SvTYPE(sv) < SVt_PVIV)
2134 sv_upgrade(sv, SVt_PVIV);
0336b60e 2135 if (isUIOK)
25da4f38 2136 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
0336b60e 2137 else
25da4f38 2138 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
0336b60e
IZ		 2139 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2140 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2141 SvCUR_set(sv, ebuf - ptr);
46fc3d4c 2142 s = SvEND(sv);
0336b60e 2143 *s = '\0';
25da4f38 2144 if (isIOK)
64f14228
GA		 2145 SvIOK_on(sv);
2146 else
2147 SvIOKp_on(sv);
0336b60e
IZ		 2148 if (isUIOK)
2149 SvIsUV_on(sv);
2150 SvPOK_on(sv);
79072805
LW		 2151 }
2152 else {
11343788 2153 dTHR;
0336b60e
IZ		 2154 if (ckWARN(WARN_UNINITIALIZED)
2155 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2156 {
1d7c1841 2157 report_uninit();
0336b60e 2158 }
a0d0e21e 2159 *lp = 0;
25da4f38
IZ		 2160 if (SvTYPE(sv) < SVt_PV)
2161 /* Typically the caller expects that sv_any is not NULL now. */
2162 sv_upgrade(sv, SVt_PV);
a0d0e21e 2163 return "";
79072805 2164 }
463ee0b2
LW		 2165 *lp = s - SvPVX(sv);
2166 SvCUR_set(sv, *lp);
79072805 2167 SvPOK_on(sv);
1d7c1841
GS		 2168 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2169 PTR2UV(sv),SvPVX(sv)));
463ee0b2 2170 return SvPVX(sv);
a0d0e21e
LW		 2171
2172 tokensave:
2173 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2174 /* Sneaky stuff here */
2175
2176 tokensaveref:
46fc3d4c 2177 if (!tsv)
96827780 2178 tsv = newSVpv(tmpbuf, 0);
46fc3d4c 2179 sv_2mortal(tsv);
2180 *lp = SvCUR(tsv);
2181 return SvPVX(tsv);
a0d0e21e
LW		 2182 }
2183 else {
2184 STRLEN len;
46fc3d4c 2185 char *t;
2186
2187 if (tsv) {
2188 sv_2mortal(tsv);
2189 t = SvPVX(tsv);
2190 len = SvCUR(tsv);
2191 }
2192 else {
96827780
MB		 2193 t = tmpbuf;
2194 len = strlen(tmpbuf);
46fc3d4c 2195 }
a0d0e21e 2196#ifdef FIXNEGATIVEZERO
46fc3d4c 2197 if (len == 2 && t[0] == '-' && t[1] == '0') {
2198 t = "0";
2199 len = 1;
2200 }
a0d0e21e
LW		 2201#endif
2202 (void)SvUPGRADE(sv, SVt_PV);
46fc3d4c 2203 *lp = len;
a0d0e21e
LW		 2204 s = SvGROW(sv, len + 1);
2205 SvCUR_set(sv, len);
46fc3d4c 2206 (void)strcpy(s, t);
6bf554b4 2207 SvPOKp_on(sv);
a0d0e21e
LW		 2208 return s;
2209 }
463ee0b2
LW		 2210}
2211
7340a771
GS		 2212char *
2213Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2214{
560a288e
GS		 2215 STRLEN n_a;
2216 return sv_2pvbyte(sv, &n_a);
7340a771
GS		 2217}
2218
2219char *
2220Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2221{
2222 return sv_2pv(sv,lp);
2223}
2224
2225char *
2226Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2227{
560a288e
GS		 2228 STRLEN n_a;
2229 return sv_2pvutf8(sv, &n_a);
7340a771
GS		 2230}
2231
2232char *
2233Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2234{
560a288e 2235 sv_utf8_upgrade(sv);
7340a771
GS		 2236 return sv_2pv(sv,lp);
2237}
2238
463ee0b2
LW		 2239/* This function is only called on magical items */
2240bool
864dbfa3 2241Perl_sv_2bool(pTHX_ register SV *sv)
463ee0b2 2242{
8990e307 2243 if (SvGMAGICAL(sv))
463ee0b2
LW		 2244 mg_get(sv);
2245
a0d0e21e
LW		 2246 if (!SvOK(sv))
2247 return 0;
2248 if (SvROK(sv)) {
11343788 2249 dTHR;
a0d0e21e
LW		 2250 SV* tmpsv;
2251 if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
9e7bc3e8 2252 return SvTRUE(tmpsv);
a0d0e21e
LW		 2253 return SvRV(sv) != 0;
2254 }
463ee0b2 2255 if (SvPOKp(sv)) {
11343788
MB		 2256 register XPV* Xpvtmp;
2257 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2258 (*Xpvtmp->xpv_pv > '0' ||
2259 Xpvtmp->xpv_cur > 1 ||
2260 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
463ee0b2
LW		 2261 return 1;
2262 else
2263 return 0;
2264 }
2265 else {
2266 if (SvIOKp(sv))
2267 return SvIVX(sv) != 0;
2268 else {
2269 if (SvNOKp(sv))
2270 return SvNVX(sv) != 0.0;
2271 else
2272 return FALSE;
2273 }
2274 }
79072805
LW		 2275}
2276
560a288e
GS		 2277void
2278Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2279{
2280 int hicount;
2281 char *c;
2282
2283 if (!sv || !SvPOK(sv) || SvUTF8(sv))
2284 return;
2285
2286 /* This function could be much more efficient if we had a FLAG
2287 * to signal if there are any hibit chars in the string
2288 */
2289 hicount = 0;
2290 for (c = SvPVX(sv); c < SvEND(sv); c++) {
2291 if (*c & 0x80)
2292 hicount++;
2293 }
2294
2295 if (hicount) {
2296 char *src, *dst;
2297 SvGROW(sv, SvCUR(sv) + hicount + 1);
2298
2299 src = SvEND(sv) - 1;
2300 SvCUR_set(sv, SvCUR(sv) + hicount);
2301 dst = SvEND(sv) - 1;
2302
2303 while (src < dst) {
2304 if (*src & 0x80) {
2305 dst--;
2306 uv_to_utf8((U8*)dst, (U8)*src--);
2307 dst--;
2308 }
2309 else {
2310 *dst-- = *src--;
2311 }
2312 }
2313
2314 SvUTF8_on(sv);
2315 }
2316}
2317
2318bool
2319Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
2320{
2321 if (SvPOK(sv) && SvUTF8(sv)) {
2322 char *c = SvPVX(sv);
2323 char *first_hi = 0;
2324 /* need to figure out if this is possible at all first */
2325 while (c < SvEND(sv)) {
2326 if (*c & 0x80) {
2327 I32 len;
ce32ed4b 2328 UV uv = utf8_to_uv((U8*)c, &len);
560a288e
GS		 2329 if (uv >= 256) {
2330 if (fail_ok)
2331 return FALSE;
2332 else {
2333 /* XXX might want to make a callback here instead */
9a54186f 2334 Perl_croak(aTHX_ "Big byte");
560a288e
GS		 2335 }
2336 }
2337 if (!first_hi)
2338 first_hi = c;
2339 c += len;
2340 }
2341 else {
2342 c++;
2343 }
2344 }
2345
2346 if (first_hi) {
2347 char *src = first_hi;
2348 char *dst = first_hi;
2349 while (src < SvEND(sv)) {
2350 if (*src & 0x80) {
2351 I32 len;
ce32ed4b 2352 U8 u = (U8)utf8_to_uv((U8*)src, &len);
560a288e
GS		 2353 *dst++ = u;
2354 src += len;
2355 }
2356 else {
2357 *dst++ = *src++;
2358 }
2359 }
2360 SvCUR_set(sv, dst - SvPVX(sv));
2361 }
2362 SvUTF8_off(sv);
2363 }
2364 return TRUE;
2365}
2366
2367void
2368Perl_sv_utf8_encode(pTHX_ register SV *sv)
2369{
2370 sv_utf8_upgrade(sv);
2371 SvUTF8_off(sv);
2372}
2373
2374bool
2375Perl_sv_utf8_decode(pTHX_ register SV *sv)
2376{
2377 if (SvPOK(sv)) {
2378 char *c;
2379 bool has_utf = FALSE;
2380 if (!sv_utf8_downgrade(sv, TRUE))
2381 return FALSE;
2382
2383 /* it is actually just a matter of turning the utf8 flag on, but
2384 * we want to make sure everything inside is valid utf8 first.
2385 */
2386 c = SvPVX(sv);
2387 while (c < SvEND(sv)) {
2388 if (*c & 0x80) {
2389 I32 len;
2390 (void)utf8_to_uv((U8*)c, &len);
2391 if (len == 1) {
2392 /* bad utf8 */
2393 return FALSE;
2394 }
2395 c += len;
2396 has_utf = TRUE;
2397 }
2398 else {
2399 c++;
2400 }
2401 }
2402
2403 if (has_utf)
2404 SvUTF8_on(sv);
2405 }
2406 return TRUE;
2407}
2408
2409
79072805 2410/* Note: sv_setsv() should not be called with a source string that needs
463ee0b2 2411 * to be reused, since it may destroy the source string if it is marked
79072805
LW		 2412 * as temporary.
2413 */
2414
954c1994
GS		 2415/*
2416=for apidoc sv_setsv
2417
2418Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
2419The source SV may be destroyed if it is mortal. Does not handle 'set'
2420magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
2421C<sv_setsv_mg>.
2422
2423=cut
2424*/
2425
79072805 2426void
864dbfa3 2427Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
79072805 2428{
11343788 2429 dTHR;
8990e307
LW		 2430 register U32 sflags;
2431 register int dtype;
2432 register int stype;
463ee0b2 2433
79072805
LW		 2434 if (sstr == dstr)
2435 return;
2213622d 2436 SV_CHECK_THINKFIRST(dstr);
79072805 2437 if (!sstr)
3280af22 2438 sstr = &PL_sv_undef;
8990e307
LW		 2439 stype = SvTYPE(sstr);
2440 dtype = SvTYPE(dstr);
79072805 2441
a0d0e21e 2442 SvAMAGIC_off(dstr);
9e7bc3e8 2443
463ee0b2 2444 /* There's a lot of redundancy below but we're going for speed here */
79072805 2445
8990e307 2446 switch (stype) {
79072805 2447 case SVt_NULL:
aece5585 2448 undef_sstr:
20408e3c
GS		 2449 if (dtype != SVt_PVGV) {
2450 (void)SvOK_off(dstr);
2451 return;
2452 }
2453 break;
463ee0b2 2454 case SVt_IV:
aece5585
GA		 2455 if (SvIOK(sstr)) {
2456 switch (dtype) {
2457 case SVt_NULL:
8990e307 2458 sv_upgrade(dstr, SVt_IV);
aece5585
GA		 2459 break;
2460 case SVt_NV:
8990e307 2461 sv_upgrade(dstr, SVt_PVNV);
aece5585
GA		 2462 break;
2463 case SVt_RV:
2464 case SVt_PV:
a0d0e21e 2465 sv_upgrade(dstr, SVt_PVIV);
aece5585
GA		 2466 break;
2467 }
2468 (void)SvIOK_only(dstr);
2469 SvIVX(dstr) = SvIVX(sstr);
25da4f38
IZ		 2470 if (SvIsUV(sstr))
2471 SvIsUV_on(dstr);
aece5585
GA		 2472 SvTAINT(dstr);
2473 return;
8990e307 2474 }
aece5585
GA		 2475 goto undef_sstr;
2476
463ee0b2 2477 case SVt_NV:
aece5585
GA		 2478 if (SvNOK(sstr)) {
2479 switch (dtype) {
2480 case SVt_NULL:
2481 case SVt_IV:
8990e307 2482 sv_upgrade(dstr, SVt_NV);
aece5585
GA		 2483 break;
2484 case SVt_RV:
2485 case SVt_PV:
2486 case SVt_PVIV:
a0d0e21e 2487 sv_upgrade(dstr, SVt_PVNV);
aece5585
GA		 2488 break;
2489 }
2490 SvNVX(dstr) = SvNVX(sstr);
2491 (void)SvNOK_only(dstr);
2492 SvTAINT(dstr);
2493 return;
8990e307 2494 }
aece5585
GA		 2495 goto undef_sstr;
2496
ed6116ce 2497 case SVt_RV:
8990e307 2498 if (dtype < SVt_RV)
ed6116ce 2499 sv_upgrade(dstr, SVt_RV);
c07a80fd 2500 else if (dtype == SVt_PVGV &&
2501 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2502 sstr = SvRV(sstr);
a5f75d66 2503 if (sstr == dstr) {
1d7c1841
GS		 2504 if (GvIMPORTED(dstr) != GVf_IMPORTED
2505 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2506 {
a5f75d66 2507 GvIMPORTED_on(dstr);
1d7c1841 2508 }
a5f75d66
AD		 2509 GvMULTI_on(dstr);
2510 return;
2511 }
c07a80fd 2512 goto glob_assign;
2513 }
ed6116ce 2514 break;
463ee0b2 2515 case SVt_PV:
fc36a67e 2516 case SVt_PVFM:
8990e307 2517 if (dtype < SVt_PV)
463ee0b2 2518 sv_upgrade(dstr, SVt_PV);
463ee0b2
LW		 2519 break;
2520 case SVt_PVIV:
8990e307 2521 if (dtype < SVt_PVIV)
463ee0b2 2522 sv_upgrade(dstr, SVt_PVIV);
463ee0b2
LW		 2523 break;
2524 case SVt_PVNV:
8990e307 2525 if (dtype < SVt_PVNV)
463ee0b2 2526 sv_upgrade(dstr, SVt_PVNV);
463ee0b2 2527 break;
4633a7c4
LW		 2528 case SVt_PVAV:
2529 case SVt_PVHV:
2530 case SVt_PVCV:
4633a7c4 2531 case SVt_PVIO:
533c011a 2532 if (PL_op)
cea2e8a9 2533 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
22c35a8c 2534 PL_op_name[PL_op->op_type]);
4633a7c4 2535 else
cea2e8a9 2536 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
4633a7c4
LW		 2537 break;
2538
79072805 2539 case SVt_PVGV:
8990e307 2540 if (dtype <= SVt_PVGV) {
c07a80fd 2541 glob_assign:
a5f75d66 2542 if (dtype != SVt_PVGV) {
a0d0e21e
LW		 2543 char *name = GvNAME(sstr);
2544 STRLEN len = GvNAMELEN(sstr);
463ee0b2 2545 sv_upgrade(dstr, SVt_PVGV);
a0d0e21e 2546 sv_magic(dstr, dstr, '*', name, len);
85aff577 2547 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
a0d0e21e
LW		 2548 GvNAME(dstr) = savepvn(name, len);
2549 GvNAMELEN(dstr) = len;
2550 SvFAKE_on(dstr); /* can coerce to non-glob */
2551 }
7bac28a0 2552 /* ahem, death to those who redefine active sort subs */
3280af22
NIS		 2553 else if (PL_curstackinfo->si_type == PERLSI_SORT
2554 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
cea2e8a9 2555 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
7bac28a0 2556 GvNAME(dstr));
a0d0e21e 2557 (void)SvOK_off(dstr);
a5f75d66 2558 GvINTRO_off(dstr); /* one-shot flag */
1edc1566 2559 gp_free((GV*)dstr);
79072805 2560 GvGP(dstr) = gp_ref(GvGP(sstr));
8990e307 2561 SvTAINT(dstr);
1d7c1841
GS		 2562 if (GvIMPORTED(dstr) != GVf_IMPORTED
2563 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2564 {
a5f75d66 2565 GvIMPORTED_on(dstr);
1d7c1841 2566 }
a5f75d66 2567 GvMULTI_on(dstr);
79072805
LW		 2568 return;
2569 }
2570 /* FALL THROUGH */
2571
2572 default:
973f89ab
CS		 2573 if (SvGMAGICAL(sstr)) {
2574 mg_get(sstr);
2575 if (SvTYPE(sstr) != stype) {
2576 stype = SvTYPE(sstr);
2577 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2578 goto glob_assign;
2579 }
2580 }
ded42b9f 2581 if (stype == SVt_PVLV)
6fc92669 2582 (void)SvUPGRADE(dstr, SVt_PVNV);
ded42b9f 2583 else
6fc92669 2584 (void)SvUPGRADE(dstr, stype);
79072805
LW		 2585 }
2586
8990e307
LW		 2587 sflags = SvFLAGS(sstr);
2588
2589 if (sflags & SVf_ROK) {
2590 if (dtype >= SVt_PV) {
2591 if (dtype == SVt_PVGV) {
2592 SV *sref = SvREFCNT_inc(SvRV(sstr));
2593 SV *dref = 0;
a5f75d66 2594 int intro = GvINTRO(dstr);
a0d0e21e
LW		 2595
2596 if (intro) {
2597 GP *gp;
1d7c1841 2598 gp_free((GV*)dstr);
a5f75d66 2599 GvINTRO_off(dstr); /* one-shot flag */
a0d0e21e 2600 Newz(602,gp, 1, GP);
44a8e56a 2601 GvGP(dstr) = gp_ref(gp);
a0d0e21e 2602 GvSV(dstr) = NEWSV(72,0);
1d7c1841 2603 GvLINE(dstr) = CopLINE(PL_curcop);
1edc1566 2604 GvEGV(dstr) = (GV*)dstr;
a0d0e21e 2605 }
a5f75d66 2606 GvMULTI_on(dstr);
8990e307
LW		 2607 switch (SvTYPE(sref)) {
2608 case SVt_PVAV:
a0d0e21e
LW		 2609 if (intro)
2610 SAVESPTR(GvAV(dstr));
2611 else
2612 dref = (SV*)GvAV(dstr);
8990e307 2613 GvAV(dstr) = (AV*)sref;
39bac7f7 2614 if (!GvIMPORTED_AV(dstr)
1d7c1841
GS		 2615 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2616 {
a5f75d66 2617 GvIMPORTED_AV_on(dstr);
1d7c1841 2618 }
8990e307
LW		 2619 break;
2620 case SVt_PVHV:
a0d0e21e
LW		 2621 if (intro)
2622 SAVESPTR(GvHV(dstr));
2623 else
2624 dref = (SV*)GvHV(dstr);
8990e307 2625 GvHV(dstr) = (HV*)sref;
39bac7f7 2626 if (!GvIMPORTED_HV(dstr)
1d7c1841
GS		 2627 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2628 {
a5f75d66 2629 GvIMPORTED_HV_on(dstr);
1d7c1841 2630 }
8990e307
LW		 2631 break;
2632 case SVt_PVCV:
8ebc5c01 2633 if (intro) {
2634 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2635 SvREFCNT_dec(GvCV(dstr));
2636 GvCV(dstr) = Nullcv;
68dc0745 2637 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3280af22 2638 PL_sub_generation++;
8ebc5c01 2639 }
a0d0e21e 2640 SAVESPTR(GvCV(dstr));
8ebc5c01 2641 }
68dc0745 2642 else
2643 dref = (SV*)GvCV(dstr);
2644 if (GvCV(dstr) != (CV*)sref) {
748a9306 2645 CV* cv = GvCV(dstr);
4633a7c4 2646 if (cv) {
68dc0745 2647 if (!GvCVGEN((GV*)dstr) &&
2648 (CvROOT(cv) || CvXSUB(cv)))
2649 {
fe5e78ed
GS		 2650 SV *const_sv = cv_const_sv(cv);
2651 bool const_changed = TRUE;
2652 if(const_sv)
2653 const_changed = sv_cmp(const_sv,
2654 op_const_sv(CvSTART((CV*)sref),
2655 Nullcv));
7bac28a0 2656 /* ahem, death to those who redefine
2657 * active sort subs */
3280af22
NIS		 2658 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2659 PL_sortcop == CvSTART(cv))
cea2e8a9 2660 Perl_croak(aTHX_
7bac28a0 2661 "Can't redefine active sort subroutine %s",
2662 GvENAME((GV*)dstr));
e476b1b5
GS		 2663 if ((const_changed || const_sv) && ckWARN(WARN_REDEFINE))
2664 Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
fe5e78ed
GS		 2665 "Constant subroutine %s redefined"
2666 : "Subroutine %s redefined",
2f34f9d4 2667 GvENAME((GV*)dstr));
9607fc9c 2668 }
3fe9a6f1 2669 cv_ckproto(cv, (GV*)dstr,
2670 SvPOK(sref) ? SvPVX(sref) : Nullch);
4633a7c4 2671 }
a5f75d66 2672 GvCV(dstr) = (CV*)sref;
7a4c00b4 2673 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
a5f75d66 2674 GvASSUMECV_on(dstr);
3280af22 2675 PL_sub_generation++;
a5f75d66 2676 }
39bac7f7 2677 if (!GvIMPORTED_CV(dstr)
1d7c1841
GS		 2678 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2679 {
a5f75d66 2680 GvIMPORTED_CV_on(dstr);
1d7c1841 2681 }
8990e307 2682 break;
91bba347
LW		 2683 case SVt_PVIO:
2684 if (intro)
2685 SAVESPTR(GvIOp(dstr));
2686 else
2687 dref = (SV*)GvIOp(dstr);
2688 GvIOp(dstr) = (IO*)sref;
2689 break;
8990e307 2690 default:
a0d0e21e
LW		 2691 if (intro)
2692 SAVESPTR(GvSV(dstr));
2693 else
2694 dref = (SV*)GvSV(dstr);
8990e307 2695 GvSV(dstr) = sref;
39bac7f7 2696 if (!GvIMPORTED_SV(dstr)
1d7c1841
GS		 2697 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2698 {
a5f75d66 2699 GvIMPORTED_SV_on(dstr);
1d7c1841 2700 }
8990e307
LW		 2701 break;
2702 }
2703 if (dref)
2704 SvREFCNT_dec(dref);
a0d0e21e
LW		 2705 if (intro)
2706 SAVEFREESV(sref);
8990e307
LW		 2707 SvTAINT(dstr);
2708 return;
2709 }
a0d0e21e 2710 if (SvPVX(dstr)) {
760ac839 2711 (void)SvOOK_off(dstr); /* backoff */
50483b2c
JD		 2712 if (SvLEN(dstr))
2713 Safefree(SvPVX(dstr));
a0d0e21e
LW		 2714 SvLEN(dstr)=SvCUR(dstr)=0;
2715 }
8990e307 2716 }
a0d0e21e 2717 (void)SvOK_off(dstr);
8990e307 2718 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
ed6116ce 2719 SvROK_on(dstr);
8990e307 2720 if (sflags & SVp_NOK) {
ed6116ce
LW		 2721 SvNOK_on(dstr);
2722 SvNVX(dstr) = SvNVX(sstr);
2723 }
8990e307 2724 if (sflags & SVp_IOK) {
a0d0e21e 2725 (void)SvIOK_on(dstr);
ed6116ce 2726 SvIVX(dstr) = SvIVX(sstr);
25da4f38
IZ		 2727 if (SvIsUV(sstr))
2728 SvIsUV_on(dstr);
ed6116ce 2729 }
a0d0e21e
LW		 2730 if (SvAMAGIC(sstr)) {
2731 SvAMAGIC_on(dstr);
2732 }
ed6116ce 2733 }
8990e307 2734 else if (sflags & SVp_POK) {
79072805
LW		 2735
2736 /*
2737 * Check to see if we can just swipe the string. If so, it's a
2738 * possible small lose on short strings, but a big win on long ones.
463ee0b2
LW		 2739 * It might even be a win on short strings if SvPVX(dstr)
2740 * has to be allocated and SvPVX(sstr) has to be freed.
79072805
LW		 2741 */
2742
ff68c719 2743 if (SvTEMP(sstr) && /* slated for free anyway? */
01b73108 2744 SvREFCNT(sstr) == 1 && /* and no other references to it? */
a5f75d66
AD		 2745 !(sflags & SVf_OOK)) /* and not involved in OOK hack? */
2746 {
adbc6bb1 2747 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
a5f75d66
AD		 2748 if (SvOOK(dstr)) {
2749 SvFLAGS(dstr) &= ~SVf_OOK;
2750 Safefree(SvPVX(dstr) - SvIVX(dstr));
2751 }
50483b2c 2752 else if (SvLEN(dstr))
a5f75d66 2753 Safefree(SvPVX(dstr));
79072805 2754 }
a5f75d66 2755 (void)SvPOK_only(dstr);
463ee0b2 2756 SvPV_set(dstr, SvPVX(sstr));
79072805
LW		 2757 SvLEN_set(dstr, SvLEN(sstr));
2758 SvCUR_set(dstr, SvCUR(sstr));
f4e86e0f
GS		 2759 if (SvUTF8(sstr))
2760 SvUTF8_on(dstr);
2761 else
2762 SvUTF8_off(dstr);
2763
79072805 2764 SvTEMP_off(dstr);
a5f75d66 2765 (void)SvOK_off(sstr);
79072805
LW		 2766 SvPV_set(sstr, Nullch);
2767 SvLEN_set(sstr, 0);
a5f75d66
AD		 2768 SvCUR_set(sstr, 0);
2769 SvTEMP_off(sstr);
79072805
LW		 2770 }
2771 else { /* have to copy actual string */
8990e307
LW		 2772 STRLEN len = SvCUR(sstr);
2773
2774 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2775 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2776 SvCUR_set(dstr, len);
2777 *SvEND(dstr) = '\0';
a0d0e21e 2778 (void)SvPOK_only(dstr);
79072805 2779 }
7e2040f0 2780 if (DO_UTF8(sstr))
a7cb1f99 2781 SvUTF8_on(dstr);
79072805 2782 /*SUPPRESS 560*/
8990e307 2783 if (sflags & SVp_NOK) {
79072805 2784 SvNOK_on(dstr);
463ee0b2 2785 SvNVX(dstr) = SvNVX(sstr);
79072805 2786 }
8990e307 2787 if (sflags & SVp_IOK) {
a0d0e21e 2788 (void)SvIOK_on(dstr);
463ee0b2 2789 SvIVX(dstr) = SvIVX(sstr);
25da4f38
IZ		 2790 if (SvIsUV(sstr))
2791 SvIsUV_on(dstr);
79072805
LW		 2792 }
2793 }
8990e307 2794 else if (sflags & SVp_NOK) {
463ee0b2 2795 SvNVX(dstr) = SvNVX(sstr);
a0d0e21e 2796 (void)SvNOK_only(dstr);
79072805 2797 if (SvIOK(sstr)) {
a0d0e21e 2798 (void)SvIOK_on(dstr);
463ee0b2 2799 SvIVX(dstr) = SvIVX(sstr);
25da4f38
IZ		 2800 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2801 if (SvIsUV(sstr))
2802 SvIsUV_on(dstr);
79072805
LW		 2803 }
2804 }
8990e307 2805 else if (sflags & SVp_IOK) {
a0d0e21e 2806 (void)SvIOK_only(dstr);
463ee0b2 2807 SvIVX(dstr) = SvIVX(sstr);
25da4f38
IZ		 2808 if (SvIsUV(sstr))
2809 SvIsUV_on(dstr);
79072805
LW		 2810 }
2811 else {
20408e3c 2812 if (dtype == SVt_PVGV) {
e476b1b5
GS		 2813 if (ckWARN(WARN_MISC))
2814 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
20408e3c
GS		 2815 }
2816 else
2817 (void)SvOK_off(dstr);
a0d0e21e 2818 }
463ee0b2 2819 SvTAINT(dstr);
79072805
LW		 2820}
2821
954c1994
GS		 2822/*
2823=for apidoc sv_setsv_mg
2824
2825Like C<sv_setsv>, but also handles 'set' magic.
2826
2827=cut
2828*/
2829
79072805 2830void
864dbfa3 2831Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
ef50df4b
GS		 2832{
2833 sv_setsv(dstr,sstr);
2834 SvSETMAGIC(dstr);
2835}
2836
954c1994
GS		 2837/*
2838=for apidoc sv_setpvn
2839
2840Copies a string into an SV. The C<len> parameter indicates the number of
2841bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
2842
2843=cut
2844*/
2845
ef50df4b 2846void
864dbfa3 2847Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
79072805 2848{
c6f8c383 2849 register char *dptr;
4561caa4
CS		 2850 assert(len >= 0); /* STRLEN is probably unsigned, so this may
2851 elicit a warning, but it won't hurt. */
2213622d 2852 SV_CHECK_THINKFIRST(sv);
463ee0b2 2853 if (!ptr) {
a0d0e21e 2854 (void)SvOK_off(sv);
463ee0b2
LW		 2855 return;
2856 }
6fc92669 2857 (void)SvUPGRADE(sv, SVt_PV);
c6f8c383 2858
79072805 2859 SvGROW(sv, len + 1);
c6f8c383
GA		 2860 dptr = SvPVX(sv);
2861 Move(ptr,dptr,len,char);
2862 dptr[len] = '\0';
79072805 2863 SvCUR_set(sv, len);
a0d0e21e 2864 (void)SvPOK_only(sv); /* validate pointer */
463ee0b2 2865 SvTAINT(sv);
79072805
LW		 2866}
2867
954c1994
GS		 2868/*
2869=for apidoc sv_setpvn_mg
2870
2871Like C<sv_setpvn>, but also handles 'set' magic.
2872
2873=cut
2874*/
2875
79072805 2876void
864dbfa3 2877Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
ef50df4b
GS		 2878{
2879 sv_setpvn(sv,ptr,len);
2880 SvSETMAGIC(sv);
2881}
2882
954c1994
GS		 2883/*
2884=for apidoc sv_setpv
2885
2886Copies a string into an SV. The string must be null-terminated. Does not
2887handle 'set' magic. See C<sv_setpv_mg>.
2888
2889=cut
2890*/
2891
ef50df4b 2892void
864dbfa3 2893Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
79072805
LW		 2894{
2895 register STRLEN len;
2896
2213622d 2897 SV_CHECK_THINKFIRST(sv);
463ee0b2 2898 if (!ptr) {
a0d0e21e 2899 (void)SvOK_off(sv);
463ee0b2
LW		 2900 return;
2901 }
79072805 2902 len = strlen(ptr);
6fc92669 2903 (void)SvUPGRADE(sv, SVt_PV);
c6f8c383 2904
79072805 2905 SvGROW(sv, len + 1);
463ee0b2 2906 Move(ptr,SvPVX(sv),len+1,char);
79072805 2907 SvCUR_set(sv, len);
a0d0e21e 2908 (void)SvPOK_only(sv); /* validate pointer */
463ee0b2
LW		 2909 SvTAINT(sv);
2910}
2911
954c1994
GS		 2912/*
2913=for apidoc sv_setpv_mg
2914
2915Like C<sv_setpv>, but also handles 'set' magic.
2916
2917=cut
2918*/
2919
463ee0b2 2920void
864dbfa3 2921Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
ef50df4b
GS		 2922{
2923 sv_setpv(sv,ptr);
2924 SvSETMAGIC(sv);
2925}
2926
954c1994
GS		 2927/*
2928=for apidoc sv_usepvn
2929
2930Tells an SV to use C<ptr> to find its string value. Normally the string is
2931stored inside the SV but sv_usepvn allows the SV to use an outside string.
2932The C<ptr> should point to memory that was allocated by C<malloc>. The
2933string length, C<len>, must be supplied. This function will realloc the
2934memory pointed to by C<ptr>, so that pointer should not be freed or used by
2935the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
2936See C<sv_usepvn_mg>.
2937
2938=cut
2939*/
2940
ef50df4b 2941void
864dbfa3 2942Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
463ee0b2 2943{
2213622d 2944 SV_CHECK_THINKFIRST(sv);
c6f8c383 2945 (void)SvUPGRADE(sv, SVt_PV);
463ee0b2 2946 if (!ptr) {
a0d0e21e 2947 (void)SvOK_off(sv);
463ee0b2
LW		 2948 return;
2949 }
a0ed51b3 2950 (void)SvOOK_off(sv);
50483b2c 2951 if (SvPVX(sv) && SvLEN(sv))
463ee0b2
LW		 2952 Safefree(SvPVX(sv));
2953 Renew(ptr, len+1, char);
2954 SvPVX(sv) = ptr;
2955 SvCUR_set(sv, len);
2956 SvLEN_set(sv, len+1);
2957 *SvEND(sv) = '\0';
a0d0e21e 2958 (void)SvPOK_only(sv); /* validate pointer */
463ee0b2 2959 SvTAINT(sv);
79072805
LW		 2960}
2961
954c1994
GS		 2962/*
2963=for apidoc sv_usepvn_mg
2964
2965Like C<sv_usepvn>, but also handles 'set' magic.
2966
2967=cut
2968*/
2969
ef50df4b 2970void
864dbfa3 2971Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
ef50df4b 2972{
51c1089b 2973 sv_usepvn(sv,ptr,len);
ef50df4b
GS		 2974 SvSETMAGIC(sv);
2975}
2976
6fc92669 2977void
864dbfa3 2978Perl_sv_force_normal(pTHX_ register SV *sv)
0f15f207 2979{
2213622d
GA		 2980 if (SvREADONLY(sv)) {
2981 dTHR;
3280af22 2982 if (PL_curcop != &PL_compiling)
cea2e8a9 2983 Perl_croak(aTHX_ PL_no_modify);
0f15f207 2984 }
2213622d
GA		 2985 if (SvROK(sv))
2986 sv_unref(sv);
6fc92669
GS		 2987 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2988 sv_unglob(sv);
0f15f207
MB		 2989}
2990
954c1994
GS		 2991/*
2992=for apidoc sv_chop
2993
2994Efficient removal of characters from the beginning of the string buffer.
2995SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
2996the string buffer. The C<ptr> becomes the first character of the adjusted
2997string.
2998
2999=cut
3000*/
3001
79072805 3002void
864dbfa3 3003Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
8ac85365
NIS		 3004
3005
79072805
LW		 3006{
3007 register STRLEN delta;
3008
a0d0e21e 3009 if (!ptr || !SvPOKp(sv))
79072805 3010 return;
2213622d 3011 SV_CHECK_THINKFIRST(sv);
79072805
LW		 3012 if (SvTYPE(sv) < SVt_PVIV)
3013 sv_upgrade(sv,SVt_PVIV);
3014
3015 if (!SvOOK(sv)) {
50483b2c
JD		 3016 if (!SvLEN(sv)) { /* make copy of shared string */
3017 char *pvx = SvPVX(sv);
3018 STRLEN len = SvCUR(sv);
3019 SvGROW(sv, len + 1);
3020 Move(pvx,SvPVX(sv),len,char);
3021 *SvEND(sv) = '\0';
3022 }
463ee0b2 3023 SvIVX(sv) = 0;
79072805
LW		 3024 SvFLAGS(sv) |= SVf_OOK;
3025 }
25da4f38 3026 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
463ee0b2 3027 delta = ptr - SvPVX(sv);
79072805
LW		 3028 SvLEN(sv) -= delta;
3029 SvCUR(sv) -= delta;
463ee0b2
LW		 3030 SvPVX(sv) += delta;
3031 SvIVX(sv) += delta;
79072805
LW		 3032}
3033
954c1994
GS		 3034/*
3035=for apidoc sv_catpvn
3036
3037Concatenates the string onto the end of the string which is in the SV. The
3038C<len> indicates number of bytes to copy. Handles 'get' magic, but not
3039'set' magic. See C<sv_catpvn_mg>.
3040
3041=cut
3042*/
3043
79072805 3044void
864dbfa3 3045Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
79072805 3046{
463ee0b2 3047 STRLEN tlen;
748a9306 3048 char *junk;
a0d0e21e 3049
748a9306 3050 junk = SvPV_force(sv, tlen);
463ee0b2 3051 SvGROW(sv, tlen + len + 1);
4633a7c4
LW		 3052 if (ptr == junk)
3053 ptr = SvPVX(sv);
463ee0b2 3054 Move(ptr,SvPVX(sv)+tlen,len,char);
79072805
LW		 3055 SvCUR(sv) += len;
3056 *SvEND(sv) = '\0';
d41ff1b8 3057 (void)SvPOK_only_UTF8(sv); /* validate pointer */
463ee0b2 3058 SvTAINT(sv);
79072805
LW		 3059}
3060
954c1994
GS		 3061/*
3062=for apidoc sv_catpvn_mg
3063
3064Like C<sv_catpvn>, but also handles 'set' magic.
3065
3066=cut
3067*/
3068
79072805 3069void
864dbfa3 3070Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
ef50df4b
GS		 3071{
3072 sv_catpvn(sv,ptr,len);
3073 SvSETMAGIC(sv);
3074}
3075
954c1994
GS		 3076/*
3077=for apidoc sv_catsv
3078
3079Concatenates the string from SV C<ssv> onto the end of the string in SV
3080C<dsv>. Handles 'get' magic, but not 'set' magic. See C<sv_catsv_mg>.
3081
3082=cut
3083*/
3084
ef50df4b 3085void
864dbfa3 3086Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
79072805
LW		 3087{
3088 char *s;
463ee0b2 3089 STRLEN len;
79072805
LW		 3090 if (!sstr)
3091 return;
155aba94 3092 if ((s = SvPV(sstr, len))) {
560a288e
GS		 3093 if (SvUTF8(sstr))
3094 sv_utf8_upgrade(dstr);
463ee0b2 3095 sv_catpvn(dstr,s,len);
560a288e
GS		 3096 if (SvUTF8(sstr))
3097 SvUTF8_on(dstr);
3098 }
79072805
LW		 3099}
3100
954c1994
GS		 3101/*
3102=for apidoc sv_catsv_mg
3103
3104Like C<sv_catsv>, but also handles 'set' magic.
3105
3106=cut
3107*/
3108
79072805 3109void
864dbfa3 3110Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
ef50df4b
GS		 3111{
3112 sv_catsv(dstr,sstr);
3113 SvSETMAGIC(dstr);
3114}
3115
954c1994
GS		 3116/*
3117=for apidoc sv_catpv
3118
3119Concatenates the string onto the end of the string which is in the SV.
3120Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3121
3122=cut
3123*/
3124
ef50df4b 3125void
864dbfa3 3126Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
79072805
LW		 3127{
3128 register STRLEN len;
463ee0b2 3129 STRLEN tlen;
748a9306 3130 char *junk;
79072805 3131
79072805
LW		 3132 if (!ptr)
3133 return;
748a9306 3134 junk = SvPV_force(sv, tlen);
79072805 3135 len = strlen(ptr);
463ee0b2 3136 SvGROW(sv, tlen + len + 1);
4633a7c4
LW		 3137 if (ptr == junk)
3138 ptr = SvPVX(sv);
463ee0b2 3139 Move(ptr,SvPVX(sv)+tlen,len+1,char);
79072805 3140 SvCUR(sv) += len;
d41ff1b8 3141 (void)SvPOK_only_UTF8(sv); /* validate pointer */
463ee0b2 3142 SvTAINT(sv);
79072805
LW		 3143}
3144
954c1994
GS		 3145/*
3146=for apidoc sv_catpv_mg
3147
3148Like C<sv_catpv>, but also handles 'set' magic.
3149
3150=cut
3151*/
3152
ef50df4b 3153void
864dbfa3 3154Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
ef50df4b 3155{
51c1089b 3156 sv_catpv(sv,ptr);
ef50df4b
GS		 3157 SvSETMAGIC(sv);
3158}
3159
79072805 3160SV *
864dbfa3 3161Perl_newSV(pTHX_ STRLEN len)
79072805
LW		 3162{
3163 register SV *sv;
3164
4561caa4 3165 new_SV(sv);
79072805
LW		 3166 if (len) {
3167 sv_upgrade(sv, SVt_PV);
3168 SvGROW(sv, len + 1);
3169 }
3170 return sv;
3171}
3172
1edc1566 3173/* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3174
954c1994
GS		 3175/*
3176=for apidoc sv_magic
3177
3178Adds magic to an SV.
3179
3180=cut
3181*/
3182
79072805 3183void
864dbfa3 3184Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
79072805
LW		 3185{
3186 MAGIC* mg;
3187
0f15f207
MB		 3188 if (SvREADONLY(sv)) {
3189 dTHR;
3280af22 3190 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
cea2e8a9 3191 Perl_croak(aTHX_ PL_no_modify);
0f15f207 3192 }
4633a7c4 3193 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
748a9306
LW		 3194 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3195 if (how == 't')
565764a8 3196 mg->mg_len |= 1;
463ee0b2 3197 return;
748a9306 3198 }
463ee0b2
LW		 3199 }
3200 else {
c6f8c383 3201 (void)SvUPGRADE(sv, SVt_PVMG);
463ee0b2 3202 }
79072805
LW		 3203 Newz(702,mg, 1, MAGIC);
3204 mg->mg_moremagic = SvMAGIC(sv);
463ee0b2 3205
79072805 3206 SvMAGIC(sv) = mg;
c277df42 3207 if (!obj || obj == sv || how == '#' || how == 'r')
8990e307 3208 mg->mg_obj = obj;
85e6fe83 3209 else {
11343788 3210 dTHR;
8990e307 3211 mg->mg_obj = SvREFCNT_inc(obj);
85e6fe83
LW		 3212 mg->mg_flags |= MGf_REFCOUNTED;
3213 }
79072805 3214 mg->mg_type = how;
565764a8 3215 mg->mg_len = namlen;
1edc1566 3216 if (name)
3217 if (namlen >= 0)
3218 mg->mg_ptr = savepvn(name, namlen);
c6ee37c5 3219 else if (namlen == HEf_SVKEY)
1edc1566 3220 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
3221
79072805
LW		 3222 switch (how) {
3223 case 0:
22c35a8c 3224 mg->mg_virtual = &PL_vtbl_sv;
79072805 3225 break;
a0d0e21e 3226 case 'A':
22c35a8c 3227 mg->mg_virtual = &PL_vtbl_amagic;
a0d0e21e
LW		 3228 break;
3229 case 'a':
22c35a8c 3230 mg->mg_virtual = &PL_vtbl_amagicelem;
a0d0e21e
LW		 3231 break;
3232 case 'c':
3233 mg->mg_virtual = 0;
3234 break;
79072805 3235 case 'B':
22c35a8c 3236 mg->mg_virtual = &PL_vtbl_bm;
79072805 3237 break;
6cef1e77 3238 case 'D':
22c35a8c 3239 mg->mg_virtual = &PL_vtbl_regdata;
6cef1e77
IZ		 3240 break;
3241 case 'd':
22c35a8c 3242 mg->mg_virtual = &PL_vtbl_regdatum;
6cef1e77 3243 break;
79072805 3244 case 'E':
22c35a8c 3245 mg->mg_virtual = &PL_vtbl_env;
79072805 3246 break;
55497cff 3247 case 'f':
22c35a8c 3248 mg->mg_virtual = &PL_vtbl_fm;
55497cff 3249 break;
79072805 3250 case 'e':
22c35a8c 3251 mg->mg_virtual = &PL_vtbl_envelem;
79072805 3252 break;
93a17b20 3253 case 'g':
22c35a8c 3254 mg->mg_virtual = &PL_vtbl_mglob;
93a17b20 3255 break;
463ee0b2 3256 case 'I':
22c35a8c 3257 mg->mg_virtual = &PL_vtbl_isa;
463ee0b2
LW		 3258 break;
3259 case 'i':
22c35a8c 3260 mg->mg_virtual = &PL_vtbl_isaelem;
463ee0b2 3261 break;
16660edb 3262 case 'k':
22c35a8c 3263 mg->mg_virtual = &PL_vtbl_nkeys;
16660edb 3264 break;
79072805 3265 case 'L':
a0d0e21e 3266 SvRMAGICAL_on(sv);
93a17b20
LW		 3267 mg->mg_virtual = 0;
3268 break;
3269 case 'l':
22c35a8c 3270 mg->mg_virtual = &PL_vtbl_dbline;
79072805 3271 break;
f93b4edd
MB		 3272#ifdef USE_THREADS
3273 case 'm':
22c35a8c 3274 mg->mg_virtual = &PL_vtbl_mutex;
f93b4edd
MB		 3275 break;
3276#endif /* USE_THREADS */
36477c24 3277#ifdef USE_LOCALE_COLLATE
bbce6d69 3278 case 'o':
22c35a8c 3279 mg->mg_virtual = &PL_vtbl_collxfrm;
bbce6d69 3280 break;
36477c24 3281#endif /* USE_LOCALE_COLLATE */
463ee0b2 3282 case 'P':
22c35a8c 3283 mg->mg_virtual = &PL_vtbl_pack;
463ee0b2
LW		 3284 break;
3285 case 'p':
a0d0e21e 3286 case 'q':
22c35a8c 3287 mg->mg_virtual = &PL_vtbl_packelem;
463ee0b2 3288 break;
c277df42 3289 case 'r':
22c35a8c 3290 mg->mg_virtual = &PL_vtbl_regexp;
c277df42 3291 break;
79072805 3292 case 'S':
22c35a8c 3293 mg->mg_virtual = &PL_vtbl_sig;
79072805
LW		 3294 break;
3295 case 's':
22c35a8c 3296 mg->mg_virtual = &PL_vtbl_sigelem;
79072805 3297 break;
463ee0b2 3298 case 't':
22c35a8c 3299 mg->mg_virtual = &PL_vtbl_taint;
565764a8 3300 mg->mg_len = 1;
463ee0b2 3301 break;
79072805 3302 case 'U':
22c35a8c 3303 mg->mg_virtual = &PL_vtbl_uvar;
79072805
LW		 3304 break;
3305 case 'v':
22c35a8c 3306 mg->mg_virtual = &PL_vtbl_vec;
79072805
LW		 3307 break;
3308 case 'x':
22c35a8c 3309 mg->mg_virtual = &PL_vtbl_substr;
79072805 3310 break;
5f05dabc 3311 case 'y':
22c35a8c 3312 mg->mg_virtual = &PL_vtbl_defelem;
5f05dabc 3313 break;
79072805 3314 case '*':
22c35a8c 3315 mg->mg_virtual = &PL_vtbl_glob;
79072805
LW		 3316 break;
3317 case '#':
22c35a8c 3318 mg->mg_virtual = &PL_vtbl_arylen;
79072805 3319 break;
a0d0e21e 3320 case '.':
22c35a8c 3321 mg->mg_virtual = &PL_vtbl_pos;
a0d0e21e 3322 break;
810b8aa5
GS		 3323 case '<':
3324 mg->mg_virtual = &PL_vtbl_backref;
3325 break;
4633a7c4
LW		 3326 case '~': /* Reserved for use by extensions not perl internals. */
3327 /* Useful for attaching extension internal data to perl vars. */
3328 /* Note that multiple extensions may clash if magical scalars */
3329 /* etc holding private data from one are passed to another. */
3330 SvRMAGICAL_on(sv);
a0d0e21e 3331 break;
79072805 3332 default:
cea2e8a9 3333 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
463ee0b2 3334 }
8990e307
LW		 3335 mg_magical(sv);
3336 if (SvGMAGICAL(sv))
3337 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
463ee0b2
LW		 3338}
3339
3340int
864dbfa3 3341Perl_sv_unmagic(pTHX_ SV *sv, int type)
463ee0b2
LW		 3342{
3343 MAGIC* mg;
3344 MAGIC** mgp;
91bba347 3345 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
463ee0b2
LW		 3346 return 0;
3347 mgp = &SvMAGIC(sv);
3348 for (mg = *mgp; mg; mg = *mgp) {
3349 if (mg->mg_type == type) {
3350 MGVTBL* vtbl = mg->mg_virtual;
3351 *mgp = mg->mg_moremagic;
1d7c1841 3352 if (vtbl && vtbl->svt_free)
fc0dc3b3 3353 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
463ee0b2 3354 if (mg->mg_ptr && mg->mg_type != 'g')
565764a8 3355 if (mg->mg_len >= 0)
1edc1566 3356 Safefree(mg->mg_ptr);
565764a8 3357 else if (mg->mg_len == HEf_SVKEY)
1edc1566 3358 SvREFCNT_dec((SV*)mg->mg_ptr);
a0d0e21e
LW		 3359 if (mg->mg_flags & MGf_REFCOUNTED)
3360 SvREFCNT_dec(mg->mg_obj);
463ee0b2
LW		 3361 Safefree(mg);
3362 }
3363 else
3364 mgp = &mg->mg_moremagic;
79072805 3365 }
91bba347 3366 if (!SvMAGIC(sv)) {
463ee0b2 3367 SvMAGICAL_off(sv);
8990e307 3368 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
463ee0b2
LW		 3369 }
3370
3371 return 0;
79072805
LW		 3372}
3373
810b8aa5 3374SV *
864dbfa3 3375Perl_sv_rvweaken(pTHX_ SV *sv)
810b8aa5
GS		 3376{
3377 SV *tsv;
3378 if (!SvOK(sv)) /* let undefs pass */
3379 return sv;
3380 if (!SvROK(sv))
cea2e8a9 3381 Perl_croak(aTHX_ "Can't weaken a nonreference");
810b8aa5
GS		 3382 else if (SvWEAKREF(sv)) {
3383 dTHR;
3384 if (ckWARN(WARN_MISC))
cea2e8a9 3385 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
810b8aa5
GS		 3386 return sv;
3387 }
3388 tsv = SvRV(sv);
3389 sv_add_backref(tsv, sv);
3390 SvWEAKREF_on(sv);
3391 SvREFCNT_dec(tsv);
3392 return sv;
3393}
3394
3395STATIC void
cea2e8a9 3396S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
810b8aa5
GS		 3397{
3398 AV *av;
3399 MAGIC *mg;
3400 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
3401 av = (AV*)mg->mg_obj;
3402 else {
3403 av = newAV();
3404 sv_magic(tsv, (SV*)av, '<', NULL, 0);
3405 SvREFCNT_dec(av); /* for sv_magic */
3406 }
3407 av_push(av,sv);
3408}
3409
3410STATIC void
cea2e8a9 3411S_sv_del_backref(pTHX_ SV *sv)
810b8aa5
GS		 3412{
3413 AV *av;
3414 SV **svp;
3415 I32 i;
3416 SV *tsv = SvRV(sv);
3417 MAGIC *mg;
3418 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
cea2e8a9 3419 Perl_croak(aTHX_ "panic: del_backref");
810b8aa5
GS		 3420 av = (AV *)mg->mg_obj;
3421 svp = AvARRAY(av);
3422 i = AvFILLp(av);
3423 while (i >= 0) {
3424 if (svp[i] == sv) {
3425 svp[i] = &PL_sv_undef; /* XXX */
3426 }
3427 i--;
3428 }
3429}
3430
954c1994
GS		 3431/*
3432=for apidoc sv_insert
3433
3434Inserts a string at the specified offset/length within the SV. Similar to
3435the Perl substr() function.
3436
3437=cut
3438*/
3439
79072805 3440void
864dbfa3 3441Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
79072805
LW		 3442{
3443 register char *big;
3444 register char *mid;
3445 register char *midend;
3446 register char *bigend;
3447 register I32 i;
6ff81951
GS		 3448 STRLEN curlen;
3449
79072805 3450
8990e307 3451 if (!bigstr)
cea2e8a9 3452 Perl_croak(aTHX_ "Can't modify non-existent substring");
6ff81951
GS		 3453 SvPV_force(bigstr, curlen);
3454 if (offset + len > curlen) {
3455 SvGROW(bigstr, offset+len+1);
3456 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
3457 SvCUR_set(bigstr, offset+len);
3458 }
79072805 3459
69b47968 3460 SvTAINT(bigstr);
79072805
LW		 3461 i = littlelen - len;
3462 if (i > 0) { /* string might grow */
a0d0e21e 3463 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
79072805
LW		 3464 mid = big + offset + len;
3465 midend = bigend = big + SvCUR(bigstr);
3466 bigend += i;
3467 *bigend = '\0';
3468 while (midend > mid) /* shove everything down */
3469 *--bigend = *--midend;
3470 Move(little,big+offset,littlelen,char);
3471 SvCUR(bigstr) += i;
3472 SvSETMAGIC(bigstr);
3473 return;
3474 }
3475 else if (i == 0) {
463ee0b2 3476 Move(little,SvPVX(bigstr)+offset,len,char);
79072805
LW		 3477 SvSETMAGIC(bigstr);
3478 return;
3479 }
3480
463ee0b2 3481 big = SvPVX(bigstr);
79072805
LW		 3482 mid = big + offset;
3483 midend = mid + len;
3484 bigend = big + SvCUR(bigstr);
3485
3486 if (midend > bigend)
cea2e8a9 3487 Perl_croak(aTHX_ "panic: sv_insert");
79072805
LW		 3488
3489 if (mid - big > bigend - midend) { /* faster to shorten from end */
3490 if (littlelen) {
3491 Move(little, mid, littlelen,char);
3492 mid += littlelen;
3493 }
3494 i = bigend - midend;
3495 if (i > 0) {
3496 Move(midend, mid, i,char);
3497 mid += i;
3498 }
3499 *mid = '\0';
3500 SvCUR_set(bigstr, mid - big);
3501 }
3502 /*SUPPRESS 560*/
155aba94 3503 else if ((i = mid - big)) { /* faster from front */
79072805
LW		 3504 midend -= littlelen;
3505 mid = midend;
3506 sv_chop(bigstr,midend-i);
3507 big += i;
3508 while (i--)
3509 *--midend = *--big;
3510 if (littlelen)
3511 Move(little, mid, littlelen,char);
3512 }
3513 else if (littlelen) {
3514 midend -= littlelen;
3515 sv_chop(bigstr,midend);
3516 Move(little,midend,littlelen,char);
3517 }
3518 else {
3519 sv_chop(bigstr,midend);
3520 }
3521 SvSETMAGIC(bigstr);
3522}
3523
3524/* make sv point to what nstr did */
3525
3526void
864dbfa3 3527Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
79072805 3528{
0453d815 3529 dTHR;
79072805 3530 U32 refcnt = SvREFCNT(sv);
2213622d 3531 SV_CHECK_THINKFIRST(sv);
0453d815
PM		 3532 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
3533 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
93a17b20 3534 if (SvMAGICAL(sv)) {
a0d0e21e
LW		 3535 if (SvMAGICAL(nsv))
3536 mg_free(nsv);
3537 else
3538 sv_upgrade(nsv, SVt_PVMG);
93a17b20 3539 SvMAGIC(nsv) = SvMAGIC(sv);
a0d0e21e 3540 SvFLAGS(nsv) |= SvMAGICAL(sv);
93a17b20
LW		 3541 SvMAGICAL_off(sv);
3542 SvMAGIC(sv) = 0;
3543 }
79072805
LW		 3544 SvREFCNT(sv) = 0;
3545 sv_clear(sv);
477f5d66 3546 assert(!SvREFCNT(sv));
79072805
LW		 3547 StructCopy(nsv,sv,SV);
3548 SvREFCNT(sv) = refcnt;
1edc1566 3549 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
463ee0b2 3550 del_SV(nsv);
79072805
LW		 3551}
3552
3553void
864dbfa3 3554Perl_sv_clear(pTHX_ register SV *sv)
79072805 3555{
ec12f114 3556 HV* stash;
79072805
LW		 3557 assert(sv);
3558 assert(SvREFCNT(sv) == 0);
3559
ed6116ce 3560 if (SvOBJECT(sv)) {
e858de61 3561 dTHR;
3280af22 3562 if (PL_defstash) { /* Still have a symbol table? */
4e35701f 3563 djSP;
8ebc5c01 3564 GV* destructor;
837485b6 3565 SV tmpref;
a0d0e21e 3566
837485b6
GS		 3567 Zero(&tmpref, 1, SV);
3568 sv_upgrade(&tmpref, SVt_RV);
3569 SvROK_on(&tmpref);
3570 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
3571 SvREFCNT(&tmpref) = 1;
8ebc5c01 3572
4e8e7886
GS		 3573 do {
3574 stash = SvSTASH(sv);
3575 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3576 if (destructor) {
3577 ENTER;
e788e7d3 3578 PUSHSTACKi(PERLSI_DESTROY);
837485b6 3579 SvRV(&tmpref) = SvREFCNT_inc(sv);
4e8e7886
GS		 3580 EXTEND(SP, 2);
3581 PUSHMARK(SP);
837485b6 3582 PUSHs(&tmpref);
4e8e7886 3583 PUTBACK;
864dbfa3
GS		 3584 call_sv((SV*)GvCV(destructor),
3585 G_DISCARD|G_EVAL|G_KEEPERR);
4e8e7886 3586 SvREFCNT(sv)--;
d3acc0f7 3587 POPSTACK;
3095d977 3588 SPAGAIN;
4e8e7886
GS		 3589 LEAVE;
3590 }
3591 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
8ebc5c01 3592
837485b6 3593 del_XRV(SvANY(&tmpref));
6f44e0a4
JP		 3594
3595 if (SvREFCNT(sv)) {
3596 if (PL_in_clean_objs)
cea2e8a9 3597 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
6f44e0a4
JP		 3598 HvNAME(stash));
3599 /* DESTROY gave object new lease on life */
3600 return;
3601 }
a0d0e21e 3602 }
4e8e7886 3603
a0d0e21e 3604 if (SvOBJECT(sv)) {
4e8e7886 3605 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
a0d0e21e
LW		 3606 SvOBJECT_off(sv); /* Curse the object. */
3607 if (SvTYPE(sv) != SVt_PVIO)
3280af22 3608 --PL_sv_objcount; /* XXX Might want something more general */
a0d0e21e 3609 }
463ee0b2 3610 }
c07a80fd 3611 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
a0d0e21e 3612 mg_free(sv);
ec12f114 3613 stash = NULL;
79072805 3614 switch (SvTYPE(sv)) {
8990e307 3615 case SVt_PVIO:
df0bd2f4
GS		 3616 if (IoIFP(sv) &&
3617 IoIFP(sv) != PerlIO_stdin() &&
5f05dabc 3618 IoIFP(sv) != PerlIO_stdout() &&
3619 IoIFP(sv) != PerlIO_stderr())
93578b34 3620 {
f2b5be74 3621 io_close((IO*)sv, FALSE);
93578b34 3622 }
1d7c1841 3623 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
1236053a 3624 PerlDir_close(IoDIRP(sv));
1d7c1841 3625 IoDIRP(sv) = (DIR*)NULL;
8990e307
LW		 3626 Safefree(IoTOP_NAME(sv));
3627 Safefree(IoFMT_NAME(sv));
3628 Safefree(IoBOTTOM_NAME(sv));
a0d0e21e 3629 /* FALL THROUGH */
79072805 3630 case SVt_PVBM:
a0d0e21e 3631 goto freescalar;
79072805 3632 case SVt_PVCV:
748a9306 3633 case SVt_PVFM:
85e6fe83 3634 cv_undef((CV*)sv);
a0d0e21e 3635 goto freescalar;
79072805 3636 case SVt_PVHV:
85e6fe83 3637 hv_undef((HV*)sv);
a0d0e21e 3638 break;
79072805 3639 case SVt_PVAV:
85e6fe83 3640 av_undef((AV*)sv);
a0d0e21e 3641 break;
02270b4e
GS		 3642 case SVt_PVLV:
3643 SvREFCNT_dec(LvTARG(sv));
3644 goto freescalar;
a0d0e21e 3645 case SVt_PVGV:
1edc1566 3646 gp_free((GV*)sv);
a0d0e21e 3647 Safefree(GvNAME(sv));
ec12f114
JPC		 3648 /* cannot decrease stash refcount yet, as we might recursively delete
3649 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3650 of stash until current sv is completely gone.
3651 -- JohnPC, 27 Mar 1998 */
3652 stash = GvSTASH(sv);
a0d0e21e 3653 /* FALL THROUGH */
79072805 3654 case SVt_PVMG:
79072805
LW		 3655 case SVt_PVNV:
3656 case SVt_PVIV:
a0d0e21e
LW		 3657 freescalar:
3658 (void)SvOOK_off(sv);
79072805
LW		 3659 /* FALL THROUGH */
3660 case SVt_PV:
a0d0e21e 3661 case SVt_RV:
810b8aa5
GS		 3662 if (SvROK(sv)) {
3663 if (SvWEAKREF(sv))
3664 sv_del_backref(sv);
3665 else
3666 SvREFCNT_dec(SvRV(sv));
3667 }
1edc1566 3668 else if (SvPVX(sv) && SvLEN(sv))
463ee0b2 3669 Safefree(SvPVX(sv));
79072805 3670 break;
a0d0e21e 3671/*
79072805 3672 case SVt_NV:
79072805 3673 case SVt_IV:
79072805
LW		 3674 case SVt_NULL:
3675 break;
a0d0e21e 3676*/
79072805
LW		 3677 }
3678
3679 switch (SvTYPE(sv)) {
3680 case SVt_NULL:
3681 break;
79072805
LW		 3682 case SVt_IV:
3683 del_XIV(SvANY(sv));
3684 break;
3685 case SVt_NV:
3686 del_XNV(SvANY(sv));
3687 break;
ed6116ce
LW		 3688 case SVt_RV:
3689 del_XRV(SvANY(sv));
3690 break;
79072805
LW		 3691 case SVt_PV:
3692 del_XPV(SvANY(sv));
3693 break;
3694 case SVt_PVIV:
3695 del_XPVIV(SvANY(sv));
3696 break;
3697 case SVt_PVNV:
3698 del_XPVNV(SvANY(sv));
3699 break;
3700 case SVt_PVMG:
3701 del_XPVMG(SvANY(sv));
3702 break;
3703 case SVt_PVLV:
3704 del_XPVLV(SvANY(sv));
3705 break;
3706 case SVt_PVAV:
3707 del_XPVAV(SvANY(sv));
3708 break;
3709 case SVt_PVHV:
3710 del_XPVHV(SvANY(sv));
3711 break;
3712 case SVt_PVCV:
3713 del_XPVCV(SvANY(sv));
3714 break;
3715 case SVt_PVGV:
3716 del_XPVGV(SvANY(sv));
ec12f114
JPC		 3717 /* code duplication for increased performance. */
3718 SvFLAGS(sv) &= SVf_BREAK;
3719 SvFLAGS(sv) |= SVTYPEMASK;
3720 /* decrease refcount of the stash that owns this GV, if any */
3721 if (stash)
3722 SvREFCNT_dec(stash);
3723 return; /* not break, SvFLAGS reset already happened */
79072805
LW		 3724 case SVt_PVBM:
3725 del_XPVBM(SvANY(sv));
3726 break;
3727 case SVt_PVFM:
3728 del_XPVFM(SvANY(sv));
3729 break;
8990e307
LW		 3730 case SVt_PVIO:
3731 del_XPVIO(SvANY(sv));
3732 break;
79072805 3733 }
a0d0e21e 3734 SvFLAGS(sv) &= SVf_BREAK;
8990e307 3735 SvFLAGS(sv) |= SVTYPEMASK;
79072805
LW		 3736}
3737
3738SV *
864dbfa3 3739Perl_sv_newref(pTHX_ SV *sv)
79072805 3740{
463ee0b2 3741 if (sv)
dce16143 3742 ATOMIC_INC(SvREFCNT(sv));
79072805
LW		 3743 return sv;
3744}
3745
3746void
864dbfa3 3747Perl_sv_free(pTHX_ SV *sv)
79072805 3748{
0453d815 3749 dTHR;
dce16143
MB		 3750 int refcount_is_zero;
3751
79072805
LW		 3752 if (!sv)
3753 return;
a0d0e21e
LW		 3754 if (SvREFCNT(sv) == 0) {
3755 if (SvFLAGS(sv) & SVf_BREAK)
3756 return;
3280af22 3757 if (PL_in_clean_all) /* All is fair */
1edc1566 3758 return;
d689ffdd
JP		 3759 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3760 /* make sure SvREFCNT(sv)==0 happens very seldom */
3761 SvREFCNT(sv) = (~(U32)0)/2;
3762 return;
3763 }
0453d815
PM		 3764 if (ckWARN_d(WARN_INTERNAL))
3765 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
79072805
LW		 3766 return;
3767 }
dce16143
MB		 3768 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3769 if (!refcount_is_zero)
8990e307 3770 return;
463ee0b2
LW		 3771#ifdef DEBUGGING
3772 if (SvTEMP(sv)) {
0453d815 3773 if (ckWARN_d(WARN_DEBUGGING))
f248d071 3774 Perl_warner(aTHX_ WARN_DEBUGGING,
1d7c1841
GS		 3775 "Attempt to free temp prematurely: SV 0x%"UVxf,
3776 PTR2UV(sv));
79072805 3777 return;
79072805 3778 }
463ee0b2 3779#endif
d689ffdd
JP		 3780 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3781 /* make sure SvREFCNT(sv)==0 happens very seldom */
3782 SvREFCNT(sv) = (~(U32)0)/2;
3783 return;
3784 }
79072805 3785 sv_clear(sv);
477f5d66
CS		 3786 if (! SvREFCNT(sv))
3787 del_SV(sv);
79072805
LW		 3788}
3789
954c1994
GS		 3790/*
3791=for apidoc sv_len
3792
3793Returns the length of the string in the SV. See also C<SvCUR>.
3794
3795=cut
3796*/
3797
79072805 3798STRLEN
864dbfa3 3799Perl_sv_len(pTHX_ register SV *sv)
79072805 3800{
748a9306 3801 char *junk;
463ee0b2 3802 STRLEN len;
79072805
LW		 3803
3804 if (!sv)
3805 return 0;
3806
8990e307 3807 if (SvGMAGICAL(sv))
565764a8 3808 len = mg_length(sv);
8990e307 3809 else
748a9306 3810 junk = SvPV(sv, len);
463ee0b2 3811 return len;
79072805
LW		 3812}
3813
a0ed51b3 3814STRLEN
864dbfa3 3815Perl_sv_len_utf8(pTHX_ register SV *sv)
a0ed51b3 3816{
dfe13c55
GS		 3817 U8 *s;
3818 U8 *send;
a0ed51b3
LW		 3819 STRLEN len;
3820
3821 if (!sv)
3822 return 0;
3823
3824#ifdef NOTYET
3825 if (SvGMAGICAL(sv))
3826 len = mg_length(sv);
3827 else
3828#endif
dfe13c55 3829 s = (U8*)SvPV(sv, len);
a0ed51b3
LW		 3830 send = s + len;
3831 len = 0;
3832 while (s < send) {
3833 s += UTF8SKIP(s);
3834 len++;
3835 }
3836 return len;
3837}
3838
3839void
864dbfa3 3840Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
a0ed51b3 3841{
dfe13c55
GS		 3842 U8 *start;
3843 U8 *s;
3844 U8 *send;
a0ed51b3
LW		 3845 I32 uoffset = *offsetp;
3846 STRLEN len;
3847
3848 if (!sv)
3849 return;
3850
dfe13c55 3851 start = s = (U8*)SvPV(sv, len);
a0ed51b3
LW		 3852 send = s + len;
3853 while (s < send && uoffset--)
3854 s += UTF8SKIP(s);
bb40f870
GA		 3855 if (s >= send)
3856 s = send;
a0ed51b3
LW		 3857 *offsetp = s - start;
3858 if (lenp) {
3859 I32 ulen = *lenp;
3860 start = s;
3861 while (s < send && ulen--)
3862 s += UTF8SKIP(s);
bb40f870
GA		 3863 if (s >= send)
3864 s = send;
a0ed51b3
LW		 3865 *lenp = s - start;
3866 }
3867 return;
3868}
3869
3870void
864dbfa3 3871Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
a0ed51b3 3872{
dfe13c55
GS		 3873 U8 *s;
3874 U8 *send;
a0ed51b3
LW		 3875 STRLEN len;
3876
3877 if (!sv)
3878 return;
3879
dfe13c55 3880 s = (U8*)SvPV(sv, len);
a0ed51b3 3881 if (len < *offsetp)
cea2e8a9 3882 Perl_croak(aTHX_ "panic: bad byte offset");
a0ed51b3
LW		 3883 send = s + *offsetp;
3884 len = 0;
3885 while (s < send) {
3886 s += UTF8SKIP(s);
3887 ++len;
3888 }
3889 if (s != send) {
0453d815
PM		 3890 dTHR;
3891 if (ckWARN_d(WARN_UTF8))
3892 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
a0ed51b3
LW		 3893 --len;
3894 }
3895 *offsetp = len;
3896 return;
3897}
3898
954c1994
GS		 3899/*
3900=for apidoc sv_eq
3901
3902Returns a boolean indicating whether the strings in the two SVs are
3903identical.
3904
3905=cut
3906*/
3907
79072805 3908I32
864dbfa3 3909Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
79072805
LW		 3910{
3911 char *pv1;
463ee0b2 3912 STRLEN cur1;
79072805 3913 char *pv2;
463ee0b2 3914 STRLEN cur2;
79072805
LW		 3915
3916 if (!str1) {
3917 pv1 = "";
3918 cur1 = 0;
3919 }
463ee0b2
LW		 3920 else
3921 pv1 = SvPV(str1, cur1);
79072805
LW		 3922
3923 if (!str2)
3924 return !cur1;
463ee0b2
LW		 3925 else
3926 pv2 = SvPV(str2, cur2);
79072805
LW		 3927
3928 if (cur1 != cur2)
3929 return 0;
3930
36477c24 3931 return memEQ(pv1, pv2, cur1);
79072805
LW		 3932}
3933
954c1994
GS		 3934/*
3935=for apidoc sv_cmp
3936
3937Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
3938string in C<sv1> is less than, equal to, or greater than the string in
3939C<sv2>.
3940
3941=cut
3942*/
3943
79072805 3944I32
864dbfa3 3945Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
79072805 3946{
560a288e
GS		 3947 STRLEN cur1, cur2;
3948 char *pv1, *pv2;
79072805 3949 I32 retval;
560a288e
GS		 3950
3951 if (str1) {
3952 pv1 = SvPV(str1, cur1);
3953 }
3954 else {
3955 cur1 = 0;
3956 }
3957
3958 if (str2) {
3959 if (SvPOK(str2)) {
3960 if (SvPOK(str1) && SvUTF8(str1) != SvUTF8(str2) && !IN_BYTE) {
3961 /* must upgrade other to UTF8 first */
3962 if (SvUTF8(str1)) {
3963 sv_utf8_upgrade(str2);
3964 }
3965 else {
3966 sv_utf8_upgrade(str1);
3967 /* refresh pointer and length */
3968 pv1 = SvPVX(str1);
3969 cur1 = SvCUR(str1);
3970 }
3971 }
3972 pv2 = SvPVX(str2);
3973 cur2 = SvCUR(str2);
3974 }
3975 else {
3976 pv2 = sv_2pv(str2, &cur2);
3977 }
3978 }
3979 else {
3980 cur2 = 0;
3981 }
79072805 3982
bbce6d69 3983 if (!cur1)
3984 return cur2 ? -1 : 0;
16660edb 3985
bbce6d69 3986 if (!cur2)
3987 return 1;
79072805 3988
bbce6d69 3989 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
16660edb 3990
bbce6d69 3991 if (retval)
3992 return retval < 0 ? -1 : 1;
16660edb 3993
bbce6d69 3994 if (cur1 == cur2)
3995 return 0;
3996 else
3997 return cur1 < cur2 ? -1 : 1;
3998}
16660edb 3999
bbce6d69 4000I32
864dbfa3 4001Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
bbce6d69 4002{
36477c24 4003#ifdef USE_LOCALE_COLLATE
16660edb 4004
bbce6d69 4005 char *pv1, *pv2;
4006 STRLEN len1, len2;
4007 I32 retval;
16660edb 4008
3280af22 4009 if (PL_collation_standard)
bbce6d69 4010 goto raw_compare;
16660edb 4011
bbce6d69 4012 len1 = 0;
8ac85365 4013 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
bbce6d69 4014 len2 = 0;
8ac85365 4015 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
16660edb 4016
bbce6d69 4017 if (!pv1 || !len1) {
4018 if (pv2 && len2)
4019 return -1;
4020 else
4021 goto raw_compare;
4022 }
4023 else {
4024 if (!pv2 || !len2)
4025 return 1;
4026 }
16660edb 4027
bbce6d69 4028 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
16660edb 4029
bbce6d69 4030 if (retval)
16660edb 4031 return retval < 0 ? -1 : 1;
4032
bbce6d69 4033 /*
4034 * When the result of collation is equality, that doesn't mean
4035 * that there are no differences -- some locales exclude some
4036 * characters from consideration. So to avoid false equalities,
4037 * we use the raw string as a tiebreaker.
4038 */
16660edb 4039
bbce6d69 4040 raw_compare:
4041 /* FALL THROUGH */
16660edb 4042
36477c24 4043#endif /* USE_LOCALE_COLLATE */
16660edb 4044
bbce6d69 4045 return sv_cmp(sv1, sv2);
4046}
79072805 4047
36477c24 4048#ifdef USE_LOCALE_COLLATE
7a4c00b4 4049/*
4050 * Any scalar variable may carry an 'o' magic that contains the
4051 * scalar data of the variable transformed to such a format that
4052 * a normal memory comparison can be used to compare the data
4053 * according to the locale settings.
4054 */
bbce6d69 4055char *
864dbfa3 4056Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
bbce6d69 4057{
7a4c00b4 4058 MAGIC *mg;
16660edb 4059
8ac85365 4060 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
3280af22 4061 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
bbce6d69 4062 char *s, *xf;
4063 STRLEN len, xlen;
4064
7a4c00b4 4065 if (mg)
4066 Safefree(mg->mg_ptr);
bbce6d69 4067 s = SvPV(sv, len);
4068 if ((xf = mem_collxfrm(s, len, &xlen))) {
ff0cee69 4069 if (SvREADONLY(sv)) {
4070 SAVEFREEPV(xf);
4071 *nxp = xlen;
3280af22 4072 return xf + sizeof(PL_collation_ix);
ff0cee69 4073 }
7a4c00b4 4074 if (! mg) {
4075 sv_magic(sv, 0, 'o', 0, 0);
4076 mg = mg_find(sv, 'o');
4077 assert(mg);
bbce6d69 4078 }
7a4c00b4 4079 mg->mg_ptr = xf;
565764a8 4080 mg->mg_len = xlen;
7a4c00b4 4081 }
4082 else {
ff0cee69 4083 if (mg) {
4084 mg->mg_ptr = NULL;
565764a8 4085 mg->mg_len = -1;
ff0cee69 4086 }
bbce6d69 4087 }
4088 }
7a4c00b4 4089 if (mg && mg->mg_ptr) {
565764a8 4090 *nxp = mg->mg_len;
3280af22 4091 return mg->mg_ptr + sizeof(PL_collation_ix);
bbce6d69 4092 }
4093 else {
4094 *nxp = 0;
4095 return NULL;
16660edb 4096 }
79072805
LW		 4097}
4098
36477c24 4099#endif /* USE_LOCALE_COLLATE */
bbce6d69 4100
79072805 4101char *
864dbfa3 4102Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
79072805 4103{
aeea060c 4104 dTHR;
c07a80fd 4105 char *rsptr;
4106 STRLEN rslen;
4107 register STDCHAR rslast;
4108 register STDCHAR *bp;
4109 register I32 cnt;
4110 I32 i;
4111
2213622d 4112 SV_CHECK_THINKFIRST(sv);
6fc92669 4113 (void)SvUPGRADE(sv, SVt_PV);
99491443 4114
ff68c719 4115 SvSCREAM_off(sv);
c07a80fd 4116
3280af22 4117 if (RsSNARF(PL_rs)) {
c07a80fd 4118 rsptr = NULL;
4119 rslen = 0;
4120 }
3280af22 4121 else if (RsRECORD(PL_rs)) {
5b2b9c68
HM		 4122 I32 recsize, bytesread;
4123 char *buffer;
4124
4125 /* Grab the size of the record we're getting */
3280af22 4126 recsize = SvIV(SvRV(PL_rs));
5b2b9c68 4127 (void)SvPOK_only(sv); /* Validate pointer */
e670df4e 4128 buffer = SvGROW(sv, recsize + 1);
5b2b9c68
HM		 4129 /* Go yank in */
4130#ifdef VMS
4131 /* VMS wants read instead of fread, because fread doesn't respect */
4132 /* RMS record boundaries. This is not necessarily a good thing to be */
4133 /* doing, but we've got no other real choice */
4134 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
4135#else
4136 bytesread = PerlIO_read(fp, buffer, recsize);
4137#endif
4138 SvCUR_set(sv, bytesread);
e670df4e 4139 buffer[bytesread] = '\0';
5b2b9c68
HM		 4140 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
4141 }
3280af22 4142 else if (RsPARA(PL_rs)) {
c07a80fd 4143 rsptr = "\n\n";
4144 rslen = 2;
4145 }
4146 else
3280af22 4147 rsptr = SvPV(PL_rs, rslen);
c07a80fd 4148 rslast = rslen ? rsptr[rslen - 1] : '\0';
4149
3280af22 4150 if (RsPARA(PL_rs)) { /* have to do this both before and after */
79072805 4151 do { /* to make sure file boundaries work right */
760ac839 4152 if (PerlIO_eof(fp))
a0d0e21e 4153 return 0;
760ac839 4154 i = PerlIO_getc(fp);
79072805 4155 if (i != '\n') {
a0d0e21e
LW		 4156 if (i == -1)
4157 return 0;
760ac839 4158 PerlIO_ungetc(fp,i);
79072805
LW		 4159 break;
4160 }
4161 } while (i != EOF);
4162 }
c07a80fd 4163
760ac839
LW		 4164 /* See if we know enough about I/O mechanism to cheat it ! */
4165
4166 /* This used to be #ifdef test - it is made run-time test for ease
4167 of abstracting out stdio interface. One call should be cheap
4168 enough here - and may even be a macro allowing compile
4169 time optimization.
4170 */
4171
4172 if (PerlIO_fast_gets(fp)) {
4173
4174 /*
4175 * We're going to steal some values from the stdio struct
4176 * and put EVERYTHING in the innermost loop into registers.
4177 */
4178 register STDCHAR *ptr;
4179 STRLEN bpx;
4180 I32 shortbuffered;
4181
16660edb 4182#if defined(VMS) && defined(PERLIO_IS_STDIO)
4183 /* An ungetc()d char is handled separately from the regular
4184 * buffer, so we getc() it back out and stuff it in the buffer.
4185 */
4186 i = PerlIO_getc(fp);
4187 if (i == EOF) return 0;
4188 *(--((*fp)->_ptr)) = (unsigned char) i;
4189 (*fp)->_cnt++;
4190#endif
c07a80fd 4191
c2960299 4192 /* Here is some breathtakingly efficient cheating */
c07a80fd 4193
a20bf0c3 4194 cnt = PerlIO_get_cnt(fp); /* get count into register */
a0d0e21e 4195 (void)SvPOK_only(sv); /* validate pointer */
79072805
LW		 4196 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
4197 if (cnt > 80 && SvLEN(sv) > append) {
4198 shortbuffered = cnt - SvLEN(sv) + append + 1;
4199 cnt -= shortbuffered;
4200 }
4201 else {
4202 shortbuffered = 0;
bbce6d69 4203 /* remember that cnt can be negative */
4204 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
79072805
LW		 4205 }
4206 }
4207 else
4208 shortbuffered = 0;
c07a80fd 4209 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
a20bf0c3 4210 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
16660edb 4211 DEBUG_P(PerlIO_printf(Perl_debug_log,
1d7c1841 4212 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
16660edb 4213 DEBUG_P(PerlIO_printf(Perl_debug_log,
1d7c1841
GS		 4214 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4215 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4216 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
79072805
LW		 4217 for (;;) {
4218 screamer:
93a17b20 4219 if (cnt > 0) {
c07a80fd 4220 if (rslen) {
760ac839
LW		 4221 while (cnt > 0) { /* this | eat */
4222 cnt--;
c07a80fd 4223 if ((*bp++ = *ptr++) == rslast) /* really | dust */
4224 goto thats_all_folks; /* screams | sed :-) */
4225 }
4226 }
4227 else {
36477c24 4228 Copy(ptr, bp, cnt, char); /* this | eat */
c07a80fd 4229 bp += cnt; /* screams | dust */
4230 ptr += cnt; /* louder | sed :-) */
a5f75d66 4231 cnt = 0;
93a17b20 4232 }
79072805
LW		 4233 }
4234
748a9306 4235 if (shortbuffered) { /* oh well, must extend */
79072805
LW		 4236 cnt = shortbuffered;
4237 shortbuffered = 0;
c07a80fd 4238 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
79072805
LW		 4239 SvCUR_set(sv, bpx);
4240 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
c07a80fd 4241 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
79072805
LW		 4242 continue;
4243 }
4244
16660edb 4245 DEBUG_P(PerlIO_printf(Perl_debug_log,
1d7c1841
GS		 4246 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
4247 PTR2UV(ptr),(long)cnt));
a20bf0c3 4248 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
16660edb 4249 DEBUG_P(PerlIO_printf(Perl_debug_log,
1d7c1841
GS		 4250 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4251 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4252 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
16660edb 4253 /* This used to call 'filbuf' in stdio form, but as that behaves like
774d564b 4254 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
4255 another abstraction. */
760ac839 4256 i = PerlIO_getc(fp); /* get more characters */
16660edb 4257 DEBUG_P(PerlIO_printf(Perl_debug_log,
1d7c1841
GS		 4258 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4259 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4260 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
a20bf0c3
JH		 4261 cnt = PerlIO_get_cnt(fp);
4262 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
16660edb 4263 DEBUG_P(PerlIO_printf(Perl_debug_log,
1d7c1841 4264 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
79072805 4265
748a9306
LW		 4266 if (i == EOF) /* all done for ever? */
4267 goto thats_really_all_folks;
4268
c07a80fd 4269 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
79072805
LW		 4270 SvCUR_set(sv, bpx);
4271 SvGROW(sv, bpx + cnt + 2);
c07a80fd 4272 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4273
760ac839 4274 *bp++ = i; /* store character from PerlIO_getc */
79072805 4275
c07a80fd 4276 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
79072805 4277 goto thats_all_folks;
79072805
LW		 4278 }
4279
4280thats_all_folks:
c07a80fd 4281 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
36477c24 4282 memNE((char*)bp - rslen, rsptr, rslen))
760ac839 4283 goto screamer; /* go back to the fray */
79072805
LW		 4284thats_really_all_folks:
4285 if (shortbuffered)
4286 cnt += shortbuffered;
16660edb 4287 DEBUG_P(PerlIO_printf(Perl_debug_log,
1d7c1841 4288 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
a20bf0c3 4289 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
16660edb 4290 DEBUG_P(PerlIO_printf(Perl_debug_log,
1d7c1841
GS		 4291 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4292 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4293 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
79072805 4294 *bp = '\0';
760ac839 4295 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
16660edb 4296 DEBUG_P(PerlIO_printf(Perl_debug_log,
fb73857a 4297 "Screamer: done, len=%ld, string=|%.*s|\n",
4298 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
760ac839
LW		 4299 }
4300 else
79072805 4301 {
4d2c4e07 4302#ifndef EPOC
760ac839 4303 /*The big, slow, and stupid way */
c07a80fd 4304 STDCHAR buf[8192];
4d2c4e07
OF		 4305#else
4306 /* Need to work around EPOC SDK features */
4307 /* On WINS: MS VC5 generates calls to _chkstk, */
4308 /* if a `large' stack frame is allocated */
4309 /* gcc on MARM does not generate calls like these */
4310 STDCHAR buf[1024];
4311#endif
79072805 4312
760ac839 4313screamer2:
c07a80fd 4314 if (rslen) {
760ac839
LW		 4315 register STDCHAR *bpe = buf + sizeof(buf);
4316 bp = buf;
4317 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
4318 ; /* keep reading */
4319 cnt = bp - buf;
c07a80fd 4320 }
4321 else {
760ac839 4322 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
16660edb 4323 /* Accomodate broken VAXC compiler, which applies U8 cast to
4324 * both args of ?: operator, causing EOF to change into 255
4325 */
4326 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
c07a80fd 4327 }
79072805
LW		 4328
4329 if (append)
760ac839 4330 sv_catpvn(sv, (char *) buf, cnt);
79072805 4331 else
760ac839 4332 sv_setpvn(sv, (char *) buf, cnt);
c07a80fd 4333
4334 if (i != EOF && /* joy */
4335 (!rslen ||
4336 SvCUR(sv) < rslen ||
36477c24 4337 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
79072805
LW		 4338 {
4339 append = -1;
63e4d877
CS		 4340 /*
4341 * If we're reading from a TTY and we get a short read,
4342 * indicating that the user hit his EOF character, we need
4343 * to notice it now, because if we try to read from the TTY
4344 * again, the EOF condition will disappear.
4345 *
4346 * The comparison of cnt to sizeof(buf) is an optimization
4347 * that prevents unnecessary calls to feof().
4348 *
4349 * - jik 9/25/96
4350 */
4351 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
4352 goto screamer2;
79072805
LW		 4353 }
4354 }
4355
3280af22 4356 if (RsPARA(PL_rs)) { /* have to do this both before and after */
c07a80fd 4357 while (i != EOF) { /* to make sure file boundaries work right */
760ac839 4358 i = PerlIO_getc(fp);
79072805 4359 if (i != '\n') {
760ac839 4360 PerlIO_ungetc(fp,i);
79072805
LW		 4361 break;
4362 }
4363 }
4364 }
c07a80fd 4365
4366 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
79072805
LW		 4367}
4368
760ac839 4369
954c1994
GS		 4370/*
4371=for apidoc sv_inc
4372
4373Auto-increment of the value in the SV.
4374
4375=cut
4376*/
4377
79072805 4378void
864dbfa3 4379Perl_sv_inc(pTHX_ register SV *sv)
79072805
LW		 4380{
4381 register char *d;
463ee0b2 4382 int flags;
79072805
LW		 4383
4384 if (!sv)
4385 return;
b23a5f78
GB		 4386 if (SvGMAGICAL(sv))
4387 mg_get(sv);
ed6116ce 4388 if (SvTHINKFIRST(sv)) {
0f15f207
MB		 4389 if (SvREADONLY(sv)) {
4390 dTHR;
3280af22 4391 if (PL_curcop != &PL_compiling)
cea2e8a9 4392 Perl_croak(aTHX_ PL_no_modify);
0f15f207 4393 }
a0d0e21e 4394 if (SvROK(sv)) {
b5be31e9 4395 IV i;
9e7bc3e8
JD		 4396 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
4397 return;
56431972 4398 i = PTR2IV(SvRV(sv));
b5be31e9
SM		 4399 sv_unref(sv);
4400 sv_setiv(sv, i);
a0d0e21e 4401 }
ed6116ce 4402 }
8990e307 4403 flags = SvFLAGS(sv);
8990e307 4404 if (flags & SVp_NOK) {
a0d0e21e 4405 (void)SvNOK_only(sv);
55497cff 4406 SvNVX(sv) += 1.0;
4407 return;
4408 }
4409 if (flags & SVp_IOK) {
25da4f38
IZ		 4410 if (SvIsUV(sv)) {
4411 if (SvUVX(sv) == UV_MAX)
65202027 4412 sv_setnv(sv, (NV)UV_MAX + 1.0);
25da4f38
IZ		 4413 else
4414 (void)SvIOK_only_UV(sv);
4415 ++SvUVX(sv);
4416 } else {
4417 if (SvIVX(sv) == IV_MAX)
65202027 4418 sv_setnv(sv, (NV)IV_MAX + 1.0);
25da4f38
IZ		 4419 else {
4420 (void)SvIOK_only(sv);
4421 ++SvIVX(sv);
4422 }
55497cff 4423 }
79072805
LW		 4424 return;
4425 }
8990e307 4426 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
4633a7c4
LW		 4427 if ((flags & SVTYPEMASK) < SVt_PVNV)
4428 sv_upgrade(sv, SVt_NV);
463ee0b2 4429 SvNVX(sv) = 1.0;
a0d0e21e 4430 (void)SvNOK_only(sv);
79072805
LW		 4431 return;
4432 }
463ee0b2 4433 d = SvPVX(sv);
79072805
LW		 4434 while (isALPHA(*d)) d++;
4435 while (isDIGIT(*d)) d++;
4436 if (*d) {
097ee67d 4437 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
79072805
LW		 4438 return;
4439 }
4440 d--;
463ee0b2 4441 while (d >= SvPVX(sv)) {
79072805
LW		 4442 if (isDIGIT(*d)) {
4443 if (++*d <= '9')
4444 return;
4445 *(d--) = '0';
4446 }
4447 else {
9d116dd7
JH		 4448#ifdef EBCDIC
4449 /* MKS: The original code here died if letters weren't consecutive.
4450 * at least it didn't have to worry about non-C locales. The
4451 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
4452 * arranged in order (although not consecutively) and that only
4453 * [A-Za-z] are accepted by isALPHA in the C locale.
4454 */
4455 if (*d != 'z' && *d != 'Z') {
4456 do { ++*d; } while (!isALPHA(*d));
4457 return;
4458 }
4459 *(d--) -= 'z' - 'a';
4460#else
79072805
LW		 4461 ++*d;
4462 if (isALPHA(*d))
4463 return;
4464 *(d--) -= 'z' - 'a' + 1;
9d116dd7 4465#endif
79072805
LW		 4466 }
4467 }
4468 /* oh,oh, the number grew */
4469 SvGROW(sv, SvCUR(sv) + 2);
4470 SvCUR(sv)++;
463ee0b2 4471 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
79072805
LW		 4472 *d = d[-1];
4473 if (isDIGIT(d[1]))
4474 *d = '1';
4475 else
4476 *d = d[1];
4477}
4478
954c1994
GS		 4479/*
4480=for apidoc sv_dec
4481
4482Auto-decrement of the value in the SV.
4483
4484=cut
4485*/
4486
79072805 4487void
864dbfa3 4488Perl_sv_dec(pTHX_ register SV *sv)
79072805 4489{
463ee0b2
LW		 4490 int flags;
4491
79072805
LW		 4492 if (!sv)
4493 return;
b23a5f78
GB		 4494 if (SvGMAGICAL(sv))
4495 mg_get(sv);
ed6116ce 4496 if (SvTHINKFIRST(sv)) {
0f15f207
MB		 4497 if (SvREADONLY(sv)) {
4498 dTHR;
3280af22 4499 if (PL_curcop != &PL_compiling)
cea2e8a9 4500 Perl_croak(aTHX_ PL_no_modify);
0f15f207 4501 }
a0d0e21e 4502 if (SvROK(sv)) {
b5be31e9 4503 IV i;
9e7bc3e8
JD		 4504 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
4505 return;
56431972 4506 i = PTR2IV(SvRV(sv));
b5be31e9
SM		 4507 sv_unref(sv);
4508 sv_setiv(sv, i);
a0d0e21e 4509 }
ed6116ce 4510 }
8990e307 4511 flags = SvFLAGS(sv);
8990e307 4512 if (flags & SVp_NOK) {
463ee0b2 4513 SvNVX(sv) -= 1.0;
a0d0e21e 4514 (void)SvNOK_only(sv);
79072805
LW		 4515 return;
4516 }
55497cff 4517 if (flags & SVp_IOK) {
25da4f38
IZ		 4518 if (SvIsUV(sv)) {
4519 if (SvUVX(sv) == 0) {
4520 (void)SvIOK_only(sv);
4521 SvIVX(sv) = -1;
4522 }
4523 else {
4524 (void)SvIOK_only_UV(sv);
4525 --SvUVX(sv);
4526 }
4527 } else {
4528 if (SvIVX(sv) == IV_MIN)
65202027 4529 sv_setnv(sv, (NV)IV_MIN - 1.0);
25da4f38
IZ		 4530 else {
4531 (void)SvIOK_only(sv);
4532 --SvIVX(sv);
4533 }
55497cff 4534 }
4535 return;
4536 }
8990e307 4537 if (!(flags & SVp_POK)) {
4633a7c4
LW		 4538 if ((flags & SVTYPEMASK) < SVt_PVNV)
4539 sv_upgrade(sv, SVt_NV);
463ee0b2 4540 SvNVX(sv) = -1.0;
a0d0e21e 4541 (void)SvNOK_only(sv);
79072805
LW		 4542 return;
4543 }
097ee67d 4544 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
79072805
LW		 4545}
4546
954c1994
GS		 4547/*
4548=for apidoc sv_mortalcopy
4549
4550Creates a new SV which is a copy of the original SV. The new SV is marked
4551as mortal.
4552
4553=cut
4554*/
4555
79072805
LW		 4556/* Make a string that will exist for the duration of the expression
4557 * evaluation. Actually, it may have to last longer than that, but
4558 * hopefully we won't free it until it has been assigned to a
4559 * permanent location. */
4560
4561SV *
864dbfa3 4562Perl_sv_mortalcopy(pTHX_ SV *oldstr)
79072805 4563{
11343788 4564 dTHR;
463ee0b2 4565 register SV *sv;
79072805 4566
4561caa4 4567 new_SV(sv);
79072805 4568 sv_setsv(sv,oldstr);
677b06e3
GS		 4569 EXTEND_MORTAL(1);
4570 PL_tmps_stack[++PL_tmps_ix] = sv;
8990e307
LW		 4571 SvTEMP_on(sv);
4572 return sv;
4573}
4574
954c1994
GS		 4575/*
4576=for apidoc sv_newmortal
4577
4578Creates a new SV which is mortal. The reference count of the SV is set to 1.
4579
4580=cut
4581*/
4582
8990e307 4583SV *
864dbfa3 4584Perl_sv_newmortal(pTHX)
8990e307 4585{
11343788 4586 dTHR;
8990e307
LW		 4587 register SV *sv;
4588
4561caa4 4589 new_SV(sv);
8990e307 4590 SvFLAGS(sv) = SVs_TEMP;
677b06e3
GS		 4591 EXTEND_MORTAL(1);
4592 PL_tmps_stack[++PL_tmps_ix] = sv;
79072805
LW		 4593 return sv;
4594}
4595
954c1994
GS		 4596/*
4597=for apidoc sv_2mortal
4598
4599Marks an SV as mortal. The SV will be destroyed when the current context
4600ends.
4601
4602=cut
4603*/
4604
79072805
LW		 4605/* same thing without the copying */
4606
4607SV *
864dbfa3 4608Perl_sv_2mortal(pTHX_ register SV *sv)
79072805 4609{
11343788 4610 dTHR;
79072805
LW		 4611 if (!sv)
4612 return sv;
d689ffdd 4613 if (SvREADONLY(sv) && SvIMMORTAL(sv))
11162842 4614 return sv;
677b06e3
GS		 4615 EXTEND_MORTAL(1);
4616 PL_tmps_stack[++PL_tmps_ix] = sv;
8990e307 4617 SvTEMP_on(sv);
79072805
LW		 4618 return sv;
4619}
4620
954c1994
GS		 4621/*
4622=for apidoc newSVpv
4623
4624Creates a new SV and copies a string into it. The reference count for the
4625SV is set to 1. If C<len> is zero, Perl will compute the length using
4626strlen(). For efficiency, consider using C<newSVpvn> instead.
4627
4628=cut
4629*/
4630
79072805 4631SV *
864dbfa3 4632Perl_newSVpv(pTHX_ const char *s, STRLEN len)
79072805 4633{
463ee0b2 4634 register SV *sv;
79072805 4635
4561caa4 4636 new_SV(sv);
79072805
LW		 4637 if (!len)
4638 len = strlen(s);
4639 sv_setpvn(sv,s,len);
4640 return sv;
4641}
4642
954c1994
GS		 4643/*
4644=for apidoc newSVpvn
4645
4646Creates a new SV and copies a string into it. The reference count for the
4647SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
4648string. You are responsible for ensuring that the source string is at least
4649C<len> bytes long.
4650
4651=cut
4652*/
4653
9da1e3b5 4654SV *
864dbfa3 4655Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
9da1e3b5
MUN		 4656{
4657 register SV *sv;
4658
4659 new_SV(sv);
9da1e3b5
MUN		 4660 sv_setpvn(sv,s,len);
4661 return sv;
4662}
4663
cea2e8a9 4664#if defined(PERL_IMPLICIT_CONTEXT)
46fc3d4c 4665SV *
cea2e8a9 4666Perl_newSVpvf_nocontext(const char* pat, ...)
46fc3d4c 4667{
cea2e8a9 4668 dTHX;
46fc3d4c 4669 register SV *sv;
4670 va_list args;
46fc3d4c 4671 va_start(args, pat);
c5be433b 4672 sv = vnewSVpvf(pat, &args);
46fc3d4c 4673 va_end(args);
4674 return sv;
4675}
cea2e8a9 4676#endif
46fc3d4c 4677
954c1994
GS		 4678/*
4679=for apidoc newSVpvf
4680
4681Creates a new SV an initialize it with the string formatted like
4682C<sprintf>.
4683
4684=cut
4685*/
4686
cea2e8a9
GS		 4687SV *
4688Perl_newSVpvf(pTHX_ const char* pat, ...)
4689{
4690 register SV *sv;
4691 va_list args;
cea2e8a9 4692 va_start(args, pat);
c5be433b 4693 sv = vnewSVpvf(pat, &args);
cea2e8a9
GS		 4694 va_end(args);
4695 return sv;
4696}
46fc3d4c 4697
79072805 4698SV *
c5be433b
GS		 4699Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
4700{
4701 register SV *sv;
4702 new_SV(sv);
4703 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4704 return sv;
4705}
4706
954c1994
GS		 4707/*
4708=for apidoc newSVnv
4709
4710Creates a new SV and copies a floating point value into it.
4711The reference count for the SV is set to 1.
4712
4713=cut
4714*/
4715
c5be433b 4716SV *
65202027 4717Perl_newSVnv(pTHX_ NV n)
79072805 4718{
463ee0b2 4719 register SV *sv;
79072805 4720
4561caa4 4721 new_SV(sv);
79072805
LW		 4722 sv_setnv(sv,n);
4723 return sv;
4724}
4725
954c1994
GS		 4726/*
4727=for apidoc newSViv
4728
4729Creates a new SV and copies an integer into it. The reference count for the
4730SV is set to 1.
4731
4732=cut
4733*/
4734
79072805 4735SV *
864dbfa3 4736Perl_newSViv(pTHX_ IV i)
79072805 4737{
463ee0b2 4738 register SV *sv;
79072805 4739
4561caa4 4740 new_SV(sv);
79072805
LW		 4741 sv_setiv(sv,i);
4742 return sv;
4743}
4744
954c1994 4745/*
1a3327fb
JH		 4746=for apidoc newSVuv
4747
4748Creates a new SV and copies an unsigned integer into it.
4749The reference count for the SV is set to 1.
4750
4751=cut
4752*/
4753
4754SV *
4755Perl_newSVuv(pTHX_ UV u)
4756{
4757 register SV *sv;
4758
4759 new_SV(sv);
4760 sv_setuv(sv,u);
4761 return sv;
4762}
4763
4764/*
954c1994
GS		 4765=for apidoc newRV_noinc
4766
4767Creates an RV wrapper for an SV. The reference count for the original
4768SV is B<not> incremented.
4769
4770=cut
4771*/
4772
2304df62 4773SV *
864dbfa3 4774Perl_newRV_noinc(pTHX_ SV *tmpRef)
2304df62 4775{
11343788 4776 dTHR;
2304df62
AD		 4777 register SV *sv;
4778
4561caa4 4779 new_SV(sv);
2304df62 4780 sv_upgrade(sv, SVt_RV);
76e3520e 4781 SvTEMP_off(tmpRef);
d689ffdd 4782 SvRV(sv) = tmpRef;
2304df62 4783 SvROK_on(sv);
2304df62
AD		 4784 return sv;
4785}
4786
954c1994 4787/* newRV_inc is #defined to newRV in sv.h */
5f05dabc 4788SV *
864dbfa3 4789Perl_newRV(pTHX_ SV *tmpRef)
5f05dabc 4790{
5f6447b6 4791 return newRV_noinc(SvREFCNT_inc(tmpRef));
5f05dabc 4792}
5f05dabc 4793
954c1994
GS		 4794/*
4795=for apidoc newSVsv
4796
4797Creates a new SV which is an exact duplicate of the original SV.
4798
4799=cut
4800*/
4801
79072805
LW		 4802/* make an exact duplicate of old */
4803
4804SV *
864dbfa3 4805Perl_newSVsv(pTHX_ register SV *old)
79072805 4806{
0453d815 4807 dTHR;
463ee0b2 4808 register SV *sv;
79072805
LW		 4809
4810 if (!old)
4811 return Nullsv;
8990e307 4812 if (SvTYPE(old) == SVTYPEMASK) {
0453d815
PM		 4813 if (ckWARN_d(WARN_INTERNAL))
4814 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
79072805
LW		 4815 return Nullsv;
4816 }
4561caa4 4817 new_SV(sv);
ff68c719 4818 if (SvTEMP(old)) {
4819 SvTEMP_off(old);
463ee0b2 4820 sv_setsv(sv,old);
ff68c719 4821 SvTEMP_on(old);
79072805
LW		 4822 }
4823 else
463ee0b2
LW		 4824 sv_setsv(sv,old);
4825 return sv;
79072805
LW		 4826}
4827
4828void
864dbfa3 4829Perl_sv_reset(pTHX_ register char *s, HV *stash)
79072805
LW		 4830{
4831 register HE *entry;
4832 register GV *gv;
4833 register SV *sv;
4834 register I32 i;
4835 register PMOP *pm;
4836 register I32 max;
4802d5d7 4837 char todo[PERL_UCHAR_MAX+1];
79072805 4838
49d8d3a1
MB		 4839 if (!stash)
4840 return;
4841
79072805
LW		 4842 if (!*s) { /* reset ?? searches */
4843 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
48c036b1 4844 pm->op_pmdynflags &= ~PMdf_USED;
79072805
LW		 4845 }
4846 return;
4847 }
4848
4849 /* reset variables */
4850
4851 if (!HvARRAY(stash))
4852 return;
463ee0b2
LW		 4853
4854 Zero(todo, 256, char);
79072805 4855 while (*s) {
4802d5d7 4856 i = (unsigned char)*s;
79072805
LW		 4857 if (s[1] == '-') {
4858 s += 2;
4859 }
4802d5d7 4860 max = (unsigned char)*s++;
79072805 4861 for ( ; i <= max; i++) {
463ee0b2
LW		 4862 todo[i] = 1;
4863 }
a0d0e21e 4864 for (i = 0; i <= (I32) HvMAX(stash); i++) {
79072805 4865 for (entry = HvARRAY(stash)[i];
9e35f4b3
GS		 4866 entry;
4867 entry = HeNEXT(entry))
4868 {
1edc1566 4869 if (!todo[(U8)*HeKEY(entry)])
463ee0b2 4870 continue;
1edc1566 4871 gv = (GV*)HeVAL(entry);
79072805 4872 sv = GvSV(gv);
9e35f4b3
GS		 4873 if (SvTHINKFIRST(sv)) {
4874 if (!SvREADONLY(sv) && SvROK(sv))
4875 sv_unref(sv);
4876 continue;
4877 }
a0d0e21e 4878 (void)SvOK_off(sv);
79072805
LW		 4879 if (SvTYPE(sv) >= SVt_PV) {
4880 SvCUR_set(sv, 0);
463ee0b2
LW		 4881 if (SvPVX(sv) != Nullch)
4882 *SvPVX(sv) = '\0';
44a8e56a 4883 SvTAINT(sv);
79072805
LW		 4884 }
4885 if (GvAV(gv)) {
4886 av_clear(GvAV(gv));
4887 }
44a8e56a 4888 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
463ee0b2 4889 hv_clear(GvHV(gv));
a0d0e21e 4890#ifndef VMS /* VMS has no environ array */
3280af22 4891 if (gv == PL_envgv)
79072805 4892 environ[0] = Nullch;
a0d0e21e 4893#endif
79072805
LW		 4894 }
4895 }
4896 }
4897 }
4898}
4899
46fc3d4c 4900IO*
864dbfa3 4901Perl_sv_2io(pTHX_ SV *sv)
46fc3d4c 4902{
4903 IO* io;
4904 GV* gv;
2d8e6c8d 4905 STRLEN n_a;
46fc3d4c 4906
4907 switch (SvTYPE(sv)) {
4908 case SVt_PVIO:
4909 io = (IO*)sv;
4910 break;
4911 case SVt_PVGV:
4912 gv = (GV*)sv;
4913 io = GvIO(gv);
4914 if (!io)
cea2e8a9 4915 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
46fc3d4c 4916 break;
4917 default:
4918 if (!SvOK(sv))
cea2e8a9 4919 Perl_croak(aTHX_ PL_no_usym, "filehandle");
46fc3d4c 4920 if (SvROK(sv))
4921 return sv_2io(SvRV(sv));
2d8e6c8d 4922 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
46fc3d4c 4923 if (gv)
4924 io = GvIO(gv);
4925 else
4926 io = 0;
4927 if (!io)
cea2e8a9 4928 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
46fc3d4c 4929 break;
4930 }
4931 return io;
4932}
4933
79072805 4934CV *
864dbfa3 4935Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
79072805
LW		 4936{
4937 GV *gv;
4938 CV *cv;
2d8e6c8d 4939 STRLEN n_a;
79072805
LW		 4940
4941 if (!sv)
93a17b20 4942 return *gvp = Nullgv, Nullcv;
79072805 4943 switch (SvTYPE(sv)) {
79072805
LW		 4944 case SVt_PVCV:
4945 *st = CvSTASH(sv);
4946 *gvp = Nullgv;
4947 return (CV*)sv;
4948 case SVt_PVHV:
4949 case SVt_PVAV:
4950 *gvp = Nullgv;
4951 return Nullcv;
8990e307
LW		 4952 case SVt_PVGV:
4953 gv = (GV*)sv;
a0d0e21e 4954 *gvp = gv;
8990e307
LW		 4955 *st = GvESTASH(gv);
4956 goto fix_gv;
4957
79072805 4958 default:
a0d0e21e
LW		 4959 if (SvGMAGICAL(sv))
4960 mg_get(sv);
4961 if (SvROK(sv)) {
0f4592ef 4962 dTHR;
f5284f61
IZ		 4963 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
4964 tryAMAGICunDEREF(to_cv);
4965
62f274bf
GS		 4966 sv = SvRV(sv);
4967 if (SvTYPE(sv) == SVt_PVCV) {
4968 cv = (CV*)sv;
4969 *gvp = Nullgv;
4970 *st = CvSTASH(cv);
4971 return cv;
4972 }
4973 else if(isGV(sv))
4974 gv = (GV*)sv;
4975 else
cea2e8a9 4976 Perl_croak(aTHX_ "Not a subroutine reference");
a0d0e21e 4977 }
62f274bf 4978 else if (isGV(sv))
79072805
LW		 4979 gv = (GV*)sv;
4980 else
2d8e6c8d 4981 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
79072805
LW		 4982 *gvp = gv;
4983 if (!gv)
4984 return Nullcv;
4985 *st = GvESTASH(gv);
8990e307 4986 fix_gv:
8ebc5c01 4987 if (lref && !GvCVu(gv)) {
4633a7c4 4988 SV *tmpsv;
748a9306 4989 ENTER;
4633a7c4 4990 tmpsv = NEWSV(704,0);
16660edb 4991 gv_efullname3(tmpsv, gv, Nullch);
f6ec51f7
GS		 4992 /* XXX this is probably not what they think they're getting.
4993 * It has the same effect as "sub name;", i.e. just a forward
4994 * declaration! */
774d564b 4995 newSUB(start_subparse(FALSE, 0),
4633a7c4
LW		 4996 newSVOP(OP_CONST, 0, tmpsv),
4997 Nullop,
8990e307 4998 Nullop);
748a9306 4999 LEAVE;
8ebc5c01 5000 if (!GvCVu(gv))
cea2e8a9 5001 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
8990e307 5002 }
8ebc5c01 5003 return GvCVu(gv);
79072805
LW		 5004 }
5005}
5006
79072805 5007I32
864dbfa3 5008Perl_sv_true(pTHX_ register SV *sv)
79072805 5009{
4e35701f 5010 dTHR;
8990e307
LW		 5011 if (!sv)
5012 return 0;
79072805 5013 if (SvPOK(sv)) {
4e35701f
NIS		 5014 register XPV* tXpv;
5015 if ((tXpv = (XPV*)SvANY(sv)) &&
c2f1de04 5016 (tXpv->xpv_cur > 1 ||
4e35701f 5017 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
79072805
LW		 5018 return 1;
5019 else
5020 return 0;
5021 }
5022 else {
5023 if (SvIOK(sv))
463ee0b2 5024 return SvIVX(sv) != 0;
79072805
LW		 5025 else {
5026 if (SvNOK(sv))
463ee0b2 5027 return SvNVX(sv) != 0.0;
79072805 5028 else
463ee0b2 5029 return sv_2bool(sv);
79072805
LW		 5030 }
5031 }
5032}
79072805 5033
ff68c719 5034IV
864dbfa3 5035Perl_sv_iv(pTHX_ register SV *sv)
85e6fe83 5036{
25da4f38
IZ		 5037 if (SvIOK(sv)) {
5038 if (SvIsUV(sv))
5039 return (IV)SvUVX(sv);
ff68c719 5040 return SvIVX(sv);
25da4f38 5041 }
ff68c719 5042 return sv_2iv(sv);
85e6fe83 5043}
85e6fe83 5044
ff68c719 5045UV
864dbfa3 5046Perl_sv_uv(pTHX_ register SV *sv)
ff68c719 5047{
25da4f38
IZ		 5048 if (SvIOK(sv)) {
5049 if (SvIsUV(sv))
5050 return SvUVX(sv);
5051 return (UV)SvIVX(sv);
5052 }
ff68c719 5053 return sv_2uv(sv);
5054}
85e6fe83 5055
65202027 5056NV
864dbfa3 5057Perl_sv_nv(pTHX_ register SV *sv)
79072805 5058{
ff68c719 5059 if (SvNOK(sv))
5060 return SvNVX(sv);
5061 return sv_2nv(sv);
79072805 5062}
79072805 5063
79072805 5064char *
864dbfa3 5065Perl_sv_pv(pTHX_ SV *sv)
1fa8b10d
JD		 5066{
5067 STRLEN n_a;
5068
5069 if (SvPOK(sv))
5070 return SvPVX(sv);
5071
5072 return sv_2pv(sv, &n_a);
5073}
5074
5075char *
864dbfa3 5076Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
79072805 5077{
85e6fe83
LW		 5078 if (SvPOK(sv)) {
5079 *lp = SvCUR(sv);
a0d0e21e 5080 return SvPVX(sv);
85e6fe83 5081 }
463ee0b2 5082 return sv_2pv(sv, lp);
79072805 5083}
79072805 5084
a0d0e21e 5085char *
864dbfa3 5086Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
a0d0e21e
LW		 5087{
5088 char *s;
5089
6fc92669
GS		 5090 if (SvTHINKFIRST(sv) && !SvROK(sv))
5091 sv_force_normal(sv);
a0d0e21e
LW		 5092
5093 if (SvPOK(sv)) {
5094 *lp = SvCUR(sv);
5095 }
5096 else {
748a9306 5097 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
6fc92669 5098 dTHR;
cea2e8a9 5099 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6fc92669 5100 PL_op_name[PL_op->op_type]);
a0d0e21e 5101 }
4633a7c4
LW		 5102 else
5103 s = sv_2pv(sv, lp);
a0d0e21e
LW		 5104 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
5105 STRLEN len = *lp;
5106
5107 if (SvROK(sv))
5108 sv_unref(sv);
5109 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
5110 SvGROW(sv, len + 1);
5111 Move(s,SvPVX(sv),len,char);
5112 SvCUR_set(sv, len);
5113 *SvEND(sv) = '\0';
5114 }
5115 if (!SvPOK(sv)) {
5116 SvPOK_on(sv); /* validate pointer */
5117 SvTAINT(sv);
1d7c1841
GS		 5118 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
5119 PTR2UV(sv),SvPVX(sv)));
a0d0e21e
LW		 5120 }
5121 }
5122 return SvPVX(sv);
5123}
5124
5125char *
7340a771
GS		 5126Perl_sv_pvbyte(pTHX_ SV *sv)
5127{
5128 return sv_pv(sv);
5129}
5130
5131char *
5132Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
5133{
5134 return sv_pvn(sv,lp);
5135}
5136
5137char *
5138Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
5139{
5140 return sv_pvn_force(sv,lp);
5141}
5142
5143char *
5144Perl_sv_pvutf8(pTHX_ SV *sv)
5145{
560a288e 5146 sv_utf8_upgrade(sv);
7340a771
GS		 5147 return sv_pv(sv);
5148}
5149
5150char *
5151Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
5152{
560a288e 5153 sv_utf8_upgrade(sv);
7340a771
GS		 5154 return sv_pvn(sv,lp);
5155}
5156
5157char *
5158Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
5159{
560a288e 5160 sv_utf8_upgrade(sv);
7340a771
GS		 5161 return sv_pvn_force(sv,lp);
5162}
5163
5164char *
864dbfa3 5165Perl_sv_reftype(pTHX_ SV *sv, int ob)
a0d0e21e
LW		 5166{
5167 if (ob && SvOBJECT(sv))
5168 return HvNAME(SvSTASH(sv));
5169 else {
5170 switch (SvTYPE(sv)) {
5171 case SVt_NULL:
5172 case SVt_IV:
5173 case SVt_NV:
5174 case SVt_RV:
5175 case SVt_PV:
5176 case SVt_PVIV:
5177 case SVt_PVNV:
5178 case SVt_PVMG:
5179 case SVt_PVBM:
5180 if (SvROK(sv))
5181 return "REF";
5182 else
5183 return "SCALAR";
5184 case SVt_PVLV: return "LVALUE";
5185 case SVt_PVAV: return "ARRAY";
5186 case SVt_PVHV: return "HASH";
5187 case SVt_PVCV: return "CODE";
5188 case SVt_PVGV: return "GLOB";
1d2dff63 5189 case SVt_PVFM: return "FORMAT";
27f9d8f3 5190 case SVt_PVIO: return "IO";
a0d0e21e
LW		 5191 default: return "UNKNOWN";
5192 }
5193 }
5194}
5195
954c1994
GS		 5196/*
5197=for apidoc sv_isobject
5198
5199Returns a boolean indicating whether the SV is an RV pointing to a blessed
5200object. If the SV is not an RV, or if the object is not blessed, then this
5201will return false.
5202
5203=cut
5204*/
5205
463ee0b2 5206int
864dbfa3 5207Perl_sv_isobject(pTHX_ SV *sv)
85e6fe83 5208{
68dc0745 5209 if (!sv)
5210 return 0;
5211 if (SvGMAGICAL(sv))
5212 mg_get(sv);
85e6fe83
LW		 5213 if (!SvROK(sv))
5214 return 0;
5215 sv = (SV*)SvRV(sv);
5216 if (!SvOBJECT(sv))
5217 return 0;
5218 return 1;
5219}
5220
954c1994
GS		 5221/*
5222=for apidoc sv_isa
5223
5224Returns a boolean indicating whether the SV is blessed into the specified
5225class. This does not check for subtypes; use C<sv_derived_from> to verify
5226an inheritance relationship.
5227
5228=cut
5229*/
5230
85e6fe83 5231int
864dbfa3 5232Perl_sv_isa(pTHX_ SV *sv, const char *name)
463ee0b2 5233{
68dc0745 5234 if (!sv)
5235 return 0;
5236 if (SvGMAGICAL(sv))
5237 mg_get(sv);
ed6116ce 5238 if (!SvROK(sv))
463ee0b2 5239 return 0;
ed6116ce
LW		 5240 sv = (SV*)SvRV(sv);
5241 if (!SvOBJECT(sv))
463ee0b2
LW		 5242 return 0;
5243
5244 return strEQ(HvNAME(SvSTASH(sv)), name);
5245}
5246
954c1994
GS		 5247/*
5248=for apidoc newSVrv
5249
5250Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
5251it will be upgraded to one. If C<classname> is non-null then the new SV will
5252be blessed in the specified package. The new SV is returned and its
5253reference count is 1.
5254
5255=cut
5256*/
5257
463ee0b2 5258SV*
864dbfa3 5259Perl_newSVrv(pTHX_ SV *rv, const char *classname)
463ee0b2 5260{
11343788 5261 dTHR;
463ee0b2
LW		 5262 SV *sv;
5263
4561caa4 5264 new_SV(sv);
51cf62d8 5265
2213622d 5266 SV_CHECK_THINKFIRST(rv);
51cf62d8 5267 SvAMAGIC_off(rv);
51cf62d8
OT		 5268
5269 if (SvTYPE(rv) < SVt_RV)
5270 sv_upgrade(rv, SVt_RV);
5271
5272 (void)SvOK_off(rv);
053fc874 5273 SvRV(rv) = sv;
ed6116ce 5274 SvROK_on(rv);
463ee0b2 5275
a0d0e21e
LW		 5276 if (classname) {
5277 HV* stash = gv_stashpv(classname, TRUE);
5278 (void)sv_bless(rv, stash);
5279 }
5280 return sv;
5281}
5282
954c1994
GS		 5283/*
5284=for apidoc sv_setref_pv
5285
5286Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
5287argument will be upgraded to an RV. That RV will be modified to point to
5288the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
5289into the SV. The C<classname> argument indicates the package for the
5290blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5291will be returned and will have a reference count of 1.
5292
5293Do not use with other Perl types such as HV, AV, SV, CV, because those
5294objects will become corrupted by the pointer copy process.
5295
5296Note that C<sv_setref_pvn> copies the string while this copies the pointer.
5297
5298=cut
5299*/
5300
a0d0e21e 5301SV*
864dbfa3 5302Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
a0d0e21e 5303{
189b2af5 5304 if (!pv) {
3280af22 5305 sv_setsv(rv, &PL_sv_undef);
189b2af5
GS		 5306 SvSETMAGIC(rv);
5307 }
a0d0e21e 5308 else
56431972 5309 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
a0d0e21e
LW		 5310 return rv;
5311}
5312
954c1994
GS		 5313/*
5314=for apidoc sv_setref_iv
5315
5316Copies an integer into a new SV, optionally blessing the SV. The C<rv>
5317argument will be upgraded to an RV. That RV will be modified to point to
5318the new SV. The C<classname> argument indicates the package for the
5319blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5320will be returned and will have a reference count of 1.
5321
5322=cut
5323*/
5324
a0d0e21e 5325SV*
864dbfa3 5326Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
a0d0e21e
LW		 5327{
5328 sv_setiv(newSVrv(rv,classname), iv);
5329 return rv;
5330}
5331
954c1994
GS		 5332/*
5333=for apidoc sv_setref_nv
5334
5335Copies a double into a new SV, optionally blessing the SV. The C<rv>
5336argument will be upgraded to an RV. That RV will be modified to point to
5337the new SV. The C<classname> argument indicates the package for the
5338blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5339will be returned and will have a reference count of 1.
5340
5341=cut
5342*/
5343
a0d0e21e 5344SV*
65202027 5345Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
a0d0e21e
LW		 5346{
5347 sv_setnv(newSVrv(rv,classname), nv);
5348 return rv;
5349}
463ee0b2 5350
954c1994
GS		 5351/*
5352=for apidoc sv_setref_pvn
5353
5354Copies a string into a new SV, optionally blessing the SV. The length of the
5355string must be specified with C<n>. The C<rv> argument will be upgraded to
5356an RV. That RV will be modified to point to the new SV. The C<classname>
5357argument indicates the package for the blessing. Set C<classname> to
5358C<Nullch> to avoid the blessing. The new SV will be returned and will have
5359a reference count of 1.
5360
5361Note that C<sv_setref_pv> copies the pointer while this copies the string.
5362
5363=cut
5364*/
5365
a0d0e21e 5366SV*
864dbfa3 5367Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
a0d0e21e
LW		 5368{
5369 sv_setpvn(newSVrv(rv,classname), pv, n);
463ee0b2
LW		 5370 return rv;
5371}
5372
954c1994
GS		 5373/*
5374=for apidoc sv_bless
5375
5376Blesses an SV into a specified package. The SV must be an RV. The package
5377must be designated by its stash (see C<gv_stashpv()>). The reference count
5378of the SV is unaffected.
5379
5380=cut
5381*/
5382
a0d0e21e 5383SV*
864dbfa3 5384Perl_sv_bless(pTHX_ SV *sv, HV *stash)
a0d0e21e 5385{
11343788 5386 dTHR;
76e3520e 5387 SV *tmpRef;
a0d0e21e 5388 if (!SvROK(sv))
cea2e8a9 5389 Perl_croak(aTHX_ "Can't bless non-reference value");
76e3520e
GS		 5390 tmpRef = SvRV(sv);
5391 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
5392 if (SvREADONLY(tmpRef))
cea2e8a9 5393 Perl_croak(aTHX_ PL_no_modify);
76e3520e
GS		 5394 if (SvOBJECT(tmpRef)) {
5395 if (SvTYPE(tmpRef) != SVt_PVIO)
3280af22 5396 --PL_sv_objcount;
76e3520e 5397 SvREFCNT_dec(SvSTASH(tmpRef));
2e3febc6 5398 }
a0d0e21e 5399 }
76e3520e
GS		 5400 SvOBJECT_on(tmpRef);
5401 if (SvTYPE(tmpRef) != SVt_PVIO)
3280af22 5402 ++PL_sv_objcount;
76e3520e
GS		 5403 (void)SvUPGRADE(tmpRef, SVt_PVMG);
5404 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
a0d0e21e 5405
2e3febc6
CS		 5406 if (Gv_AMG(stash))
5407 SvAMAGIC_on(sv);
5408 else
5409 SvAMAGIC_off(sv);
a0d0e21e
LW		 5410
5411 return sv;
5412}
5413
76e3520e 5414STATIC void
cea2e8a9 5415S_sv_unglob(pTHX_ SV *sv)
a0d0e21e 5416{
850fabdf
GS		 5417 void *xpvmg;
5418
a0d0e21e
LW		 5419 assert(SvTYPE(sv) == SVt_PVGV);
5420 SvFAKE_off(sv);
5421 if (GvGP(sv))
1edc1566 5422 gp_free((GV*)sv);
e826b3c7
GS		 5423 if (GvSTASH(sv)) {
5424 SvREFCNT_dec(GvSTASH(sv));
5425 GvSTASH(sv) = Nullhv;
5426 }
a0d0e21e
LW		 5427 sv_unmagic(sv, '*');
5428 Safefree(GvNAME(sv));
a5f75d66 5429 GvMULTI_off(sv);
850fabdf
GS		 5430
5431 /* need to keep SvANY(sv) in the right arena */
5432 xpvmg = new_XPVMG();
5433 StructCopy(SvANY(sv), xpvmg, XPVMG);
5434 del_XPVGV(SvANY(sv));
5435 SvANY(sv) = xpvmg;
5436
a0d0e21e
LW		 5437 SvFLAGS(sv) &= ~SVTYPEMASK;
5438 SvFLAGS(sv) |= SVt_PVMG;
5439}
5440
954c1994
GS		 5441/*
5442=for apidoc sv_unref
5443
5444Unsets the RV status of the SV, and decrements the reference count of
5445whatever was being referenced by the RV. This can almost be thought of
5446as a reversal of C<newSVrv>. See C<SvROK_off>.
5447
5448=cut
5449*/
5450
ed6116ce 5451void
864dbfa3 5452Perl_sv_unref(pTHX_ SV *sv)
ed6116ce 5453{
a0d0e21e 5454 SV* rv = SvRV(sv);
810b8aa5
GS		 5455
5456 if (SvWEAKREF(sv)) {
5457 sv_del_backref(sv);
5458 SvWEAKREF_off(sv);
5459 SvRV(sv) = 0;
5460 return;
5461 }
ed6116ce
LW		 5462 SvRV(sv) = 0;
5463 SvROK_off(sv);
4633a7c4
LW		 5464 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
5465 SvREFCNT_dec(rv);
8e07c86e 5466 else
4633a7c4 5467 sv_2mortal(rv); /* Schedule for freeing later */
ed6116ce 5468}
8990e307 5469
bbce6d69 5470void
864dbfa3 5471Perl_sv_taint(pTHX_ SV *sv)
bbce6d69 5472{
5473 sv_magic((sv), Nullsv, 't', Nullch, 0);
5474}
5475
5476void
864dbfa3 5477Perl_sv_untaint(pTHX_ SV *sv)
bbce6d69 5478{
13f57bf8 5479 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
36477c24 5480 MAGIC *mg = mg_find(sv, 't');
5481 if (mg)
565764a8 5482 mg->mg_len &= ~1;
36477c24 5483 }
bbce6d69 5484}
5485
5486bool
864dbfa3 5487Perl_sv_tainted(pTHX_ SV *sv)
bbce6d69 5488{
13f57bf8 5489 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
36477c24 5490 MAGIC *mg = mg_find(sv, 't');
155aba94 5491 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
36477c24 5492 return TRUE;
5493 }
5494 return FALSE;
bbce6d69 5495}
5496
954c1994
GS		 5497/*
5498=for apidoc sv_setpviv
5499
5500Copies an integer into the given SV, also updating its string value.
5501Does not handle 'set' magic. See C<sv_setpviv_mg>.
5502
5503=cut
5504*/
5505
84902520 5506void
864dbfa3 5507Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
84902520 5508{
25da4f38
IZ		 5509 char buf[TYPE_CHARS(UV)];
5510 char *ebuf;
5511 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
84902520 5512
25da4f38 5513 sv_setpvn(sv, ptr, ebuf - ptr);
84902520
TB		 5514}
5515
ef50df4b 5516
954c1994
GS		 5517/*
5518=for apidoc sv_setpviv_mg
5519
5520Like C<sv_setpviv>, but also handles 'set' magic.
5521
5522=cut
5523*/
5524
ef50df4b 5525void
864dbfa3 5526Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
ef50df4b 5527{
25da4f38
IZ		 5528 char buf[TYPE_CHARS(UV)];
5529 char *ebuf;
5530 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5531
5532 sv_setpvn(sv, ptr, ebuf - ptr);
ef50df4b
GS		 5533 SvSETMAGIC(sv);
5534}
5535
cea2e8a9
GS		 5536#if defined(PERL_IMPLICIT_CONTEXT)
5537void
5538Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
5539{
5540 dTHX;
5541 va_list args;
5542 va_start(args, pat);
c5be433b 5543 sv_vsetpvf(sv, pat, &args);
cea2e8a9
GS		 5544 va_end(args);
5545}
5546
5547
5548void
5549Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
5550{
5551 dTHX;
5552 va_list args;
5553 va_start(args, pat);
c5be433b 5554 sv_vsetpvf_mg(sv, pat, &args);
cea2e8a9 5555 va_end(args);
cea2e8a9
GS		 5556}
5557#endif
5558
954c1994
GS		 5559/*
5560=for apidoc sv_setpvf
5561
5562Processes its arguments like C<sprintf> and sets an SV to the formatted
5563output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
5564
5565=cut
5566*/
5567
46fc3d4c 5568void
864dbfa3 5569Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
46fc3d4c 5570{
5571 va_list args;
46fc3d4c 5572 va_start(args, pat);
c5be433b 5573 sv_vsetpvf(sv, pat, &args);
46fc3d4c 5574 va_end(args);
5575}
5576
c5be433b
GS		 5577void
5578Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5579{
5580 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5581}
ef50df4b 5582
954c1994
GS		 5583/*
5584=for apidoc sv_setpvf_mg
5585
5586Like C<sv_setpvf>, but also handles 'set' magic.
5587
5588=cut
5589*/
5590
ef50df4b 5591void
864dbfa3 5592Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
ef50df4b
GS		 5593{
5594 va_list args;
ef50df4b 5595 va_start(args, pat);
c5be433b 5596 sv_vsetpvf_mg(sv, pat, &args);
ef50df4b 5597 va_end(args);
c5be433b
GS		 5598}
5599
5600void
5601Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5602{
5603 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
ef50df4b
GS		 5604 SvSETMAGIC(sv);
5605}
5606
cea2e8a9
GS		 5607#if defined(PERL_IMPLICIT_CONTEXT)
5608void
5609Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
5610{
5611 dTHX;
5612 va_list args;
5613 va_start(args, pat);
c5be433b 5614 sv_vcatpvf(sv, pat, &args);
cea2e8a9
GS		 5615 va_end(args);
5616}
5617
5618void
5619Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
5620{
5621 dTHX;
5622 va_list args;
5623 va_start(args, pat);
c5be433b 5624 sv_vcatpvf_mg(sv, pat, &args);
cea2e8a9 5625 va_end(args);
cea2e8a9
GS		 5626}
5627#endif
5628
954c1994
GS		 5629/*
5630=for apidoc sv_catpvf
5631
5632Processes its arguments like C<sprintf> and appends the formatted output
5633to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
5634typically be called after calling this function to handle 'set' magic.
5635
5636=cut
5637*/
5638
46fc3d4c 5639void
864dbfa3 5640Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
46fc3d4c 5641{
5642 va_list args;
46fc3d4c 5643 va_start(args, pat);
c5be433b 5644 sv_vcatpvf(sv, pat, &args);
46fc3d4c 5645 va_end(args);
5646}
5647
ef50df4b 5648void
c5be433b
GS		 5649Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5650{
5651 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5652}
5653
954c1994
GS		 5654/*
5655=for apidoc sv_catpvf_mg
5656
5657Like C<sv_catpvf>, but also handles 'set' magic.
5658
5659=cut
5660*/
5661
c5be433b 5662void
864dbfa3 5663Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
ef50df4b
GS		 5664{
5665 va_list args;
ef50df4b 5666 va_start(args, pat);
c5be433b 5667 sv_vcatpvf_mg(sv, pat, &args);
ef50df4b 5668 va_end(args);
c5be433b
GS		 5669}
5670
5671void
5672Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5673{
5674 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
ef50df4b
GS		 5675 SvSETMAGIC(sv);
5676}
5677
954c1994
GS		 5678/*
5679=for apidoc sv_vsetpvfn
5680
5681Works like C<vcatpvfn> but copies the text into the SV instead of
5682appending it.
5683
5684=cut
5685*/
5686
46fc3d4c 5687void
7d5ea4e7 5688Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
46fc3d4c 5689{
5690 sv_setpvn(sv, "", 0);
7d5ea4e7 5691 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
46fc3d4c 5692}
5693
954c1994
GS		 5694/*
5695=for apidoc sv_vcatpvfn
5696
5697Processes its arguments like C<vsprintf> and appends the formatted output
5698to an SV. Uses an array of SVs if the C style variable argument list is
5699missing (NULL). When running with taint checks enabled, indicates via
5700C<maybe_tainted> if results are untrustworthy (often due to the use of
5701locales).
5702
5703=cut
5704*/
5705
46fc3d4c 5706void
7d5ea4e7 5707Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
46fc3d4c 5708{
e858de61 5709 dTHR;
46fc3d4c 5710 char *p;
5711 char *q;
5712 char *patend;
fc36a67e 5713 STRLEN origlen;
46fc3d4c 5714 I32 svix = 0;
c635e13b 5715 static char nullstr[] = "(null)";
7e2040f0 5716 SV *argsv;
46fc3d4c 5717
5718 /* no matter what, this is a string now */
fc36a67e 5719 (void)SvPV_force(sv, origlen);
46fc3d4c 5720
fc36a67e 5721 /* special-case "", "%s", and "%_" */
46fc3d4c 5722 if (patlen == 0)
5723 return;
fc36a67e 5724 if (patlen == 2 && pat[0] == '%') {
5725 switch (pat[1]) {
5726 case 's':
c635e13b 5727 if (args) {
5728 char *s = va_arg(*args, char*);
5729 sv_catpv(sv, s ? s : nullstr);
5730 }
7e2040f0 5731 else if (svix < svmax) {
fc36a67e 5732 sv_catsv(sv, *svargs);
7e2040f0
GS		 5733 if (DO_UTF8(*svargs))
5734 SvUTF8_on(sv);
5735 }
fc36a67e 5736 return;
5737 case '_':
5738 if (args) {
7e2040f0
GS		 5739 argsv = va_arg(*args, SV*);
5740 sv_catsv(sv, argsv);
5741 if (DO_UTF8(argsv))
5742 SvUTF8_on(sv);
fc36a67e 5743 return;
5744 }
5745 /* See comment on '_' below */
5746 break;
5747 }
46fc3d4c 5748 }
5749
5750 patend = (char*)pat + patlen;
5751 for (p = (char*)pat; p < patend; p = q) {
5752 bool alt = FALSE;
5753 bool left = FALSE;
b22c7a20
GS		 5754 bool vectorize = FALSE;
5755 bool utf = FALSE;
46fc3d4c 5756 char fill = ' ';
5757 char plus = 0;
5758 char intsize = 0;
5759 STRLEN width = 0;
fc36a67e 5760 STRLEN zeros = 0;
46fc3d4c 5761 bool has_precis = FALSE;
5762 STRLEN precis = 0;
7e2040f0 5763 bool is_utf = FALSE;
46fc3d4c 5764
5765 char esignbuf[4];
806e7201 5766 U8 utf8buf[UTF8_MAXLEN];
46fc3d4c 5767 STRLEN esignlen = 0;
5768
5769 char *eptr = Nullch;
fc36a67e 5770 STRLEN elen = 0;
089c015b
JH		 5771 /* Times 4: a decimal digit takes more than 3 binary digits.
5772 * NV_DIG: mantissa takes than many decimal digits.
5773 * Plus 32: Playing safe. */
5774 char ebuf[IV_DIG * 4 + NV_DIG + 32];
2d4389e4
JH		 5775 /* large enough for "%#.#f" --chip */
5776 /* what about long double NVs? --jhi */
b22c7a20
GS		 5777
5778 SV *vecsv;
a05b299f 5779 U8 *vecstr = Null(U8*);
b22c7a20 5780 STRLEN veclen = 0;
46fc3d4c 5781 char c;
5782 int i;
5783 unsigned base;
5784 IV iv;
5785 UV uv;
65202027 5786 NV nv;
46fc3d4c 5787 STRLEN have;
5788 STRLEN need;
5789 STRLEN gap;
b22c7a20
GS		 5790 char *dotstr = ".";
5791 STRLEN dotstrlen = 1;
46fc3d4c 5792
5793 for (q = p; q < patend && *q != '%'; ++q) ;
5794 if (q > p) {
5795 sv_catpvn(sv, p, q - p);
5796 p = q;
5797 }
5798 if (q++ >= patend)
5799 break;
5800
fc36a67e 5801 /* FLAGS */
5802
46fc3d4c 5803 while (*q) {
5804 switch (*q) {
5805 case ' ':
5806 case '+':
5807 plus = *q++;
5808 continue;
5809
5810 case '-':
5811 left = TRUE;
5812 q++;
5813 continue;
5814
5815 case '0':
5816 fill = *q++;
5817 continue;
5818
5819 case '#':
5820 alt = TRUE;
5821 q++;
5822 continue;
5823
b22c7a20
GS		 5824 case '*': /* printf("%*vX",":",$ipv6addr) */
5825 if (q[1] != 'v')
5826 break;
5827 q++;
5828 if (args)
5829 vecsv = va_arg(*args, SV*);
5830 else if (svix < svmax)
5831 vecsv = svargs[svix++];
9c3dd3fe
GS		 5832 else
5833 continue;
b22c7a20
GS		 5834 dotstr = SvPVx(vecsv,dotstrlen);
5835 if (DO_UTF8(vecsv))
5836 is_utf = TRUE;
5837 /* FALL THROUGH */
5838
5839 case 'v':
5840 vectorize = TRUE;
5841 q++;
5842 if (args)
5843 vecsv = va_arg(*args, SV*);
5844 else if (svix < svmax)
5845 vecsv = svargs[svix++];
9c3dd3fe 5846 else {
51486eaa 5847 vecstr = (U8*)"";
9c3dd3fe
GS		 5848 veclen = 0;
5849 continue;
5850 }
a05b299f 5851 vecstr = (U8*)SvPVx(vecsv,veclen);
b22c7a20
GS		 5852 utf = DO_UTF8(vecsv);
5853 continue;
5854
fc36a67e 5855 default:
5856 break;
5857 }
5858 break;
5859 }
46fc3d4c 5860
fc36a67e 5861 /* WIDTH */
5862
5863 switch (*q) {
5864 case '1': case '2': case '3':
5865 case '4': case '5': case '6':
5866 case '7': case '8': case '9':
5867 width = 0;
5868 while (isDIGIT(*q))
5869 width = width * 10 + (*q++ - '0');
5870 break;
5871
5872 case '*':
5873 if (args)
5874 i = va_arg(*args, int);
5875 else
5876 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5877 left |= (i < 0);
5878 width = (i < 0) ? -i : i;
5879 q++;
5880 break;
5881 }
5882
5883 /* PRECISION */
46fc3d4c 5884
fc36a67e 5885 if (*q == '.') {
5886 q++;
5887 if (*q == '*') {
46fc3d4c 5888 if (args)
5889 i = va_arg(*args, int);
5890 else
5891 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
fc36a67e 5892 precis = (i < 0) ? 0 : i;
46fc3d4c 5893 q++;
fc36a67e 5894 }
5895 else {
5896 precis = 0;
5897 while (isDIGIT(*q))
5898 precis = precis * 10 + (*q++ - '0');
5899 }
5900 has_precis = TRUE;
5901 }
46fc3d4c 5902
fc36a67e 5903 /* SIZE */
46fc3d4c 5904
fc36a67e 5905 switch (*q) {
6f9bb7fd
GS		 5906#ifdef HAS_QUAD
5907 case 'L': /* Ld */
5908 case 'q': /* qd */
5909 intsize = 'q';
5910 q++;
5911 break;
5912#endif
fc36a67e 5913 case 'l':
cf2093f6
JH		 5914#ifdef HAS_QUAD
5915 if (*(q + 1) == 'l') { /* lld */
fc36a67e 5916 intsize = 'q';
5917 q += 2;
46fc3d4c 5918 break;
cf2093f6 5919 }
fc36a67e 5920#endif
6f9bb7fd 5921 /* FALL THROUGH */
fc36a67e 5922 case 'h':
cf2093f6 5923 /* FALL THROUGH */
fc36a67e 5924 case 'V':
5925 intsize = *q++;
46fc3d4c 5926 break;
5927 }
5928
686fa4bb
JH		 5929#ifdef USE_64_BIT_INT
5930 if (!intsize)
5931 intsize = 'q';
5932#endif
5933
fc36a67e 5934 /* CONVERSION */
5935
46fc3d4c 5936 switch (c = *q++) {
5937
5938 /* STRINGS */
5939
5940 case '%':
5941 eptr = q - 1;
5942 elen = 1;
5943 goto string;
5944
5945 case 'c':
7e2040f0
GS		 5946 if (args)
5947 uv = va_arg(*args, int);
5948 else
5949 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
3969a896 5950 if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
dfe13c55
GS		 5951 eptr = (char*)utf8buf;
5952 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
7e2040f0
GS		 5953 is_utf = TRUE;
5954 }
5955 else {
5956 c = (char)uv;
5957 eptr = &c;
5958 elen = 1;
a0ed51b3 5959 }
46fc3d4c 5960 goto string;
5961
46fc3d4c 5962 case 's':
5963 if (args) {
fc36a67e 5964 eptr = va_arg(*args, char*);
c635e13b 5965 if (eptr)
1d7c1841
GS		 5966#ifdef MACOS_TRADITIONAL
5967 /* On MacOS, %#s format is used for Pascal strings */
5968 if (alt)
5969 elen = *eptr++;
5970 else
5971#endif
c635e13b 5972 elen = strlen(eptr);
5973 else {
5974 eptr = nullstr;
5975 elen = sizeof nullstr - 1;
5976 }
46fc3d4c 5977 }
a0ed51b3 5978 else if (svix < svmax) {
7e2040f0
GS		 5979 argsv = svargs[svix++];
5980 eptr = SvPVx(argsv, elen);
5981 if (DO_UTF8(argsv)) {
a0ed51b3
LW		 5982 if (has_precis && precis < elen) {
5983 I32 p = precis;
7e2040f0 5984 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
a0ed51b3
LW		 5985 precis = p;
5986 }
5987 if (width) { /* fudge width (can't fudge elen) */
7e2040f0 5988 width += elen - sv_len_utf8(argsv);
a0ed51b3 5989 }
7e2040f0 5990 is_utf = TRUE;
a0ed51b3
LW		 5991 }
5992 }
46fc3d4c 5993 goto string;
5994
fc36a67e 5995 case '_':
5996 /*
5997 * The "%_" hack might have to be changed someday,
5998 * if ISO or ANSI decide to use '_' for something.
5999 * So we keep it hidden from users' code.
6000 */
6001 if (!args)
6002 goto unknown;
7e2040f0
GS		 6003 argsv = va_arg(*args,SV*);
6004 eptr = SvPVx(argsv, elen);
6005 if (DO_UTF8(argsv))
6006 is_utf = TRUE;
fc36a67e 6007
46fc3d4c 6008 string:
b22c7a20 6009 vectorize = FALSE;
46fc3d4c 6010 if (has_precis && elen > precis)
6011 elen = precis;
6012 break;
6013
6014 /* INTEGERS */
6015
fc36a67e 6016 case 'p':
6017 if (args)
56431972 6018 uv = PTR2UV(va_arg(*args, void*));
fc36a67e 6019 else
56431972 6020 uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
fc36a67e 6021 base = 16;
6022 goto integer;
6023
46fc3d4c 6024 case 'D':
29fe7a80 6025#ifdef IV_IS_QUAD
22f3ae8c 6026 intsize = 'q';
29fe7a80 6027#else
46fc3d4c 6028 intsize = 'l';
29fe7a80 6029#endif
46fc3d4c 6030 /* FALL THROUGH */
6031 case 'd':
6032 case 'i':
b22c7a20
GS		 6033 if (vectorize) {
6034 I32 ulen;
6035 if (!veclen) {
6036 vectorize = FALSE;
6037 break;
6038 }
6039 if (utf)
6040 iv = (IV)utf8_to_uv(vecstr, &ulen);
6041 else {
a05b299f 6042 iv = *vecstr;
b22c7a20
GS		 6043 ulen = 1;
6044 }
6045 vecstr += ulen;
6046 veclen -= ulen;
6047 }
6048 else if (args) {
46fc3d4c 6049 switch (intsize) {
6050 case 'h': iv = (short)va_arg(*args, int); break;
6051 default: iv = va_arg(*args, int); break;
6052 case 'l': iv = va_arg(*args, long); break;
fc36a67e 6053 case 'V': iv = va_arg(*args, IV); break;
cf2093f6
JH		 6054#ifdef HAS_QUAD
6055 case 'q': iv = va_arg(*args, Quad_t); break;
6056#endif
46fc3d4c 6057 }
6058 }
6059 else {
6060 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6061 switch (intsize) {
6062 case 'h': iv = (short)iv; break;
6063 default: iv = (int)iv; break;
6064 case 'l': iv = (long)iv; break;
fc36a67e 6065 case 'V': break;
cf2093f6
JH		 6066#ifdef HAS_QUAD
6067 case 'q': iv = (Quad_t)iv; break;
6068#endif
46fc3d4c 6069 }
6070 }
6071 if (iv >= 0) {
6072 uv = iv;
6073 if (plus)
6074 esignbuf[esignlen++] = plus;
6075 }
6076 else {
6077 uv = -iv;
6078 esignbuf[esignlen++] = '-';
6079 }
6080 base = 10;
6081 goto integer;
6082
fc36a67e 6083 case 'U':
29fe7a80 6084#ifdef IV_IS_QUAD
22f3ae8c 6085 intsize = 'q';
29fe7a80 6086#else
fc36a67e 6087 intsize = 'l';
29fe7a80 6088#endif
fc36a67e 6089 /* FALL THROUGH */
6090 case 'u':
6091 base = 10;
6092 goto uns_integer;
6093
4f19785b
WSI		 6094 case 'b':
6095 base = 2;
6096 goto uns_integer;
6097
46fc3d4c 6098 case 'O':
29fe7a80 6099#ifdef IV_IS_QUAD
22f3ae8c 6100 intsize = 'q';
29fe7a80 6101#else
46fc3d4c 6102 intsize = 'l';
29fe7a80 6103#endif
46fc3d4c 6104 /* FALL THROUGH */
6105 case 'o':
6106 base = 8;
6107 goto uns_integer;
6108
6109 case 'X':
46fc3d4c 6110 case 'x':
6111 base = 16;
46fc3d4c 6112
6113 uns_integer:
b22c7a20
GS		 6114 if (vectorize) {
6115 I32 ulen;
6116 vector:
6117 if (!veclen) {
6118 vectorize = FALSE;
6119 break;
6120 }
6121 if (utf)
6122 uv = utf8_to_uv(vecstr, &ulen);
6123 else {
a05b299f 6124 uv = *vecstr;
b22c7a20
GS		 6125 ulen = 1;
6126 }
6127 vecstr += ulen;
6128 veclen -= ulen;
6129 }
6130 else if (args) {
46fc3d4c 6131 switch (intsize) {
6132 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
6133 default: uv = va_arg(*args, unsigned); break;
6134 case 'l': uv = va_arg(*args, unsigned long); break;
fc36a67e 6135 case 'V': uv = va_arg(*args, UV); break;
cf2093f6
JH		 6136#ifdef HAS_QUAD
6137 case 'q': uv = va_arg(*args, Quad_t); break;
6138#endif
46fc3d4c 6139 }
6140 }
6141 else {
6142 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
6143 switch (intsize) {
6144 case 'h': uv = (unsigned short)uv; break;
6145 default: uv = (unsigned)uv; break;
6146 case 'l': uv = (unsigned long)uv; break;
fc36a67e 6147 case 'V': break;
cf2093f6
JH		 6148#ifdef HAS_QUAD
6149 case 'q': uv = (Quad_t)uv; break;
6150#endif
46fc3d4c 6151 }
6152 }
6153
6154 integer:
46fc3d4c 6155 eptr = ebuf + sizeof ebuf;
fc36a67e 6156 switch (base) {
6157 unsigned dig;
6158 case 16:
c10ed8b9
HS		 6159 if (!uv)
6160 alt = FALSE;
1d7c1841
GS		 6161 p = (char*)((c == 'X')
6162 ? "0123456789ABCDEF" : "0123456789abcdef");
fc36a67e 6163 do {
6164 dig = uv & 15;
6165 *--eptr = p[dig];
6166 } while (uv >>= 4);
6167 if (alt) {
46fc3d4c 6168 esignbuf[esignlen++] = '0';
fc36a67e 6169 esignbuf[esignlen++] = c; /* 'x' or 'X' */
46fc3d4c 6170 }
fc36a67e 6171 break;
6172 case 8:
6173 do {
6174 dig = uv & 7;
6175 *--eptr = '0' + dig;
6176 } while (uv >>= 3);
6177 if (alt && *eptr != '0')
6178 *--eptr = '0';
6179 break;
4f19785b
WSI		 6180 case 2:
6181 do {
6182 dig = uv & 1;
6183 *--eptr = '0' + dig;
6184 } while (uv >>= 1);
eda88b6d
JH		 6185 if (alt) {
6186 esignbuf[esignlen++] = '0';
7481bb52 6187 esignbuf[esignlen++] = 'b';
eda88b6d 6188 }
4f19785b 6189 break;
fc36a67e 6190 default: /* it had better be ten or less */
6bc102ca 6191#if defined(PERL_Y2KWARN)
e476b1b5 6192 if (ckWARN(WARN_Y2K)) {
6bc102ca
GS		 6193 STRLEN n;
6194 char *s = SvPV(sv,n);
6195 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
6196 && (n == 2 || !isDIGIT(s[n-3])))
6197 {
e476b1b5 6198 Perl_warner(aTHX_ WARN_Y2K,
6bc102ca
GS		 6199 "Possible Y2K bug: %%%c %s",
6200 c, "format string following '19'");
6201 }
6202 }
6203#endif
fc36a67e 6204 do {
6205 dig = uv % base;
6206 *--eptr = '0' + dig;
6207 } while (uv /= base);
6208 break;
46fc3d4c 6209 }
6210 elen = (ebuf + sizeof ebuf) - eptr;
c10ed8b9
HS		 6211 if (has_precis) {
6212 if (precis > elen)
6213 zeros = precis - elen;
6214 else if (precis == 0 && elen == 1 && *eptr == '0')
6215 elen = 0;
6216 }
46fc3d4c 6217 break;
6218
6219 /* FLOATING POINT */
6220
fc36a67e 6221 case 'F':
6222 c = 'f'; /* maybe %F isn't supported here */
6223 /* FALL THROUGH */
46fc3d4c 6224 case 'e': case 'E':
fc36a67e 6225 case 'f':
46fc3d4c 6226 case 'g': case 'G':
6227
6228 /* This is evil, but floating point is even more evil */
6229
b22c7a20 6230 vectorize = FALSE;
fc36a67e 6231 if (args)
65202027 6232 nv = va_arg(*args, NV);
fc36a67e 6233 else
6234 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
6235
6236 need = 0;
6237 if (c != 'e' && c != 'E') {
6238 i = PERL_INT_MIN;
73b309ea 6239 (void)Perl_frexp(nv, &i);
fc36a67e 6240 if (i == PERL_INT_MIN)
cea2e8a9 6241 Perl_die(aTHX_ "panic: frexp");
c635e13b 6242 if (i > 0)
fc36a67e 6243 need = BIT_DIGITS(i);
6244 }
6245 need += has_precis ? precis : 6; /* known default */
6246 if (need < width)
6247 need = width;
6248
46fc3d4c 6249 need += 20; /* fudge factor */
80252599
GS		 6250 if (PL_efloatsize < need) {
6251 Safefree(PL_efloatbuf);
6252 PL_efloatsize = need + 20; /* more fudge */
6253 New(906, PL_efloatbuf, PL_efloatsize, char);
7d5ea4e7 6254 PL_efloatbuf[0] = '\0';
46fc3d4c 6255 }
6256
6257 eptr = ebuf + sizeof ebuf;
6258 *--eptr = '\0';
6259 *--eptr = c;
65202027 6260#ifdef USE_LONG_DOUBLE
cf2093f6 6261 {
7a7a2329 6262 static char const my_prifldbl[] = PERL_PRIfldbl;
f320eb41
JH		 6263 char const *p = my_prifldbl + sizeof my_prifldbl - 3;
6264 while (p >= my_prifldbl) { *--eptr = *p--; }
cf2093f6 6265 }
65202027 6266#endif
46fc3d4c 6267 if (has_precis) {
6268 base = precis;
6269 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6270 *--eptr = '.';
6271 }
6272 if (width) {
6273 base = width;
6274 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6275 }
6276 if (fill == '0')
6277 *--eptr = fill;
84902520
TB		 6278 if (left)
6279 *--eptr = '-';
46fc3d4c 6280 if (plus)
6281 *--eptr = plus;
6282 if (alt)
6283 *--eptr = '#';
6284 *--eptr = '%';
6285
097ee67d
JH		 6286 {
6287 RESTORE_NUMERIC_STANDARD();
6288 (void)sprintf(PL_efloatbuf, eptr, nv);
6289 RESTORE_NUMERIC_LOCAL();
6290 }
46fc3d4c 6291
80252599
GS		 6292 eptr = PL_efloatbuf;
6293 elen = strlen(PL_efloatbuf);
46fc3d4c 6294 break;
6295
fc36a67e 6296 /* SPECIAL */
6297
6298 case 'n':
b22c7a20 6299 vectorize = FALSE;
fc36a67e 6300 i = SvCUR(sv) - origlen;
6301 if (args) {
c635e13b 6302 switch (intsize) {
6303 case 'h': *(va_arg(*args, short*)) = i; break;
6304 default: *(va_arg(*args, int*)) = i; break;
6305 case 'l': *(va_arg(*args, long*)) = i; break;
6306 case 'V': *(va_arg(*args, IV*)) = i; break;
cf2093f6
JH		 6307#ifdef HAS_QUAD
6308 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
6309#endif
c635e13b 6310 }
fc36a67e 6311 }
6312 else if (svix < svmax)
6313 sv_setuv(svargs[svix++], (UV)i);
6314 continue; /* not "break" */
6315
6316 /* UNKNOWN */
6317
46fc3d4c 6318 default:
fc36a67e 6319 unknown:
b22c7a20 6320 vectorize = FALSE;
599cee73 6321 if (!args && ckWARN(WARN_PRINTF) &&
533c011a 6322 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
c635e13b 6323 SV *msg = sv_newmortal();
cea2e8a9 6324 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
533c011a 6325 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
0f4b6630 6326 if (c) {
0f4b6630
JH		 6327 if (isPRINT(c))
6328 Perl_sv_catpvf(aTHX_ msg,
6329 "\"%%%c\"", c & 0xFF);
6330 else
6331 Perl_sv_catpvf(aTHX_ msg,
57def98f 6332 "\"%%\\%03"UVof"\"",
0f4b6630 6333 (UV)c & 0xFF);
0f4b6630 6334 } else
c635e13b 6335 sv_catpv(msg, "end of string");
894356b3 6336 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
c635e13b 6337 }
fb73857a 6338
6339 /* output mangled stuff ... */
6340 if (c == '\0')
6341 --q;
46fc3d4c 6342 eptr = p;
6343 elen = q - p;
fb73857a 6344
6345 /* ... right here, because formatting flags should not apply */
6346 SvGROW(sv, SvCUR(sv) + elen + 1);
6347 p = SvEND(sv);
6348 memcpy(p, eptr, elen);
6349 p += elen;
6350 *p = '\0';
6351 SvCUR(sv) = p - SvPVX(sv);
6352 continue; /* not "break" */
46fc3d4c 6353 }
6354
fc36a67e 6355 have = esignlen + zeros + elen;
46fc3d4c 6356 need = (have > width ? have : width);
6357 gap = need - have;
6358
b22c7a20 6359 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
46fc3d4c 6360 p = SvEND(sv);
6361 if (esignlen && fill == '0') {
6362 for (i = 0; i < esignlen; i++)
6363 *p++ = esignbuf[i];
6364 }
6365 if (gap && !left) {
6366 memset(p, fill, gap);
6367 p += gap;
6368 }
6369 if (esignlen && fill != '0') {
6370 for (i = 0; i < esignlen; i++)
6371 *p++ = esignbuf[i];
6372 }
fc36a67e 6373 if (zeros) {
6374 for (i = zeros; i; i--)
6375 *p++ = '0';
6376 }
46fc3d4c 6377 if (elen) {
6378 memcpy(p, eptr, elen);
6379 p += elen;
6380 }
6381 if (gap && left) {
6382 memset(p, ' ', gap);
6383 p += gap;
6384 }
b22c7a20
GS		 6385 if (vectorize) {
6386 if (veclen) {
6387 memcpy(p, dotstr, dotstrlen);
6388 p += dotstrlen;
6389 }
6390 else
6391 vectorize = FALSE; /* done iterating over vecstr */
6392 }
7e2040f0
GS		 6393 if (is_utf)
6394 SvUTF8_on(sv);
46fc3d4c 6395 *p = '\0';
6396 SvCUR(sv) = p - SvPVX(sv);
b22c7a20
GS		 6397 if (vectorize) {
6398 esignlen = 0;
6399 goto vector;
6400 }
46fc3d4c 6401 }
6402}
51371543 6403
1d7c1841
GS		 6404#if defined(USE_ITHREADS)
6405
6406#if defined(USE_THREADS)
6407# include "error: USE_THREADS and USE_ITHREADS are incompatible"
6408#endif
6409
1d7c1841
GS		 6410#ifndef GpREFCNT_inc
6411# define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
6412#endif
6413
6414
6415#define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
6416#define av_dup(s) (AV*)sv_dup((SV*)s)
6417#define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
6418#define hv_dup(s) (HV*)sv_dup((SV*)s)
6419#define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
6420#define cv_dup(s) (CV*)sv_dup((SV*)s)
6421#define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
6422#define io_dup(s) (IO*)sv_dup((SV*)s)
6423#define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
6424#define gv_dup(s) (GV*)sv_dup((SV*)s)
6425#define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
6426#define SAVEPV(p) (p ? savepv(p) : Nullch)
6427#define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
6428
6429REGEXP *
6430Perl_re_dup(pTHX_ REGEXP *r)
6431{
6432 /* XXX fix when pmop->op_pmregexp becomes shared */
6433 return ReREFCNT_inc(r);
6434}
6435
6436PerlIO *
6437Perl_fp_dup(pTHX_ PerlIO *fp, char type)
6438{
6439 PerlIO *ret;
6440 if (!fp)
6441 return (PerlIO*)NULL;
6442
6443 /* look for it in the table first */
6444 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
6445 if (ret)
6446 return ret;
6447
6448 /* create anew and remember what it is */
6449 ret = PerlIO_fdupopen(fp);
6450 ptr_table_store(PL_ptr_table, fp, ret);
6451 return ret;
6452}
6453
6454DIR *
6455Perl_dirp_dup(pTHX_ DIR *dp)
6456{
6457 if (!dp)
6458 return (DIR*)NULL;
6459 /* XXX TODO */
6460 return dp;
6461}
6462
6463GP *
6464Perl_gp_dup(pTHX_ GP *gp)
6465{
6466 GP *ret;
6467 if (!gp)
6468 return (GP*)NULL;
6469 /* look for it in the table first */
6470 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
6471 if (ret)
6472 return ret;
6473
6474 /* create anew and remember what it is */
6475 Newz(0, ret, 1, GP);
6476 ptr_table_store(PL_ptr_table, gp, ret);
6477
6478 /* clone */
6479 ret->gp_refcnt = 0; /* must be before any other dups! */
6480 ret->gp_sv = sv_dup_inc(gp->gp_sv);
6481 ret->gp_io = io_dup_inc(gp->gp_io);
6482 ret->gp_form = cv_dup_inc(gp->gp_form);
6483 ret->gp_av = av_dup_inc(gp->gp_av);
6484 ret->gp_hv = hv_dup_inc(gp->gp_hv);
6485 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
6486 ret->gp_cv = cv_dup_inc(gp->gp_cv);
6487 ret->gp_cvgen = gp->gp_cvgen;
6488 ret->gp_flags = gp->gp_flags;
6489 ret->gp_line = gp->gp_line;
6490 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
6491 return ret;
6492}
6493
6494MAGIC *
6495Perl_mg_dup(pTHX_ MAGIC *mg)
6496{
6497 MAGIC *mgret = (MAGIC*)NULL;
6498 MAGIC *mgprev;
6499 if (!mg)
6500 return (MAGIC*)NULL;
6501 /* look for it in the table first */
6502 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
6503 if (mgret)
6504 return mgret;
6505
6506 for (; mg; mg = mg->mg_moremagic) {
6507 MAGIC *nmg;
6508 Newz(0, nmg, 1, MAGIC);
6509 if (!mgret)
6510 mgret = nmg;
6511 else
6512 mgprev->mg_moremagic = nmg;
6513 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
6514 nmg->mg_private = mg->mg_private;
6515 nmg->mg_type = mg->mg_type;
6516 nmg->mg_flags = mg->mg_flags;
6517 if (mg->mg_type == 'r') {
6518 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
6519 }
6520 else {
6521 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
6522 ? sv_dup_inc(mg->mg_obj)
6523 : sv_dup(mg->mg_obj);
6524 }
6525 nmg->mg_len = mg->mg_len;
6526 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
6527 if (mg->mg_ptr && mg->mg_type != 'g') {
6528 if (mg->mg_len >= 0) {
6529 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
6530 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
6531 AMT *amtp = (AMT*)mg->mg_ptr;
6532 AMT *namtp = (AMT*)nmg->mg_ptr;
6533 I32 i;
6534 for (i = 1; i < NofAMmeth; i++) {
6535 namtp->table[i] = cv_dup_inc(amtp->table[i]);
6536 }
6537 }
6538 }
6539 else if (mg->mg_len == HEf_SVKEY)
6540 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
6541 }
6542 mgprev = nmg;
6543 }
6544 return mgret;
6545}
6546
6547PTR_TBL_t *
6548Perl_ptr_table_new(pTHX)
6549{
6550 PTR_TBL_t *tbl;
6551 Newz(0, tbl, 1, PTR_TBL_t);
6552 tbl->tbl_max = 511;
6553 tbl->tbl_items = 0;
6554 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
6555 return tbl;
6556}
6557
6558void *
6559Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
6560{
6561 PTR_TBL_ENT_t *tblent;
d2a79402 6562 UV hash = PTR2UV(sv);
1d7c1841
GS		 6563 assert(tbl);
6564 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
6565 for (; tblent; tblent = tblent->next) {
6566 if (tblent->oldval == sv)
6567 return tblent->newval;
6568 }
6569 return (void*)NULL;
6570}
6571
6572void
6573Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
6574{
6575 PTR_TBL_ENT_t *tblent, **otblent;
6576 /* XXX this may be pessimal on platforms where pointers aren't good
6577 * hash values e.g. if they grow faster in the most significant
6578 * bits */
d2a79402 6579 UV hash = PTR2UV(oldv);
1d7c1841
GS		 6580 bool i = 1;
6581
6582 assert(tbl);
6583 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
6584 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
6585 if (tblent->oldval == oldv) {
6586 tblent->newval = newv;
6587 tbl->tbl_items++;
6588 return;
6589 }
6590 }
6591 Newz(0, tblent, 1, PTR_TBL_ENT_t);
6592 tblent->oldval = oldv;
6593 tblent->newval = newv;
6594 tblent->next = *otblent;
6595 *otblent = tblent;
6596 tbl->tbl_items++;
6597 if (i && tbl->tbl_items > tbl->tbl_max)
6598 ptr_table_split(tbl);
6599}
6600
6601void
6602Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
6603{
6604 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
6605 UV oldsize = tbl->tbl_max + 1;
6606 UV newsize = oldsize * 2;
6607 UV i;
6608
6609 Renew(ary, newsize, PTR_TBL_ENT_t*);
6610 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
6611 tbl->tbl_max = --newsize;
6612 tbl->tbl_ary = ary;
6613 for (i=0; i < oldsize; i++, ary++) {
6614 PTR_TBL_ENT_t **curentp, **entp, *ent;
6615 if (!*ary)
6616 continue;
6617 curentp = ary + oldsize;
6618 for (entp = ary, ent = *ary; ent; ent = *entp) {
d2a79402 6619 if ((newsize & PTR2UV(ent->oldval)) != i) {
1d7c1841
GS		 6620 *entp = ent->next;
6621 ent->next = *curentp;
6622 *curentp = ent;
6623 continue;
6624 }
6625 else
6626 entp = &ent->next;
6627 }
6628 }
6629}
6630
6631#ifdef DEBUGGING
6632char *PL_watch_pvx;
6633#endif
6634
6635SV *
6636Perl_sv_dup(pTHX_ SV *sstr)
6637{
1d7c1841
GS		 6638 SV *dstr;
6639
6640 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
6641 return Nullsv;
6642 /* look for it in the table first */
6643 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
6644 if (dstr)
6645 return dstr;
6646
6647 /* create anew and remember what it is */
6648 new_SV(dstr);
6649 ptr_table_store(PL_ptr_table, sstr, dstr);
6650
6651 /* clone */
6652 SvFLAGS(dstr) = SvFLAGS(sstr);
6653 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
6654 SvREFCNT(dstr) = 0; /* must be before any other dups! */
6655
6656#ifdef DEBUGGING
6657 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
6658 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
6659 PL_watch_pvx, SvPVX(sstr));
6660#endif
6661
6662 switch (SvTYPE(sstr)) {
6663 case SVt_NULL:
6664 SvANY(dstr) = NULL;
6665 break;
6666 case SVt_IV:
6667 SvANY(dstr) = new_XIV();
6668 SvIVX(dstr) = SvIVX(sstr);
6669 break;
6670 case SVt_NV:
6671 SvANY(dstr) = new_XNV();
6672 SvNVX(dstr) = SvNVX(sstr);
6673 break;
6674 case SVt_RV:
6675 SvANY(dstr) = new_XRV();
6676 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6677 break;
6678 case SVt_PV:
6679 SvANY(dstr) = new_XPV();
6680 SvCUR(dstr) = SvCUR(sstr);
6681 SvLEN(dstr) = SvLEN(sstr);
6682 if (SvROK(sstr))
6683 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6684 else if (SvPVX(sstr) && SvLEN(sstr))
6685 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6686 else
6687 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6688 break;
6689 case SVt_PVIV:
6690 SvANY(dstr) = new_XPVIV();
6691 SvCUR(dstr) = SvCUR(sstr);
6692 SvLEN(dstr) = SvLEN(sstr);
6693 SvIVX(dstr) = SvIVX(sstr);
6694 if (SvROK(sstr))
6695 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6696 else if (SvPVX(sstr) && SvLEN(sstr))
6697 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6698 else
6699 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6700 break;
6701 case SVt_PVNV:
6702 SvANY(dstr) = new_XPVNV();
6703 SvCUR(dstr) = SvCUR(sstr);
6704 SvLEN(dstr) = SvLEN(sstr);
6705 SvIVX(dstr) = SvIVX(sstr);
6706 SvNVX(dstr) = SvNVX(sstr);
6707 if (SvROK(sstr))
6708 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6709 else if (SvPVX(sstr) && SvLEN(sstr))
6710 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6711 else
6712 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6713 break;
6714 case SVt_PVMG:
6715 SvANY(dstr) = new_XPVMG();
6716 SvCUR(dstr) = SvCUR(sstr);
6717 SvLEN(dstr) = SvLEN(sstr);
6718 SvIVX(dstr) = SvIVX(sstr);
6719 SvNVX(dstr) = SvNVX(sstr);
6720 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6721 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6722 if (SvROK(sstr))
6723 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6724 else if (SvPVX(sstr) && SvLEN(sstr))
6725 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6726 else
6727 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6728 break;
6729 case SVt_PVBM:
6730 SvANY(dstr) = new_XPVBM();
6731 SvCUR(dstr) = SvCUR(sstr);
6732 SvLEN(dstr) = SvLEN(sstr);
6733 SvIVX(dstr) = SvIVX(sstr);
6734 SvNVX(dstr) = SvNVX(sstr);
6735 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6736 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6737 if (SvROK(sstr))
6738 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6739 else if (SvPVX(sstr) && SvLEN(sstr))
6740 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6741 else
6742 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6743 BmRARE(dstr) = BmRARE(sstr);
6744 BmUSEFUL(dstr) = BmUSEFUL(sstr);
6745 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
6746 break;
6747 case SVt_PVLV:
6748 SvANY(dstr) = new_XPVLV();
6749 SvCUR(dstr) = SvCUR(sstr);
6750 SvLEN(dstr) = SvLEN(sstr);
6751 SvIVX(dstr) = SvIVX(sstr);
6752 SvNVX(dstr) = SvNVX(sstr);
6753 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6754 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6755 if (SvROK(sstr))
6756 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6757 else if (SvPVX(sstr) && SvLEN(sstr))
6758 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6759 else
6760 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6761 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
6762 LvTARGLEN(dstr) = LvTARGLEN(sstr);
6763 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
6764 LvTYPE(dstr) = LvTYPE(sstr);
6765 break;
6766 case SVt_PVGV:
6767 SvANY(dstr) = new_XPVGV();
6768 SvCUR(dstr) = SvCUR(sstr);
6769 SvLEN(dstr) = SvLEN(sstr);
6770 SvIVX(dstr) = SvIVX(sstr);
6771 SvNVX(dstr) = SvNVX(sstr);
6772 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6773 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6774 if (SvROK(sstr))
6775 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6776 else if (SvPVX(sstr) && SvLEN(sstr))
6777 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6778 else
6779 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6780 GvNAMELEN(dstr) = GvNAMELEN(sstr);
6781 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
6782 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
6783 GvFLAGS(dstr) = GvFLAGS(sstr);
6784 GvGP(dstr) = gp_dup(GvGP(sstr));
6785 (void)GpREFCNT_inc(GvGP(dstr));
6786 break;
6787 case SVt_PVIO:
6788 SvANY(dstr) = new_XPVIO();
6789 SvCUR(dstr) = SvCUR(sstr);
6790 SvLEN(dstr) = SvLEN(sstr);
6791 SvIVX(dstr) = SvIVX(sstr);
6792 SvNVX(dstr) = SvNVX(sstr);
6793 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6794 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6795 if (SvROK(sstr))
6796 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6797 else if (SvPVX(sstr) && SvLEN(sstr))
6798 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6799 else
6800 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6801 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
6802 if (IoOFP(sstr) == IoIFP(sstr))
6803 IoOFP(dstr) = IoIFP(dstr);
6804 else
6805 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
6806 /* PL_rsfp_filters entries have fake IoDIRP() */
6807 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
6808 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
6809 else
6810 IoDIRP(dstr) = IoDIRP(sstr);
6811 IoLINES(dstr) = IoLINES(sstr);
6812 IoPAGE(dstr) = IoPAGE(sstr);
6813 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
6814 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
6815 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
6816 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
6817 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
6818 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
6819 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
6820 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
6821 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
6822 IoTYPE(dstr) = IoTYPE(sstr);
6823 IoFLAGS(dstr) = IoFLAGS(sstr);
6824 break;
6825 case SVt_PVAV:
6826 SvANY(dstr) = new_XPVAV();
6827 SvCUR(dstr) = SvCUR(sstr);
6828 SvLEN(dstr) = SvLEN(sstr);
6829 SvIVX(dstr) = SvIVX(sstr);
6830 SvNVX(dstr) = SvNVX(sstr);
6831 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6832 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6833 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
6834 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
6835 if (AvARRAY((AV*)sstr)) {
6836 SV **dst_ary, **src_ary;
6837 SSize_t items = AvFILLp((AV*)sstr) + 1;
6838
6839 src_ary = AvARRAY((AV*)sstr);
6840 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
6841 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
6842 SvPVX(dstr) = (char*)dst_ary;
6843 AvALLOC((AV*)dstr) = dst_ary;
6844 if (AvREAL((AV*)sstr)) {
6845 while (items-- > 0)
6846 *dst_ary++ = sv_dup_inc(*src_ary++);
6847 }
6848 else {
6849 while (items-- > 0)
6850 *dst_ary++ = sv_dup(*src_ary++);
6851 }
6852 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
6853 while (items-- > 0) {
6854 *dst_ary++ = &PL_sv_undef;
6855 }
6856 }
6857 else {
6858 SvPVX(dstr) = Nullch;
6859 AvALLOC((AV*)dstr) = (SV**)NULL;
6860 }
6861 break;
6862 case SVt_PVHV:
6863 SvANY(dstr) = new_XPVHV();
6864 SvCUR(dstr) = SvCUR(sstr);
6865 SvLEN(dstr) = SvLEN(sstr);
6866 SvIVX(dstr) = SvIVX(sstr);
6867 SvNVX(dstr) = SvNVX(sstr);
6868 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6869 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6870 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
6871 if (HvARRAY((HV*)sstr)) {
1d7c1841
GS		 6872 STRLEN i = 0;
6873 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
6874 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
6875 Newz(0, dxhv->xhv_array,
6876 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
6877 while (i <= sxhv->xhv_max) {
6878 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
6879 !!HvSHAREKEYS(sstr));
6880 ++i;
6881 }
6882 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
6883 }
6884 else {
6885 SvPVX(dstr) = Nullch;
6886 HvEITER((HV*)dstr) = (HE*)NULL;
6887 }
6888 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
6889 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
6890 break;
6891 case SVt_PVFM:
6892 SvANY(dstr) = new_XPVFM();
6893 FmLINES(dstr) = FmLINES(sstr);
6894 goto dup_pvcv;
6895 /* NOTREACHED */
6896 case SVt_PVCV:
6897 SvANY(dstr) = new_XPVCV();
6898dup_pvcv:
6899 SvCUR(dstr) = SvCUR(sstr);
6900 SvLEN(dstr) = SvLEN(sstr);
6901 SvIVX(dstr) = SvIVX(sstr);
6902 SvNVX(dstr) = SvNVX(sstr);
6903 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6904 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6905 if (SvPVX(sstr) && SvLEN(sstr))
6906 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6907 else
6908 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6909 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
6910 CvSTART(dstr) = CvSTART(sstr);
6911 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
6912 CvXSUB(dstr) = CvXSUB(sstr);
6913 CvXSUBANY(dstr) = CvXSUBANY(sstr);
6914 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
6915 CvDEPTH(dstr) = CvDEPTH(sstr);
6916 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
6917 /* XXX padlists are real, but pretend to be not */
6918 AvREAL_on(CvPADLIST(sstr));
6919 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
6920 AvREAL_off(CvPADLIST(sstr));
6921 AvREAL_off(CvPADLIST(dstr));
6922 }
6923 else
6924 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
6925 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
6926 CvFLAGS(dstr) = CvFLAGS(sstr);
6927 break;
6928 default:
6929 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
6930 break;
6931 }
6932
6933 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
6934 ++PL_sv_objcount;
6935
6936 return dstr;
6937}
6938
6939PERL_CONTEXT *
6940Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
6941{
6942 PERL_CONTEXT *ncxs;
6943
6944 if (!cxs)
6945 return (PERL_CONTEXT*)NULL;
6946
6947 /* look for it in the table first */
6948 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
6949 if (ncxs)
6950 return ncxs;
6951
6952 /* create anew and remember what it is */
6953 Newz(56, ncxs, max + 1, PERL_CONTEXT);
6954 ptr_table_store(PL_ptr_table, cxs, ncxs);
6955
6956 while (ix >= 0) {
6957 PERL_CONTEXT *cx = &cxs[ix];
6958 PERL_CONTEXT *ncx = &ncxs[ix];
6959 ncx->cx_type = cx->cx_type;
6960 if (CxTYPE(cx) == CXt_SUBST) {
6961 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
6962 }
6963 else {
6964 ncx->blk_oldsp = cx->blk_oldsp;
6965 ncx->blk_oldcop = cx->blk_oldcop;
6966 ncx->blk_oldretsp = cx->blk_oldretsp;
6967 ncx->blk_oldmarksp = cx->blk_oldmarksp;
6968 ncx->blk_oldscopesp = cx->blk_oldscopesp;
6969 ncx->blk_oldpm = cx->blk_oldpm;
6970 ncx->blk_gimme = cx->blk_gimme;
6971 switch (CxTYPE(cx)) {
6972 case CXt_SUB:
6973 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
6974 ? cv_dup_inc(cx->blk_sub.cv)
6975 : cv_dup(cx->blk_sub.cv));
6976 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
6977 ? av_dup_inc(cx->blk_sub.argarray)
6978 : Nullav);
6979 ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
6980 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
6981 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
6982 ncx->blk_sub.lval = cx->blk_sub.lval;
6983 break;
6984 case CXt_EVAL:
6985 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
6986 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
0f79a09d 6987 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
1d7c1841
GS		 6988 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
6989 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
6990 break;
6991 case CXt_LOOP:
6992 ncx->blk_loop.label = cx->blk_loop.label;
6993 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
6994 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
6995 ncx->blk_loop.next_op = cx->blk_loop.next_op;
6996 ncx->blk_loop.last_op = cx->blk_loop.last_op;
6997 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
6998 ? cx->blk_loop.iterdata
6999 : gv_dup((GV*)cx->blk_loop.iterdata));
a4b82a6f
GS		 7000 ncx->blk_loop.oldcurpad
7001 = (SV**)ptr_table_fetch(PL_ptr_table,
7002 cx->blk_loop.oldcurpad);
1d7c1841
GS		 7003 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
7004 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
7005 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
7006 ncx->blk_loop.iterix = cx->blk_loop.iterix;
7007 ncx->blk_loop.itermax = cx->blk_loop.itermax;
7008 break;
7009 case CXt_FORMAT:
7010 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
7011 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
7012 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
7013 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
7014 break;
7015 case CXt_BLOCK:
7016 case CXt_NULL:
7017 break;
7018 }
7019 }
7020 --ix;
7021 }
7022 return ncxs;
7023}
7024
7025PERL_SI *
7026Perl_si_dup(pTHX_ PERL_SI *si)
7027{
7028 PERL_SI *nsi;
7029
7030 if (!si)
7031 return (PERL_SI*)NULL;
7032
7033 /* look for it in the table first */
7034 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
7035 if (nsi)
7036 return nsi;
7037
7038 /* create anew and remember what it is */
7039 Newz(56, nsi, 1, PERL_SI);
7040 ptr_table_store(PL_ptr_table, si, nsi);
7041
7042 nsi->si_stack = av_dup_inc(si->si_stack);
7043 nsi->si_cxix = si->si_cxix;
7044 nsi->si_cxmax = si->si_cxmax;
7045 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
7046 nsi->si_type = si->si_type;
7047 nsi->si_prev = si_dup(si->si_prev);
7048 nsi->si_next = si_dup(si->si_next);
7049 nsi->si_markoff = si->si_markoff;
7050
7051 return nsi;
7052}
7053
7054#define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
7055#define TOPINT(ss,ix) ((ss)[ix].any_i32)
7056#define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
7057#define TOPLONG(ss,ix) ((ss)[ix].any_long)
7058#define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
7059#define TOPIV(ss,ix) ((ss)[ix].any_iv)
7060#define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
7061#define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
7062#define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
7063#define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
7064#define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
7065#define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
7066
7067/* XXXXX todo */
7068#define pv_dup_inc(p) SAVEPV(p)
7069#define pv_dup(p) SAVEPV(p)
7070#define svp_dup_inc(p,pp) any_dup(p,pp)
7071
7072void *
7073Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
7074{
7075 void *ret;
7076
7077 if (!v)
7078 return (void*)NULL;
7079
7080 /* look for it in the table first */
7081 ret = ptr_table_fetch(PL_ptr_table, v);
7082 if (ret)
7083 return ret;
7084
7085 /* see if it is part of the interpreter structure */
7086 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
7087 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
7088 else
7089 ret = v;
7090
7091 return ret;
7092}
7093
7094ANY *
7095Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
7096{
7097 ANY *ss = proto_perl->Tsavestack;
7098 I32 ix = proto_perl->Tsavestack_ix;
7099 I32 max = proto_perl->Tsavestack_max;
7100 ANY *nss;
7101 SV *sv;
7102 GV *gv;
7103 AV *av;
7104 HV *hv;
7105 void* ptr;
7106 int intval;
7107 long longval;
7108 GP *gp;
7109 IV iv;
7110 I32 i;
7111 char *c;
7112 void (*dptr) (void*);
7113 void (*dxptr) (pTHXo_ void*);
e977893f 7114 OP *o;
1d7c1841
GS		 7115
7116 Newz(54, nss, max, ANY);
7117
7118 while (ix > 0) {
7119 i = POPINT(ss,ix);
7120 TOPINT(nss,ix) = i;
7121 switch (i) {
7122 case SAVEt_ITEM: /* normal string */
7123 sv = (SV*)POPPTR(ss,ix);
7124 TOPPTR(nss,ix) = sv_dup_inc(sv);
7125 sv = (SV*)POPPTR(ss,ix);
7126 TOPPTR(nss,ix) = sv_dup_inc(sv);
7127 break;
7128 case SAVEt_SV: /* scalar reference */
7129 sv = (SV*)POPPTR(ss,ix);
7130 TOPPTR(nss,ix) = sv_dup_inc(sv);
7131 gv = (GV*)POPPTR(ss,ix);
7132 TOPPTR(nss,ix) = gv_dup_inc(gv);
7133 break;
7134 case SAVEt_GENERIC_SVREF: /* generic sv */
7135 case SAVEt_SVREF: /* scalar reference */
7136 sv = (SV*)POPPTR(ss,ix);
7137 TOPPTR(nss,ix) = sv_dup_inc(sv);
7138 ptr = POPPTR(ss,ix);
7139 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
7140 break;
7141 case SAVEt_AV: /* array reference */
7142 av = (AV*)POPPTR(ss,ix);
7143 TOPPTR(nss,ix) = av_dup_inc(av);
7144 gv = (GV*)POPPTR(ss,ix);
7145 TOPPTR(nss,ix) = gv_dup(gv);
7146 break;
7147 case SAVEt_HV: /* hash reference */
7148 hv = (HV*)POPPTR(ss,ix);
7149 TOPPTR(nss,ix) = hv_dup_inc(hv);
7150 gv = (GV*)POPPTR(ss,ix);
7151 TOPPTR(nss,ix) = gv_dup(gv);
7152 break;
7153 case SAVEt_INT: /* int reference */
7154 ptr = POPPTR(ss,ix);
7155 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7156 intval = (int)POPINT(ss,ix);
7157 TOPINT(nss,ix) = intval;
7158 break;
7159 case SAVEt_LONG: /* long reference */
7160 ptr = POPPTR(ss,ix);
7161 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7162 longval = (long)POPLONG(ss,ix);
7163 TOPLONG(nss,ix) = longval;
7164 break;
7165 case SAVEt_I32: /* I32 reference */
7166 case SAVEt_I16: /* I16 reference */
7167 case SAVEt_I8: /* I8 reference */
7168 ptr = POPPTR(ss,ix);
7169 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7170 i = POPINT(ss,ix);
7171 TOPINT(nss,ix) = i;
7172 break;
7173 case SAVEt_IV: /* IV reference */
7174 ptr = POPPTR(ss,ix);
7175 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7176 iv = POPIV(ss,ix);
7177 TOPIV(nss,ix) = iv;
7178 break;
7179 case SAVEt_SPTR: /* SV* reference */
7180 ptr = POPPTR(ss,ix);
7181 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7182 sv = (SV*)POPPTR(ss,ix);
7183 TOPPTR(nss,ix) = sv_dup(sv);
7184 break;
7185 case SAVEt_VPTR: /* random* reference */
7186 ptr = POPPTR(ss,ix);
7187 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7188 ptr = POPPTR(ss,ix);
7189 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7190 break;
7191 case SAVEt_PPTR: /* char* reference */
7192 ptr = POPPTR(ss,ix);
7193 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7194 c = (char*)POPPTR(ss,ix);
7195 TOPPTR(nss,ix) = pv_dup(c);
7196 break;
7197 case SAVEt_HPTR: /* HV* reference */
7198 ptr = POPPTR(ss,ix);
7199 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7200 hv = (HV*)POPPTR(ss,ix);
7201 TOPPTR(nss,ix) = hv_dup(hv);
7202 break;
7203 case SAVEt_APTR: /* AV* reference */
7204 ptr = POPPTR(ss,ix);
7205 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7206 av = (AV*)POPPTR(ss,ix);
7207 TOPPTR(nss,ix) = av_dup(av);
7208 break;
7209 case SAVEt_NSTAB:
7210 gv = (GV*)POPPTR(ss,ix);
7211 TOPPTR(nss,ix) = gv_dup(gv);
7212 break;
7213 case SAVEt_GP: /* scalar reference */
7214 gp = (GP*)POPPTR(ss,ix);
7215 TOPPTR(nss,ix) = gp = gp_dup(gp);
7216 (void)GpREFCNT_inc(gp);
7217 gv = (GV*)POPPTR(ss,ix);
7218 TOPPTR(nss,ix) = gv_dup_inc(c);
7219 c = (char*)POPPTR(ss,ix);
7220 TOPPTR(nss,ix) = pv_dup(c);
7221 iv = POPIV(ss,ix);
7222 TOPIV(nss,ix) = iv;
7223 iv = POPIV(ss,ix);
7224 TOPIV(nss,ix) = iv;
7225 break;
7226 case SAVEt_FREESV:
7227 sv = (SV*)POPPTR(ss,ix);
7228 TOPPTR(nss,ix) = sv_dup_inc(sv);
7229 break;
7230 case SAVEt_FREEOP:
7231 ptr = POPPTR(ss,ix);
7232 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
7233 /* these are assumed to be refcounted properly */
7234 switch (((OP*)ptr)->op_type) {
7235 case OP_LEAVESUB:
7236 case OP_LEAVESUBLV:
7237 case OP_LEAVEEVAL:
7238 case OP_LEAVE:
7239 case OP_SCOPE:
7240 case OP_LEAVEWRITE:
e977893f
GS		 7241 TOPPTR(nss,ix) = ptr;
7242 o = (OP*)ptr;
7243 OpREFCNT_inc(o);
1d7c1841
GS		 7244 break;
7245 default:
7246 TOPPTR(nss,ix) = Nullop;
7247 break;
7248 }
7249 }
7250 else
7251 TOPPTR(nss,ix) = Nullop;
7252 break;
7253 case SAVEt_FREEPV:
7254 c = (char*)POPPTR(ss,ix);
7255 TOPPTR(nss,ix) = pv_dup_inc(c);
7256 break;
7257 case SAVEt_CLEARSV:
7258 longval = POPLONG(ss,ix);
7259 TOPLONG(nss,ix) = longval;
7260 break;
7261 case SAVEt_DELETE:
7262 hv = (HV*)POPPTR(ss,ix);
7263 TOPPTR(nss,ix) = hv_dup_inc(hv);
7264 c = (char*)POPPTR(ss,ix);
7265 TOPPTR(nss,ix) = pv_dup_inc(c);
7266 i = POPINT(ss,ix);
7267 TOPINT(nss,ix) = i;
7268 break;
7269 case SAVEt_DESTRUCTOR:
7270 ptr = POPPTR(ss,ix);
7271 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7272 dptr = POPDPTR(ss,ix);
ef75a179 7273 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
1d7c1841
GS		 7274 break;
7275 case SAVEt_DESTRUCTOR_X:
7276 ptr = POPPTR(ss,ix);
7277 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7278 dxptr = POPDXPTR(ss,ix);
ef75a179 7279 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
1d7c1841
GS		 7280 break;
7281 case SAVEt_REGCONTEXT:
7282 case SAVEt_ALLOC:
7283 i = POPINT(ss,ix);
7284 TOPINT(nss,ix) = i;
7285 ix -= i;
7286 break;
7287 case SAVEt_STACK_POS: /* Position on Perl stack */
7288 i = POPINT(ss,ix);
7289 TOPINT(nss,ix) = i;
7290 break;
7291 case SAVEt_AELEM: /* array element */
7292 sv = (SV*)POPPTR(ss,ix);
7293 TOPPTR(nss,ix) = sv_dup_inc(sv);
7294 i = POPINT(ss,ix);
7295 TOPINT(nss,ix) = i;
7296 av = (AV*)POPPTR(ss,ix);
7297 TOPPTR(nss,ix) = av_dup_inc(av);
7298 break;
7299 case SAVEt_HELEM: /* hash element */
7300 sv = (SV*)POPPTR(ss,ix);
7301 TOPPTR(nss,ix) = sv_dup_inc(sv);
7302 sv = (SV*)POPPTR(ss,ix);
7303 TOPPTR(nss,ix) = sv_dup_inc(sv);
7304 hv = (HV*)POPPTR(ss,ix);
7305 TOPPTR(nss,ix) = hv_dup_inc(hv);
7306 break;
7307 case SAVEt_OP:
7308 ptr = POPPTR(ss,ix);
7309 TOPPTR(nss,ix) = ptr;
7310 break;
7311 case SAVEt_HINTS:
7312 i = POPINT(ss,ix);
7313 TOPINT(nss,ix) = i;
7314 break;
c4410b1b
GS		 7315 case SAVEt_COMPPAD:
7316 av = (AV*)POPPTR(ss,ix);
7317 TOPPTR(nss,ix) = av_dup(av);
7318 break;
1d7c1841
GS		 7319 default:
7320 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
7321 }
7322 }
7323
7324 return nss;
7325}
7326
7327#ifdef PERL_OBJECT
7328#include "XSUB.h"
7329#endif
7330
7331PerlInterpreter *
7332perl_clone(PerlInterpreter *proto_perl, UV flags)
7333{
7334#ifdef PERL_OBJECT
7335 CPerlObj *pPerl = (CPerlObj*)proto_perl;
7336#endif
7337
7338#ifdef PERL_IMPLICIT_SYS
7339 return perl_clone_using(proto_perl, flags,
7340 proto_perl->IMem,
7341 proto_perl->IMemShared,
7342 proto_perl->IMemParse,
7343 proto_perl->IEnv,
7344 proto_perl->IStdIO,
7345 proto_perl->ILIO,
7346 proto_perl->IDir,
7347 proto_perl->ISock,
7348 proto_perl->IProc);
7349}
7350
7351PerlInterpreter *
7352perl_clone_using(PerlInterpreter *proto_perl, UV flags,
7353 struct IPerlMem* ipM, struct IPerlMem* ipMS,
7354 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
7355 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
7356 struct IPerlDir* ipD, struct IPerlSock* ipS,
7357 struct IPerlProc* ipP)
7358{
7359 /* XXX many of the string copies here can be optimized if they're
7360 * constants; they need to be allocated as common memory and just
7361 * their pointers copied. */
7362
7363 IV i;
1d7c1841
GS		 7364# ifdef PERL_OBJECT
7365 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
7366 ipD, ipS, ipP);
ba869deb 7367 PERL_SET_THX(pPerl);
1d7c1841
GS		 7368# else /* !PERL_OBJECT */
7369 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
ba869deb 7370 PERL_SET_THX(my_perl);
1d7c1841
GS		 7371
7372# ifdef DEBUGGING
7373 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7374 PL_markstack = 0;
7375 PL_scopestack = 0;
7376 PL_savestack = 0;
7377 PL_retstack = 0;
7378# else /* !DEBUGGING */
7379 Zero(my_perl, 1, PerlInterpreter);
7380# endif /* DEBUGGING */
7381
7382 /* host pointers */
7383 PL_Mem = ipM;
7384 PL_MemShared = ipMS;
7385 PL_MemParse = ipMP;
7386 PL_Env = ipE;
7387 PL_StdIO = ipStd;
7388 PL_LIO = ipLIO;
7389 PL_Dir = ipD;
7390 PL_Sock = ipS;
7391 PL_Proc = ipP;
7392# endif /* PERL_OBJECT */
7393#else /* !PERL_IMPLICIT_SYS */
7394 IV i;
1d7c1841 7395 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
ba869deb 7396 PERL_SET_THX(my_perl);
1d7c1841
GS		 7397
7398# ifdef DEBUGGING
7399 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7400 PL_markstack = 0;
7401 PL_scopestack = 0;
7402 PL_savestack = 0;
7403 PL_retstack = 0;
7404# else /* !DEBUGGING */
7405 Zero(my_perl, 1, PerlInterpreter);
7406# endif /* DEBUGGING */
7407#endif /* PERL_IMPLICIT_SYS */
7408
7409 /* arena roots */
7410 PL_xiv_arenaroot = NULL;
7411 PL_xiv_root = NULL;
7412 PL_xnv_root = NULL;
7413 PL_xrv_root = NULL;
7414 PL_xpv_root = NULL;
7415 PL_xpviv_root = NULL;
7416 PL_xpvnv_root = NULL;
7417 PL_xpvcv_root = NULL;
7418 PL_xpvav_root = NULL;
7419 PL_xpvhv_root = NULL;
7420 PL_xpvmg_root = NULL;
7421 PL_xpvlv_root = NULL;
7422 PL_xpvbm_root = NULL;
7423 PL_he_root = NULL;
7424 PL_nice_chunk = NULL;
7425 PL_nice_chunk_size = 0;
7426 PL_sv_count = 0;
7427 PL_sv_objcount = 0;
7428 PL_sv_root = Nullsv;
7429 PL_sv_arenaroot = Nullsv;
7430
7431 PL_debug = proto_perl->Idebug;
7432
7433 /* create SV map for pointer relocation */
7434 PL_ptr_table = ptr_table_new();
7435
7436 /* initialize these special pointers as early as possible */
7437 SvANY(&PL_sv_undef) = NULL;
7438 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
7439 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
7440 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
7441
7442#ifdef PERL_OBJECT
7443 SvUPGRADE(&PL_sv_no, SVt_PVNV);
7444#else
7445 SvANY(&PL_sv_no) = new_XPVNV();
7446#endif
7447 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
7448 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7449 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
7450 SvCUR(&PL_sv_no) = 0;
7451 SvLEN(&PL_sv_no) = 1;
7452 SvNVX(&PL_sv_no) = 0;
7453 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
7454
7455#ifdef PERL_OBJECT
7456 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
7457#else
7458 SvANY(&PL_sv_yes) = new_XPVNV();
7459#endif
7460 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
7461 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7462 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
7463 SvCUR(&PL_sv_yes) = 1;
7464 SvLEN(&PL_sv_yes) = 2;
7465 SvNVX(&PL_sv_yes) = 1;
7466 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
7467
7468 /* create shared string table */
7469 PL_strtab = newHV();
7470 HvSHAREKEYS_off(PL_strtab);
7471 hv_ksplit(PL_strtab, 512);
7472 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
7473
7474 PL_compiling = proto_perl->Icompiling;
7475 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
7476 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
7477 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
7478 if (!specialWARN(PL_compiling.cop_warnings))
7479 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
7480 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
7481
7482 /* pseudo environmental stuff */
7483 PL_origargc = proto_perl->Iorigargc;
7484 i = PL_origargc;
7485 New(0, PL_origargv, i+1, char*);
7486 PL_origargv[i] = '\0';
7487 while (i-- > 0) {
7488 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
7489 }
7490 PL_envgv = gv_dup(proto_perl->Ienvgv);
7491 PL_incgv = gv_dup(proto_perl->Iincgv);
7492 PL_hintgv = gv_dup(proto_perl->Ihintgv);
7493 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
7494 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
7495 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
7496
7497 /* switches */
7498 PL_minus_c = proto_perl->Iminus_c;
a7cb1f99 7499 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
1d7c1841
GS		 7500 PL_localpatches = proto_perl->Ilocalpatches;
7501 PL_splitstr = proto_perl->Isplitstr;
7502 PL_preprocess = proto_perl->Ipreprocess;
7503 PL_minus_n = proto_perl->Iminus_n;
7504 PL_minus_p = proto_perl->Iminus_p;
7505 PL_minus_l = proto_perl->Iminus_l;
7506 PL_minus_a = proto_perl->Iminus_a;
7507 PL_minus_F = proto_perl->Iminus_F;
7508 PL_doswitches = proto_perl->Idoswitches;
7509 PL_dowarn = proto_perl->Idowarn;
7510 PL_doextract = proto_perl->Idoextract;
7511 PL_sawampersand = proto_perl->Isawampersand;
7512 PL_unsafe = proto_perl->Iunsafe;
7513 PL_inplace = SAVEPV(proto_perl->Iinplace);
7514 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
7515 PL_perldb = proto_perl->Iperldb;
7516 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
7517
7518 /* magical thingies */
7519 /* XXX time(&PL_basetime) when asked for? */
7520 PL_basetime = proto_perl->Ibasetime;
7521 PL_formfeed = sv_dup(proto_perl->Iformfeed);
7522
7523 PL_maxsysfd = proto_perl->Imaxsysfd;
7524 PL_multiline = proto_perl->Imultiline;
7525 PL_statusvalue = proto_perl->Istatusvalue;
7526#ifdef VMS
7527 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
7528#endif
7529
7530 /* shortcuts to various I/O objects */
7531 PL_stdingv = gv_dup(proto_perl->Istdingv);
7532 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
7533 PL_defgv = gv_dup(proto_perl->Idefgv);
7534 PL_argvgv = gv_dup(proto_perl->Iargvgv);
7535 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
7536 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
7537
7538 /* shortcuts to regexp stuff */
7539 PL_replgv = gv_dup(proto_perl->Ireplgv);
7540
7541 /* shortcuts to misc objects */
7542 PL_errgv = gv_dup(proto_perl->Ierrgv);
7543
7544 /* shortcuts to debugging objects */
7545 PL_DBgv = gv_dup(proto_perl->IDBgv);
7546 PL_DBline = gv_dup(proto_perl->IDBline);
7547 PL_DBsub = gv_dup(proto_perl->IDBsub);
7548 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
7549 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
7550 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
7551 PL_lineary = av_dup(proto_perl->Ilineary);
7552 PL_dbargs = av_dup(proto_perl->Idbargs);
7553
7554 /* symbol tables */
7555 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
7556 PL_curstash = hv_dup(proto_perl->Tcurstash);
7557 PL_debstash = hv_dup(proto_perl->Idebstash);
7558 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
7559 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
7560
7561 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
7562 PL_endav = av_dup_inc(proto_perl->Iendav);
7d30b5c4 7563 PL_checkav = av_dup_inc(proto_perl->Icheckav);
1d7c1841
GS		 7564 PL_initav = av_dup_inc(proto_perl->Iinitav);
7565
7566 PL_sub_generation = proto_perl->Isub_generation;
7567
7568 /* funky return mechanisms */
7569 PL_forkprocess = proto_perl->Iforkprocess;
7570
7571 /* subprocess state */
7572 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
7573
7574 /* internal state */
7575 PL_tainting = proto_perl->Itainting;
7576 PL_maxo = proto_perl->Imaxo;
7577 if (proto_perl->Iop_mask)
7578 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
7579 else
7580 PL_op_mask = Nullch;
7581
7582 /* current interpreter roots */
7583 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
7584 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
7585 PL_main_start = proto_perl->Imain_start;
e977893f 7586 PL_eval_root = proto_perl->Ieval_root;
1d7c1841
GS		 7587 PL_eval_start = proto_perl->Ieval_start;
7588
7589 /* runtime control stuff */
7590 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
7591 PL_copline = proto_perl->Icopline;
7592
7593 PL_filemode = proto_perl->Ifilemode;
7594 PL_lastfd = proto_perl->Ilastfd;
7595 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
7596 PL_Argv = NULL;
7597 PL_Cmd = Nullch;
7598 PL_gensym = proto_perl->Igensym;
7599 PL_preambled = proto_perl->Ipreambled;
7600 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
7601 PL_laststatval = proto_perl->Ilaststatval;
7602 PL_laststype = proto_perl->Ilaststype;
7603 PL_mess_sv = Nullsv;
7604
7605 PL_orslen = proto_perl->Iorslen;
7606 PL_ors = SAVEPVN(proto_perl->Iors, PL_orslen);
7607 PL_ofmt = SAVEPV(proto_perl->Iofmt);
7608
7609 /* interpreter atexit processing */
7610 PL_exitlistlen = proto_perl->Iexitlistlen;
7611 if (PL_exitlistlen) {
7612 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7613 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7614 }
7615 else
7616 PL_exitlist = (PerlExitListEntry*)NULL;
7617 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
7618
7619 PL_profiledata = NULL;
7620 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
7621 /* PL_rsfp_filters entries have fake IoDIRP() */
7622 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
7623
7624 PL_compcv = cv_dup(proto_perl->Icompcv);
7625 PL_comppad = av_dup(proto_perl->Icomppad);
7626 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
7627 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
7628 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
7629 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
7630 proto_perl->Tcurpad);
7631
7632#ifdef HAVE_INTERP_INTERN
7633 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
7634#endif
7635
7636 /* more statics moved here */
7637 PL_generation = proto_perl->Igeneration;
7638 PL_DBcv = cv_dup(proto_perl->IDBcv);
1d7c1841
GS		 7639
7640 PL_in_clean_objs = proto_perl->Iin_clean_objs;
7641 PL_in_clean_all = proto_perl->Iin_clean_all;
7642
7643 PL_uid = proto_perl->Iuid;
7644 PL_euid = proto_perl->Ieuid;
7645 PL_gid = proto_perl->Igid;
7646 PL_egid = proto_perl->Iegid;
7647 PL_nomemok = proto_perl->Inomemok;
7648 PL_an = proto_perl->Ian;
7649 PL_cop_seqmax = proto_perl->Icop_seqmax;
7650 PL_op_seqmax = proto_perl->Iop_seqmax;
7651 PL_evalseq = proto_perl->Ievalseq;
7652 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
7653 PL_origalen = proto_perl->Iorigalen;
7654 PL_pidstatus = newHV(); /* XXX flag for cloning? */
7655 PL_osname = SAVEPV(proto_perl->Iosname);
7656 PL_sh_path = SAVEPV(proto_perl->Ish_path);
7657 PL_sighandlerp = proto_perl->Isighandlerp;
7658
7659
7660 PL_runops = proto_perl->Irunops;
7661
7662 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
7663
7664#ifdef CSH
7665 PL_cshlen = proto_perl->Icshlen;
7666 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
7667#endif
7668
7669 PL_lex_state = proto_perl->Ilex_state;
7670 PL_lex_defer = proto_perl->Ilex_defer;
7671 PL_lex_expect = proto_perl->Ilex_expect;
7672 PL_lex_formbrack = proto_perl->Ilex_formbrack;
7673 PL_lex_dojoin = proto_perl->Ilex_dojoin;
7674 PL_lex_starts = proto_perl->Ilex_starts;
7675 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
7676 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
7677 PL_lex_op = proto_perl->Ilex_op;
7678 PL_lex_inpat = proto_perl->Ilex_inpat;
7679 PL_lex_inwhat = proto_perl->Ilex_inwhat;
7680 PL_lex_brackets = proto_perl->Ilex_brackets;
7681 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
7682 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
7683 PL_lex_casemods = proto_perl->Ilex_casemods;
7684 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
7685 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
7686
7687 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
7688 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
7689 PL_nexttoke = proto_perl->Inexttoke;
7690
7691 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
7692 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
7693 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7694 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
7695 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7696 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
7697 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7698 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7699 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
7700 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7701 PL_pending_ident = proto_perl->Ipending_ident;
7702 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
7703
7704 PL_expect = proto_perl->Iexpect;
7705
7706 PL_multi_start = proto_perl->Imulti_start;
7707 PL_multi_end = proto_perl->Imulti_end;
7708 PL_multi_open = proto_perl->Imulti_open;
7709 PL_multi_close = proto_perl->Imulti_close;
7710
7711 PL_error_count = proto_perl->Ierror_count;
7712 PL_subline = proto_perl->Isubline;
7713 PL_subname = sv_dup_inc(proto_perl->Isubname);
7714
7715 PL_min_intro_pending = proto_perl->Imin_intro_pending;
7716 PL_max_intro_pending = proto_perl->Imax_intro_pending;
7717 PL_padix = proto_perl->Ipadix;
7718 PL_padix_floor = proto_perl->Ipadix_floor;
7719 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
7720
7721 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
7722 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7723 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
7724 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7725 PL_last_lop_op = proto_perl->Ilast_lop_op;
7726 PL_in_my = proto_perl->Iin_my;
7727 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
7728#ifdef FCRYPT
7729 PL_cryptseen = proto_perl->Icryptseen;
7730#endif
7731
7732 PL_hints = proto_perl->Ihints;
7733
7734 PL_amagic_generation = proto_perl->Iamagic_generation;
7735
7736#ifdef USE_LOCALE_COLLATE
7737 PL_collation_ix = proto_perl->Icollation_ix;
7738 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
7739 PL_collation_standard = proto_perl->Icollation_standard;
7740 PL_collxfrm_base = proto_perl->Icollxfrm_base;
7741 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
7742#endif /* USE_LOCALE_COLLATE */
7743
7744#ifdef USE_LOCALE_NUMERIC
7745 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
7746 PL_numeric_standard = proto_perl->Inumeric_standard;
7747 PL_numeric_local = proto_perl->Inumeric_local;
7748 PL_numeric_radix = proto_perl->Inumeric_radix;
7749#endif /* !USE_LOCALE_NUMERIC */
7750
7751 /* utf8 character classes */
7752 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
7753 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
7754 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
7755 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
7756 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
7757 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
7758 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
7759 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
7760 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
7761 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
7762 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
7763 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
7764 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
7765 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
7766 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
7767 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
7768 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
7769
7770 /* swatch cache */
7771 PL_last_swash_hv = Nullhv; /* reinits on demand */
7772 PL_last_swash_klen = 0;
7773 PL_last_swash_key[0]= '\0';
7774 PL_last_swash_tmps = (U8*)NULL;
7775 PL_last_swash_slen = 0;
7776
7777 /* perly.c globals */
7778 PL_yydebug = proto_perl->Iyydebug;
7779 PL_yynerrs = proto_perl->Iyynerrs;
7780 PL_yyerrflag = proto_perl->Iyyerrflag;
7781 PL_yychar = proto_perl->Iyychar;
7782 PL_yyval = proto_perl->Iyyval;
7783 PL_yylval = proto_perl->Iyylval;
7784
7785 PL_glob_index = proto_perl->Iglob_index;
7786 PL_srand_called = proto_perl->Isrand_called;
7787 PL_uudmap['M'] = 0; /* reinits on demand */
7788 PL_bitcount = Nullch; /* reinits on demand */
7789
7790 if (proto_perl->Ipsig_ptr) {
7791 int sig_num[] = { SIG_NUM };
7792 Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
7793 Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
7794 for (i = 1; PL_sig_name[i]; i++) {
7795 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
7796 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
7797 }
7798 }
7799 else {
7800 PL_psig_ptr = (SV**)NULL;
7801 PL_psig_name = (SV**)NULL;
7802 }
7803
7804 /* thrdvar.h stuff */
7805
7806 if (flags & 1) {
7807 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
7808 PL_tmps_ix = proto_perl->Ttmps_ix;
7809 PL_tmps_max = proto_perl->Ttmps_max;
7810 PL_tmps_floor = proto_perl->Ttmps_floor;
7811 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
7812 i = 0;
7813 while (i <= PL_tmps_ix) {
7814 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
7815 ++i;
7816 }
7817
7818 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
7819 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
7820 Newz(54, PL_markstack, i, I32);
7821 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
7822 - proto_perl->Tmarkstack);
7823 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
7824 - proto_perl->Tmarkstack);
7825 Copy(proto_perl->Tmarkstack, PL_markstack,
7826 PL_markstack_ptr - PL_markstack + 1, I32);
7827
7828 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
7829 * NOTE: unlike the others! */
7830 PL_scopestack_ix = proto_perl->Tscopestack_ix;
7831 PL_scopestack_max = proto_perl->Tscopestack_max;
7832 Newz(54, PL_scopestack, PL_scopestack_max, I32);
7833 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
7834
7835 /* next push_return() sets PL_retstack[PL_retstack_ix]
7836 * NOTE: unlike the others! */
7837 PL_retstack_ix = proto_perl->Tretstack_ix;
7838 PL_retstack_max = proto_perl->Tretstack_max;
7839 Newz(54, PL_retstack, PL_retstack_max, OP*);
7840 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
7841
7842 /* NOTE: si_dup() looks at PL_markstack */
7843 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
7844
7845 /* PL_curstack = PL_curstackinfo->si_stack; */
7846 PL_curstack = av_dup(proto_perl->Tcurstack);
7847 PL_mainstack = av_dup(proto_perl->Tmainstack);
7848
7849 /* next PUSHs() etc. set *(PL_stack_sp+1) */
7850 PL_stack_base = AvARRAY(PL_curstack);
7851 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
7852 - proto_perl->Tstack_base);
7853 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
7854
7855 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
7856 * NOTE: unlike the others! */
7857 PL_savestack_ix = proto_perl->Tsavestack_ix;
7858 PL_savestack_max = proto_perl->Tsavestack_max;
7859 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
7860 PL_savestack = ss_dup(proto_perl);
7861 }
7862 else {
7863 init_stacks();
7864 }
7865
7866 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
7867 PL_top_env = &PL_start_env;
7868
7869 PL_op = proto_perl->Top;
7870
7871 PL_Sv = Nullsv;
7872 PL_Xpv = (XPV*)NULL;
7873 PL_na = proto_perl->Tna;
7874
7875 PL_statbuf = proto_perl->Tstatbuf;
7876 PL_statcache = proto_perl->Tstatcache;
7877 PL_statgv = gv_dup(proto_perl->Tstatgv);
7878 PL_statname = sv_dup_inc(proto_perl->Tstatname);
7879#ifdef HAS_TIMES
7880 PL_timesbuf = proto_perl->Ttimesbuf;
7881#endif
7882
7883 PL_tainted = proto_perl->Ttainted;
7884 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
7885 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
7886 PL_rs = sv_dup_inc(proto_perl->Trs);
7887 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
7888 PL_ofslen = proto_perl->Tofslen;
7889 PL_ofs = SAVEPVN(proto_perl->Tofs, PL_ofslen);
7890 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
7891 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
7892 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
7893 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
7894 PL_formtarget = sv_dup(proto_perl->Tformtarget);
7895
7896 PL_restartop = proto_perl->Trestartop;
7897 PL_in_eval = proto_perl->Tin_eval;
7898 PL_delaymagic = proto_perl->Tdelaymagic;
7899 PL_dirty = proto_perl->Tdirty;
7900 PL_localizing = proto_perl->Tlocalizing;
7901
14dd3ad8 7902#ifdef PERL_FLEXIBLE_EXCEPTIONS
1d7c1841 7903 PL_protect = proto_perl->Tprotect;
14dd3ad8 7904#endif
1d7c1841
GS		 7905 PL_errors = sv_dup_inc(proto_perl->Terrors);
7906 PL_av_fetch_sv = Nullsv;
7907 PL_hv_fetch_sv = Nullsv;
7908 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
7909 PL_modcount = proto_perl->Tmodcount;
7910 PL_lastgotoprobe = Nullop;
7911 PL_dumpindent = proto_perl->Tdumpindent;
7912
7913 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
7914 PL_sortstash = hv_dup(proto_perl->Tsortstash);
7915 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
7916 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
7917 PL_sortcxix = proto_perl->Tsortcxix;
7918 PL_efloatbuf = Nullch; /* reinits on demand */
7919 PL_efloatsize = 0; /* reinits on demand */
7920
7921 /* regex stuff */
7922
7923 PL_screamfirst = NULL;
7924 PL_screamnext = NULL;
7925 PL_maxscream = -1; /* reinits on demand */
7926 PL_lastscream = Nullsv;
7927
7928 PL_watchaddr = NULL;
7929 PL_watchok = Nullch;
7930
7931 PL_regdummy = proto_perl->Tregdummy;
7932 PL_regcomp_parse = Nullch;
7933 PL_regxend = Nullch;
7934 PL_regcode = (regnode*)NULL;
7935 PL_regnaughty = 0;
7936 PL_regsawback = 0;
7937 PL_regprecomp = Nullch;
7938 PL_regnpar = 0;
7939 PL_regsize = 0;
7940 PL_regflags = 0;
7941 PL_regseen = 0;
7942 PL_seen_zerolen = 0;
7943 PL_seen_evals = 0;
7944 PL_regcomp_rx = (regexp*)NULL;
7945 PL_extralen = 0;
7946 PL_colorset = 0; /* reinits PL_colors[] */
7947 /*PL_colors[6] = {0,0,0,0,0,0};*/
7948 PL_reg_whilem_seen = 0;
7949 PL_reginput = Nullch;
7950 PL_regbol = Nullch;
7951 PL_regeol = Nullch;
7952 PL_regstartp = (I32*)NULL;
7953 PL_regendp = (I32*)NULL;
7954 PL_reglastparen = (U32*)NULL;
7955 PL_regtill = Nullch;
7956 PL_regprev = '\n';
7957 PL_reg_start_tmp = (char**)NULL;
7958 PL_reg_start_tmpl = 0;
7959 PL_regdata = (struct reg_data*)NULL;
7960 PL_bostr = Nullch;
7961 PL_reg_flags = 0;
7962 PL_reg_eval_set = 0;
7963 PL_regnarrate = 0;
7964 PL_regprogram = (regnode*)NULL;
7965 PL_regindent = 0;
7966 PL_regcc = (CURCUR*)NULL;
7967 PL_reg_call_cc = (struct re_cc_state*)NULL;
7968 PL_reg_re = (regexp*)NULL;
7969 PL_reg_ganch = Nullch;
7970 PL_reg_sv = Nullsv;
7971 PL_reg_magic = (MAGIC*)NULL;
7972 PL_reg_oldpos = 0;
7973 PL_reg_oldcurpm = (PMOP*)NULL;
7974 PL_reg_curpm = (PMOP*)NULL;
7975 PL_reg_oldsaved = Nullch;
7976 PL_reg_oldsavedlen = 0;
7977 PL_reg_maxiter = 0;
7978 PL_reg_leftiter = 0;
7979 PL_reg_poscache = Nullch;
7980 PL_reg_poscache_size= 0;
7981
7982 /* RE engine - function pointers */
7983 PL_regcompp = proto_perl->Tregcompp;
7984 PL_regexecp = proto_perl->Tregexecp;
7985 PL_regint_start = proto_perl->Tregint_start;
7986 PL_regint_string = proto_perl->Tregint_string;
7987 PL_regfree = proto_perl->Tregfree;
7988
7989 PL_reginterp_cnt = 0;
7990 PL_reg_starttry = 0;
7991
7992#ifdef PERL_OBJECT
7993 return (PerlInterpreter*)pPerl;
7994#else
7995 return my_perl;
7996#endif
7997}
7998
7999#else /* !USE_ITHREADS */
51371543
GS		 8000
8001#ifdef PERL_OBJECT
51371543
GS		 8002#include "XSUB.h"
8003#endif
8004
1d7c1841
GS		 8005#endif /* USE_ITHREADS */
8006
51371543
GS		 8007static void
8008do_report_used(pTHXo_ SV *sv)
8009{
8010 if (SvTYPE(sv) != SVTYPEMASK) {
bf49b057 8011 PerlIO_printf(Perl_debug_log, "****\n");
51371543
GS		 8012 sv_dump(sv);
8013 }
8014}
8015
8016static void
8017do_clean_objs(pTHXo_ SV *sv)
8018{
8019 SV* rv;
8020
8021 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
8022 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
8023 SvROK_off(sv);
8024 SvRV(sv) = 0;
8025 SvREFCNT_dec(rv);
8026 }
8027
8028 /* XXX Might want to check arrays, etc. */
8029}
8030
8031#ifndef DISABLE_DESTRUCTOR_KLUDGE
8032static void
8033do_clean_named_objs(pTHXo_ SV *sv)
8034{
f472eb5c 8035 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
51371543 8036 if ( SvOBJECT(GvSV(sv)) ||
155aba94
GS		 8037 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
8038 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
8039 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
8040 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
51371543
GS		 8041 {
8042 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
8043 SvREFCNT_dec(sv);
8044 }
8045 }
8046}
8047#endif
8048
8049static void
8050do_clean_all(pTHXo_ SV *sv)
8051{
1d7c1841 8052 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
51371543
GS		 8053 SvFLAGS(sv) |= SVf_BREAK;
8054 SvREFCNT_dec(sv);
8055}
8056
Unnamed repository; edit this file 'description' to name the repository.