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