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