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