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