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