1 /* sv.c 2 * 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall 5 * and others 6 * 7 * You may distribute under the terms of either the GNU General Public 8 * License or the Artistic License, as specified in the README file. 9 * 10 */ 11 12 /* 13 * 'I wonder what the Entish is for "yes" and "no",' he thought. 14 * --Pippin 15 * 16 * [p.480 of _The Lord of the Rings_, III/iv: "Treebeard"] 17 */ 18 19 /* 20 * 21 * 22 * This file contains the code that creates, manipulates and destroys 23 * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the 24 * structure of an SV, so their creation and destruction is handled 25 * here; higher-level functions are in av.c, hv.c, and so on. Opcode 26 * level functions (eg. substr, split, join) for each of the types are 27 * in the pp*.c files. 28 */ 29 30 #include "EXTERN.h" 31 #define PERL_IN_SV_C 32 #include "perl.h" 33 #include "regcomp.h" 34 35 #ifndef HAS_C99 36 # if defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L && !defined(VMS) 37 # define HAS_C99 1 38 # endif 39 #endif 40 #ifdef HAS_C99 41 # include <stdint.h> 42 #endif 43 44 #ifdef __Lynx__ 45 /* Missing proto on LynxOS */ 46 char *gconvert(double, int, int, char *); 47 #endif 48 49 #ifndef SV_COW_THRESHOLD 50 # define SV_COW_THRESHOLD 0 /* COW iff len > K */ 51 #endif 52 #ifndef SV_COWBUF_THRESHOLD 53 # define SV_COWBUF_THRESHOLD 1250 /* COW iff len > K */ 54 #endif 55 #ifndef SV_COW_MAX_WASTE_THRESHOLD 56 # define SV_COW_MAX_WASTE_THRESHOLD 80 /* COW iff (len - cur) < K */ 57 #endif 58 #ifndef SV_COWBUF_WASTE_THRESHOLD 59 # define SV_COWBUF_WASTE_THRESHOLD 80 /* COW iff (len - cur) < K */ 60 #endif 61 #ifndef SV_COW_MAX_WASTE_FACTOR_THRESHOLD 62 # define SV_COW_MAX_WASTE_FACTOR_THRESHOLD 2 /* COW iff len < (cur * K) */ 63 #endif 64 #ifndef SV_COWBUF_WASTE_FACTOR_THRESHOLD 65 # define SV_COWBUF_WASTE_FACTOR_THRESHOLD 2 /* COW iff len < (cur * K) */ 66 #endif 67 /* Work around compiler warnings about unsigned >= THRESHOLD when thres- 68 hold is 0. */ 69 #if SV_COW_THRESHOLD 70 # define GE_COW_THRESHOLD(cur) ((cur) >= SV_COW_THRESHOLD) 71 #else 72 # define GE_COW_THRESHOLD(cur) 1 73 #endif 74 #if SV_COWBUF_THRESHOLD 75 # define GE_COWBUF_THRESHOLD(cur) ((cur) >= SV_COWBUF_THRESHOLD) 76 #else 77 # define GE_COWBUF_THRESHOLD(cur) 1 78 #endif 79 #if SV_COW_MAX_WASTE_THRESHOLD 80 # define GE_COW_MAX_WASTE_THRESHOLD(cur,len) (((len)-(cur)) < SV_COW_MAX_WASTE_THRESHOLD) 81 #else 82 # define GE_COW_MAX_WASTE_THRESHOLD(cur,len) 1 83 #endif 84 #if SV_COWBUF_WASTE_THRESHOLD 85 # define GE_COWBUF_WASTE_THRESHOLD(cur,len) (((len)-(cur)) < SV_COWBUF_WASTE_THRESHOLD) 86 #else 87 # define GE_COWBUF_WASTE_THRESHOLD(cur,len) 1 88 #endif 89 #if SV_COW_MAX_WASTE_FACTOR_THRESHOLD 90 # define GE_COW_MAX_WASTE_FACTOR_THRESHOLD(cur,len) ((len) < SV_COW_MAX_WASTE_FACTOR_THRESHOLD * (cur)) 91 #else 92 # define GE_COW_MAX_WASTE_FACTOR_THRESHOLD(cur,len) 1 93 #endif 94 #if SV_COWBUF_WASTE_FACTOR_THRESHOLD 95 # define GE_COWBUF_WASTE_FACTOR_THRESHOLD(cur,len) ((len) < SV_COWBUF_WASTE_FACTOR_THRESHOLD * (cur)) 96 #else 97 # define GE_COWBUF_WASTE_FACTOR_THRESHOLD(cur,len) 1 98 #endif 99 100 #define CHECK_COW_THRESHOLD(cur,len) (\ 101 GE_COW_THRESHOLD((cur)) && \ 102 GE_COW_MAX_WASTE_THRESHOLD((cur),(len)) && \ 103 GE_COW_MAX_WASTE_FACTOR_THRESHOLD((cur),(len)) \ 104 ) 105 #define CHECK_COWBUF_THRESHOLD(cur,len) (\ 106 GE_COWBUF_THRESHOLD((cur)) && \ 107 GE_COWBUF_WASTE_THRESHOLD((cur),(len)) && \ 108 GE_COWBUF_WASTE_FACTOR_THRESHOLD((cur),(len)) \ 109 ) 110 /* void Gconvert: on Linux at least, gcvt (which Gconvert gets deffed to), 111 * has a mandatory return value, even though that value is just the same 112 * as the buf arg */ 113 114 #ifdef PERL_UTF8_CACHE_ASSERT 115 /* if adding more checks watch out for the following tests: 116 * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t 117 * lib/utf8.t lib/Unicode/Collate/t/index.t 118 * --jhi 119 */ 120 # define ASSERT_UTF8_CACHE(cache) \ 121 STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \ 122 assert((cache)[2] <= (cache)[3]); \ 123 assert((cache)[3] <= (cache)[1]);} \ 124 } STMT_END 125 #else 126 # define ASSERT_UTF8_CACHE(cache) NOOP 127 #endif 128 129 #ifdef PERL_OLD_COPY_ON_WRITE 130 #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv)) 131 #define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next)) 132 #endif 133 134 /* ============================================================================ 135 136 =head1 Allocation and deallocation of SVs. 137 138 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct 139 sv, av, hv...) contains type and reference count information, and for 140 many types, a pointer to the body (struct xrv, xpv, xpviv...), which 141 contains fields specific to each type. Some types store all they need 142 in the head, so don't have a body. 143 144 In all but the most memory-paranoid configurations (ex: PURIFY), heads 145 and bodies are allocated out of arenas, which by default are 146 approximately 4K chunks of memory parcelled up into N heads or bodies. 147 Sv-bodies are allocated by their sv-type, guaranteeing size 148 consistency needed to allocate safely from arrays. 149 150 For SV-heads, the first slot in each arena is reserved, and holds a 151 link to the next arena, some flags, and a note of the number of slots. 152 Snaked through each arena chain is a linked list of free items; when 153 this becomes empty, an extra arena is allocated and divided up into N 154 items which are threaded into the free list. 155 156 SV-bodies are similar, but they use arena-sets by default, which 157 separate the link and info from the arena itself, and reclaim the 1st 158 slot in the arena. SV-bodies are further described later. 159 160 The following global variables are associated with arenas: 161 162 PL_sv_arenaroot pointer to list of SV arenas 163 PL_sv_root pointer to list of free SV structures 164 165 PL_body_arenas head of linked-list of body arenas 166 PL_body_roots[] array of pointers to list of free bodies of svtype 167 arrays are indexed by the svtype needed 168 169 A few special SV heads are not allocated from an arena, but are 170 instead directly created in the interpreter structure, eg PL_sv_undef. 171 The size of arenas can be changed from the default by setting 172 PERL_ARENA_SIZE appropriately at compile time. 173 174 The SV arena serves the secondary purpose of allowing still-live SVs 175 to be located and destroyed during final cleanup. 176 177 At the lowest level, the macros new_SV() and del_SV() grab and free 178 an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv() 179 to return the SV to the free list with error checking.) new_SV() calls 180 more_sv() / sv_add_arena() to add an extra arena if the free list is empty. 181 SVs in the free list have their SvTYPE field set to all ones. 182 183 At the time of very final cleanup, sv_free_arenas() is called from 184 perl_destruct() to physically free all the arenas allocated since the 185 start of the interpreter. 186 187 The function visit() scans the SV arenas list, and calls a specified 188 function for each SV it finds which is still live - ie which has an SvTYPE 189 other than all 1's, and a non-zero SvREFCNT. visit() is used by the 190 following functions (specified as [function that calls visit()] / [function 191 called by visit() for each SV]): 192 193 sv_report_used() / do_report_used() 194 dump all remaining SVs (debugging aid) 195 196 sv_clean_objs() / do_clean_objs(),do_clean_named_objs(), 197 do_clean_named_io_objs(),do_curse() 198 Attempt to free all objects pointed to by RVs, 199 try to do the same for all objects indir- 200 ectly referenced by typeglobs too, and 201 then do a final sweep, cursing any 202 objects that remain. Called once from 203 perl_destruct(), prior to calling sv_clean_all() 204 below. 205 206 sv_clean_all() / do_clean_all() 207 SvREFCNT_dec(sv) each remaining SV, possibly 208 triggering an sv_free(). It also sets the 209 SVf_BREAK flag on the SV to indicate that the 210 refcnt has been artificially lowered, and thus 211 stopping sv_free() from giving spurious warnings 212 about SVs which unexpectedly have a refcnt 213 of zero. called repeatedly from perl_destruct() 214 until there are no SVs left. 215 216 =head2 Arena allocator API Summary 217 218 Private API to rest of sv.c 219 220 new_SV(), del_SV(), 221 222 new_XPVNV(), del_XPVGV(), 223 etc 224 225 Public API: 226 227 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas() 228 229 =cut 230 231 * ========================================================================= */ 232 233 /* 234 * "A time to plant, and a time to uproot what was planted..." 235 */ 236 237 #ifdef PERL_MEM_LOG 238 # define MEM_LOG_NEW_SV(sv, file, line, func) \ 239 Perl_mem_log_new_sv(sv, file, line, func) 240 # define MEM_LOG_DEL_SV(sv, file, line, func) \ 241 Perl_mem_log_del_sv(sv, file, line, func) 242 #else 243 # define MEM_LOG_NEW_SV(sv, file, line, func) NOOP 244 # define MEM_LOG_DEL_SV(sv, file, line, func) NOOP 245 #endif 246 247 #ifdef DEBUG_LEAKING_SCALARS 248 # define FREE_SV_DEBUG_FILE(sv) STMT_START { \ 249 if ((sv)->sv_debug_file) PerlMemShared_free((sv)->sv_debug_file); \ 250 } STMT_END 251 # define DEBUG_SV_SERIAL(sv) \ 252 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n", \ 253 PTR2UV(sv), (long)(sv)->sv_debug_serial)) 254 #else 255 # define FREE_SV_DEBUG_FILE(sv) 256 # define DEBUG_SV_SERIAL(sv) NOOP 257 #endif 258 259 #ifdef PERL_POISON 260 # define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv) 261 # define SvARENA_CHAIN_SET(sv,val) (sv)->sv_u.svu_rv = MUTABLE_SV((val)) 262 /* Whilst I'd love to do this, it seems that things like to check on 263 unreferenced scalars 264 # define POSION_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV) 265 */ 266 # define POSION_SV_HEAD(sv) PoisonNew(&SvANY(sv), 1, void *), \ 267 PoisonNew(&SvREFCNT(sv), 1, U32) 268 #else 269 # define SvARENA_CHAIN(sv) SvANY(sv) 270 # define SvARENA_CHAIN_SET(sv,val) SvANY(sv) = (void *)(val) 271 # define POSION_SV_HEAD(sv) 272 #endif 273 274 /* Mark an SV head as unused, and add to free list. 275 * 276 * If SVf_BREAK is set, skip adding it to the free list, as this SV had 277 * its refcount artificially decremented during global destruction, so 278 * there may be dangling pointers to it. The last thing we want in that 279 * case is for it to be reused. */ 280 281 #define plant_SV(p) \ 282 STMT_START { \ 283 const U32 old_flags = SvFLAGS(p); \ 284 MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__); \ 285 DEBUG_SV_SERIAL(p); \ 286 FREE_SV_DEBUG_FILE(p); \ 287 POSION_SV_HEAD(p); \ 288 SvFLAGS(p) = SVTYPEMASK; \ 289 if (!(old_flags & SVf_BREAK)) { \ 290 SvARENA_CHAIN_SET(p, PL_sv_root); \ 291 PL_sv_root = (p); \ 292 } \ 293 --PL_sv_count; \ 294 } STMT_END 295 296 #define uproot_SV(p) \ 297 STMT_START { \ 298 (p) = PL_sv_root; \ 299 PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p)); \ 300 ++PL_sv_count; \ 301 } STMT_END 302 303 304 /* make some more SVs by adding another arena */ 305 306 STATIC SV* 307 S_more_sv(pTHX) 308 { 309 dVAR; 310 SV* sv; 311 char *chunk; /* must use New here to match call to */ 312 Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */ 313 sv_add_arena(chunk, PERL_ARENA_SIZE, 0); 314 uproot_SV(sv); 315 return sv; 316 } 317 318 /* new_SV(): return a new, empty SV head */ 319 320 #ifdef DEBUG_LEAKING_SCALARS 321 /* provide a real function for a debugger to play with */ 322 STATIC SV* 323 S_new_SV(pTHX_ const char *file, int line, const char *func) 324 { 325 SV* sv; 326 327 if (PL_sv_root) 328 uproot_SV(sv); 329 else 330 sv = S_more_sv(aTHX); 331 SvANY(sv) = 0; 332 SvREFCNT(sv) = 1; 333 SvFLAGS(sv) = 0; 334 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0; 335 sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE 336 ? PL_parser->copline 337 : PL_curcop 338 ? CopLINE(PL_curcop) 339 : 0 340 ); 341 sv->sv_debug_inpad = 0; 342 sv->sv_debug_parent = NULL; 343 sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL; 344 345 sv->sv_debug_serial = PL_sv_serial++; 346 347 MEM_LOG_NEW_SV(sv, file, line, func); 348 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) new_SV (from %s:%d [%s])\n", 349 PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func)); 350 351 return sv; 352 } 353 # define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__) 354 355 #else 356 # define new_SV(p) \ 357 STMT_START { \ 358 if (PL_sv_root) \ 359 uproot_SV(p); \ 360 else \ 361 (p) = S_more_sv(aTHX); \ 362 SvANY(p) = 0; \ 363 SvREFCNT(p) = 1; \ 364 SvFLAGS(p) = 0; \ 365 MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__); \ 366 } STMT_END 367 #endif 368 369 370 /* del_SV(): return an empty SV head to the free list */ 371 372 #ifdef DEBUGGING 373 374 #define del_SV(p) \ 375 STMT_START { \ 376 if (DEBUG_D_TEST) \ 377 del_sv(p); \ 378 else \ 379 plant_SV(p); \ 380 } STMT_END 381 382 STATIC void 383 S_del_sv(pTHX_ SV *p) 384 { 385 dVAR; 386 387 PERL_ARGS_ASSERT_DEL_SV; 388 389 if (DEBUG_D_TEST) { 390 SV* sva; 391 bool ok = 0; 392 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) { 393 const SV * const sv = sva + 1; 394 const SV * const svend = &sva[SvREFCNT(sva)]; 395 if (p >= sv && p < svend) { 396 ok = 1; 397 break; 398 } 399 } 400 if (!ok) { 401 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), 402 "Attempt to free non-arena SV: 0x%"UVxf 403 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE); 404 return; 405 } 406 } 407 plant_SV(p); 408 } 409 410 #else /* ! DEBUGGING */ 411 412 #define del_SV(p) plant_SV(p) 413 414 #endif /* DEBUGGING */ 415 416 417 /* 418 =head1 SV Manipulation Functions 419 420 =for apidoc sv_add_arena 421 422 Given a chunk of memory, link it to the head of the list of arenas, 423 and split it into a list of free SVs. 424 425 =cut 426 */ 427 428 static void 429 S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags) 430 { 431 dVAR; 432 SV *const sva = MUTABLE_SV(ptr); 433 SV* sv; 434 SV* svend; 435 436 PERL_ARGS_ASSERT_SV_ADD_ARENA; 437 438 /* The first SV in an arena isn't an SV. */ 439 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */ 440 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */ 441 SvFLAGS(sva) = flags; /* FAKE if not to be freed */ 442 443 PL_sv_arenaroot = sva; 444 PL_sv_root = sva + 1; 445 446 svend = &sva[SvREFCNT(sva) - 1]; 447 sv = sva + 1; 448 while (sv < svend) { 449 SvARENA_CHAIN_SET(sv, (sv + 1)); 450 #ifdef DEBUGGING 451 SvREFCNT(sv) = 0; 452 #endif 453 /* Must always set typemask because it's always checked in on cleanup 454 when the arenas are walked looking for objects. */ 455 SvFLAGS(sv) = SVTYPEMASK; 456 sv++; 457 } 458 SvARENA_CHAIN_SET(sv, 0); 459 #ifdef DEBUGGING 460 SvREFCNT(sv) = 0; 461 #endif 462 SvFLAGS(sv) = SVTYPEMASK; 463 } 464 465 /* visit(): call the named function for each non-free SV in the arenas 466 * whose flags field matches the flags/mask args. */ 467 468 STATIC I32 469 S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask) 470 { 471 dVAR; 472 SV* sva; 473 I32 visited = 0; 474 475 PERL_ARGS_ASSERT_VISIT; 476 477 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) { 478 const SV * const svend = &sva[SvREFCNT(sva)]; 479 SV* sv; 480 for (sv = sva + 1; sv < svend; ++sv) { 481 if (SvTYPE(sv) != (svtype)SVTYPEMASK 482 && (sv->sv_flags & mask) == flags 483 && SvREFCNT(sv)) 484 { 485 (*f)(aTHX_ sv); 486 ++visited; 487 } 488 } 489 } 490 return visited; 491 } 492 493 #ifdef DEBUGGING 494 495 /* called by sv_report_used() for each live SV */ 496 497 static void 498 do_report_used(pTHX_ SV *const sv) 499 { 500 if (SvTYPE(sv) != (svtype)SVTYPEMASK) { 501 PerlIO_printf(Perl_debug_log, "****\n"); 502 sv_dump(sv); 503 } 504 } 505 #endif 506 507 /* 508 =for apidoc sv_report_used 509 510 Dump the contents of all SVs not yet freed (debugging aid). 511 512 =cut 513 */ 514 515 void 516 Perl_sv_report_used(pTHX) 517 { 518 #ifdef DEBUGGING 519 visit(do_report_used, 0, 0); 520 #else 521 PERL_UNUSED_CONTEXT; 522 #endif 523 } 524 525 /* called by sv_clean_objs() for each live SV */ 526 527 static void 528 do_clean_objs(pTHX_ SV *const ref) 529 { 530 dVAR; 531 assert (SvROK(ref)); 532 { 533 SV * const target = SvRV(ref); 534 if (SvOBJECT(target)) { 535 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref))); 536 if (SvWEAKREF(ref)) { 537 sv_del_backref(target, ref); 538 SvWEAKREF_off(ref); 539 SvRV_set(ref, NULL); 540 } else { 541 SvROK_off(ref); 542 SvRV_set(ref, NULL); 543 SvREFCNT_dec_NN(target); 544 } 545 } 546 } 547 } 548 549 550 /* clear any slots in a GV which hold objects - except IO; 551 * called by sv_clean_objs() for each live GV */ 552 553 static void 554 do_clean_named_objs(pTHX_ SV *const sv) 555 { 556 dVAR; 557 SV *obj; 558 assert(SvTYPE(sv) == SVt_PVGV); 559 assert(isGV_with_GP(sv)); 560 if (!GvGP(sv)) 561 return; 562 563 /* freeing GP entries may indirectly free the current GV; 564 * hold onto it while we mess with the GP slots */ 565 SvREFCNT_inc(sv); 566 567 if ( ((obj = GvSV(sv) )) && SvOBJECT(obj)) { 568 DEBUG_D((PerlIO_printf(Perl_debug_log, 569 "Cleaning named glob SV object:\n "), sv_dump(obj))); 570 GvSV(sv) = NULL; 571 SvREFCNT_dec_NN(obj); 572 } 573 if ( ((obj = MUTABLE_SV(GvAV(sv)) )) && SvOBJECT(obj)) { 574 DEBUG_D((PerlIO_printf(Perl_debug_log, 575 "Cleaning named glob AV object:\n "), sv_dump(obj))); 576 GvAV(sv) = NULL; 577 SvREFCNT_dec_NN(obj); 578 } 579 if ( ((obj = MUTABLE_SV(GvHV(sv)) )) && SvOBJECT(obj)) { 580 DEBUG_D((PerlIO_printf(Perl_debug_log, 581 "Cleaning named glob HV object:\n "), sv_dump(obj))); 582 GvHV(sv) = NULL; 583 SvREFCNT_dec_NN(obj); 584 } 585 if ( ((obj = MUTABLE_SV(GvCV(sv)) )) && SvOBJECT(obj)) { 586 DEBUG_D((PerlIO_printf(Perl_debug_log, 587 "Cleaning named glob CV object:\n "), sv_dump(obj))); 588 GvCV_set(sv, NULL); 589 SvREFCNT_dec_NN(obj); 590 } 591 SvREFCNT_dec_NN(sv); /* undo the inc above */ 592 } 593 594 /* clear any IO slots in a GV which hold objects (except stderr, defout); 595 * called by sv_clean_objs() for each live GV */ 596 597 static void 598 do_clean_named_io_objs(pTHX_ SV *const sv) 599 { 600 dVAR; 601 SV *obj; 602 assert(SvTYPE(sv) == SVt_PVGV); 603 assert(isGV_with_GP(sv)); 604 if (!GvGP(sv) || sv == (SV*)PL_stderrgv || sv == (SV*)PL_defoutgv) 605 return; 606 607 SvREFCNT_inc(sv); 608 if ( ((obj = MUTABLE_SV(GvIO(sv)) )) && SvOBJECT(obj)) { 609 DEBUG_D((PerlIO_printf(Perl_debug_log, 610 "Cleaning named glob IO object:\n "), sv_dump(obj))); 611 GvIOp(sv) = NULL; 612 SvREFCNT_dec_NN(obj); 613 } 614 SvREFCNT_dec_NN(sv); /* undo the inc above */ 615 } 616 617 /* Void wrapper to pass to visit() */ 618 static void 619 do_curse(pTHX_ SV * const sv) { 620 if ((PL_stderrgv && GvGP(PL_stderrgv) && (SV*)GvIO(PL_stderrgv) == sv) 621 || (PL_defoutgv && GvGP(PL_defoutgv) && (SV*)GvIO(PL_defoutgv) == sv)) 622 return; 623 (void)curse(sv, 0); 624 } 625 626 /* 627 =for apidoc sv_clean_objs 628 629 Attempt to destroy all objects not yet freed. 630 631 =cut 632 */ 633 634 void 635 Perl_sv_clean_objs(pTHX) 636 { 637 dVAR; 638 GV *olddef, *olderr; 639 PL_in_clean_objs = TRUE; 640 visit(do_clean_objs, SVf_ROK, SVf_ROK); 641 /* Some barnacles may yet remain, clinging to typeglobs. 642 * Run the non-IO destructors first: they may want to output 643 * error messages, close files etc */ 644 visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP); 645 visit(do_clean_named_io_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP); 646 /* And if there are some very tenacious barnacles clinging to arrays, 647 closures, or what have you.... */ 648 visit(do_curse, SVs_OBJECT, SVs_OBJECT); 649 olddef = PL_defoutgv; 650 PL_defoutgv = NULL; /* disable skip of PL_defoutgv */ 651 if (olddef && isGV_with_GP(olddef)) 652 do_clean_named_io_objs(aTHX_ MUTABLE_SV(olddef)); 653 olderr = PL_stderrgv; 654 PL_stderrgv = NULL; /* disable skip of PL_stderrgv */ 655 if (olderr && isGV_with_GP(olderr)) 656 do_clean_named_io_objs(aTHX_ MUTABLE_SV(olderr)); 657 SvREFCNT_dec(olddef); 658 PL_in_clean_objs = FALSE; 659 } 660 661 /* called by sv_clean_all() for each live SV */ 662 663 static void 664 do_clean_all(pTHX_ SV *const sv) 665 { 666 dVAR; 667 if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) { 668 /* don't clean pid table and strtab */ 669 return; 670 } 671 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) )); 672 SvFLAGS(sv) |= SVf_BREAK; 673 SvREFCNT_dec_NN(sv); 674 } 675 676 /* 677 =for apidoc sv_clean_all 678 679 Decrement the refcnt of each remaining SV, possibly triggering a 680 cleanup. This function may have to be called multiple times to free 681 SVs which are in complex self-referential hierarchies. 682 683 =cut 684 */ 685 686 I32 687 Perl_sv_clean_all(pTHX) 688 { 689 dVAR; 690 I32 cleaned; 691 PL_in_clean_all = TRUE; 692 cleaned = visit(do_clean_all, 0,0); 693 return cleaned; 694 } 695 696 /* 697 ARENASETS: a meta-arena implementation which separates arena-info 698 into struct arena_set, which contains an array of struct 699 arena_descs, each holding info for a single arena. By separating 700 the meta-info from the arena, we recover the 1st slot, formerly 701 borrowed for list management. The arena_set is about the size of an 702 arena, avoiding the needless malloc overhead of a naive linked-list. 703 704 The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused 705 memory in the last arena-set (1/2 on average). In trade, we get 706 back the 1st slot in each arena (ie 1.7% of a CV-arena, less for 707 smaller types). The recovery of the wasted space allows use of 708 small arenas for large, rare body types, by changing array* fields 709 in body_details_by_type[] below. 710 */ 711 struct arena_desc { 712 char *arena; /* the raw storage, allocated aligned */ 713 size_t size; /* its size ~4k typ */ 714 svtype utype; /* bodytype stored in arena */ 715 }; 716 717 struct arena_set; 718 719 /* Get the maximum number of elements in set[] such that struct arena_set 720 will fit within PERL_ARENA_SIZE, which is probably just under 4K, and 721 therefore likely to be 1 aligned memory page. */ 722 723 #define ARENAS_PER_SET ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \ 724 - 2 * sizeof(int)) / sizeof (struct arena_desc)) 725 726 struct arena_set { 727 struct arena_set* next; 728 unsigned int set_size; /* ie ARENAS_PER_SET */ 729 unsigned int curr; /* index of next available arena-desc */ 730 struct arena_desc set[ARENAS_PER_SET]; 731 }; 732 733 /* 734 =for apidoc sv_free_arenas 735 736 Deallocate the memory used by all arenas. Note that all the individual SV 737 heads and bodies within the arenas must already have been freed. 738 739 =cut 740 */ 741 void 742 Perl_sv_free_arenas(pTHX) 743 { 744 dVAR; 745 SV* sva; 746 SV* svanext; 747 unsigned int i; 748 749 /* Free arenas here, but be careful about fake ones. (We assume 750 contiguity of the fake ones with the corresponding real ones.) */ 751 752 for (sva = PL_sv_arenaroot; sva; sva = svanext) { 753 svanext = MUTABLE_SV(SvANY(sva)); 754 while (svanext && SvFAKE(svanext)) 755 svanext = MUTABLE_SV(SvANY(svanext)); 756 757 if (!SvFAKE(sva)) 758 Safefree(sva); 759 } 760 761 { 762 struct arena_set *aroot = (struct arena_set*) PL_body_arenas; 763 764 while (aroot) { 765 struct arena_set *current = aroot; 766 i = aroot->curr; 767 while (i--) { 768 assert(aroot->set[i].arena); 769 Safefree(aroot->set[i].arena); 770 } 771 aroot = aroot->next; 772 Safefree(current); 773 } 774 } 775 PL_body_arenas = 0; 776 777 i = PERL_ARENA_ROOTS_SIZE; 778 while (i--) 779 PL_body_roots[i] = 0; 780 781 PL_sv_arenaroot = 0; 782 PL_sv_root = 0; 783 } 784 785 /* 786 Here are mid-level routines that manage the allocation of bodies out 787 of the various arenas. There are 5 kinds of arenas: 788 789 1. SV-head arenas, which are discussed and handled above 790 2. regular body arenas 791 3. arenas for reduced-size bodies 792 4. Hash-Entry arenas 793 794 Arena types 2 & 3 are chained by body-type off an array of 795 arena-root pointers, which is indexed by svtype. Some of the 796 larger/less used body types are malloced singly, since a large 797 unused block of them is wasteful. Also, several svtypes dont have 798 bodies; the data fits into the sv-head itself. The arena-root 799 pointer thus has a few unused root-pointers (which may be hijacked 800 later for arena types 4,5) 801 802 3 differs from 2 as an optimization; some body types have several 803 unused fields in the front of the structure (which are kept in-place 804 for consistency). These bodies can be allocated in smaller chunks, 805 because the leading fields arent accessed. Pointers to such bodies 806 are decremented to point at the unused 'ghost' memory, knowing that 807 the pointers are used with offsets to the real memory. 808 809 810 =head1 SV-Body Allocation 811 812 Allocation of SV-bodies is similar to SV-heads, differing as follows; 813 the allocation mechanism is used for many body types, so is somewhat 814 more complicated, it uses arena-sets, and has no need for still-live 815 SV detection. 816 817 At the outermost level, (new|del)_X*V macros return bodies of the 818 appropriate type. These macros call either (new|del)_body_type or 819 (new|del)_body_allocated macro pairs, depending on specifics of the 820 type. Most body types use the former pair, the latter pair is used to 821 allocate body types with "ghost fields". 822 823 "ghost fields" are fields that are unused in certain types, and 824 consequently don't need to actually exist. They are declared because 825 they're part of a "base type", which allows use of functions as 826 methods. The simplest examples are AVs and HVs, 2 aggregate types 827 which don't use the fields which support SCALAR semantics. 828 829 For these types, the arenas are carved up into appropriately sized 830 chunks, we thus avoid wasted memory for those unaccessed members. 831 When bodies are allocated, we adjust the pointer back in memory by the 832 size of the part not allocated, so it's as if we allocated the full 833 structure. (But things will all go boom if you write to the part that 834 is "not there", because you'll be overwriting the last members of the 835 preceding structure in memory.) 836 837 We calculate the correction using the STRUCT_OFFSET macro on the first 838 member present. If the allocated structure is smaller (no initial NV 839 actually allocated) then the net effect is to subtract the size of the NV 840 from the pointer, to return a new pointer as if an initial NV were actually 841 allocated. (We were using structures named *_allocated for this, but 842 this turned out to be a subtle bug, because a structure without an NV 843 could have a lower alignment constraint, but the compiler is allowed to 844 optimised accesses based on the alignment constraint of the actual pointer 845 to the full structure, for example, using a single 64 bit load instruction 846 because it "knows" that two adjacent 32 bit members will be 8-byte aligned.) 847 848 This is the same trick as was used for NV and IV bodies. Ironically it 849 doesn't need to be used for NV bodies any more, because NV is now at 850 the start of the structure. IV bodies don't need it either, because 851 they are no longer allocated. 852 853 In turn, the new_body_* allocators call S_new_body(), which invokes 854 new_body_inline macro, which takes a lock, and takes a body off the 855 linked list at PL_body_roots[sv_type], calling Perl_more_bodies() if 856 necessary to refresh an empty list. Then the lock is released, and 857 the body is returned. 858 859 Perl_more_bodies allocates a new arena, and carves it up into an array of N 860 bodies, which it strings into a linked list. It looks up arena-size 861 and body-size from the body_details table described below, thus 862 supporting the multiple body-types. 863 864 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and 865 the (new|del)_X*V macros are mapped directly to malloc/free. 866 867 For each sv-type, struct body_details bodies_by_type[] carries 868 parameters which control these aspects of SV handling: 869 870 Arena_size determines whether arenas are used for this body type, and if 871 so, how big they are. PURIFY or PERL_ARENA_SIZE=0 set this field to 872 zero, forcing individual mallocs and frees. 873 874 Body_size determines how big a body is, and therefore how many fit into 875 each arena. Offset carries the body-pointer adjustment needed for 876 "ghost fields", and is used in *_allocated macros. 877 878 But its main purpose is to parameterize info needed in 879 Perl_sv_upgrade(). The info here dramatically simplifies the function 880 vs the implementation in 5.8.8, making it table-driven. All fields 881 are used for this, except for arena_size. 882 883 For the sv-types that have no bodies, arenas are not used, so those 884 PL_body_roots[sv_type] are unused, and can be overloaded. In 885 something of a special case, SVt_NULL is borrowed for HE arenas; 886 PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the 887 bodies_by_type[SVt_NULL] slot is not used, as the table is not 888 available in hv.c. 889 890 */ 891 892 struct body_details { 893 U8 body_size; /* Size to allocate */ 894 U8 copy; /* Size of structure to copy (may be shorter) */ 895 U8 offset; 896 unsigned int type : 4; /* We have space for a sanity check. */ 897 unsigned int cant_upgrade : 1; /* Cannot upgrade this type */ 898 unsigned int zero_nv : 1; /* zero the NV when upgrading from this */ 899 unsigned int arena : 1; /* Allocated from an arena */ 900 size_t arena_size; /* Size of arena to allocate */ 901 }; 902 903 #define HADNV FALSE 904 #define NONV TRUE 905 906 907 #ifdef PURIFY 908 /* With -DPURFIY we allocate everything directly, and don't use arenas. 909 This seems a rather elegant way to simplify some of the code below. */ 910 #define HASARENA FALSE 911 #else 912 #define HASARENA TRUE 913 #endif 914 #define NOARENA FALSE 915 916 /* Size the arenas to exactly fit a given number of bodies. A count 917 of 0 fits the max number bodies into a PERL_ARENA_SIZE.block, 918 simplifying the default. If count > 0, the arena is sized to fit 919 only that many bodies, allowing arenas to be used for large, rare 920 bodies (XPVFM, XPVIO) without undue waste. The arena size is 921 limited by PERL_ARENA_SIZE, so we can safely oversize the 922 declarations. 923 */ 924 #define FIT_ARENA0(body_size) \ 925 ((size_t)(PERL_ARENA_SIZE / body_size) * body_size) 926 #define FIT_ARENAn(count,body_size) \ 927 ( count * body_size <= PERL_ARENA_SIZE) \ 928 ? count * body_size \ 929 : FIT_ARENA0 (body_size) 930 #define FIT_ARENA(count,body_size) \ 931 (U32)(count \ 932 ? FIT_ARENAn (count, body_size) \ 933 : FIT_ARENA0 (body_size)) 934 935 /* Calculate the length to copy. Specifically work out the length less any 936 final padding the compiler needed to add. See the comment in sv_upgrade 937 for why copying the padding proved to be a bug. */ 938 939 #define copy_length(type, last_member) \ 940 STRUCT_OFFSET(type, last_member) \ 941 + sizeof (((type*)SvANY((const SV *)0))->last_member) 942 943 static const struct body_details bodies_by_type[] = { 944 /* HEs use this offset for their arena. */ 945 { 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 }, 946 947 /* IVs are in the head, so the allocation size is 0. */ 948 { 0, 949 sizeof(IV), /* This is used to copy out the IV body. */ 950 STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV, 951 NOARENA /* IVS don't need an arena */, 0 952 }, 953 954 { sizeof(NV), sizeof(NV), 955 STRUCT_OFFSET(XPVNV, xnv_u), 956 SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) }, 957 958 { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur), 959 copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur), 960 + STRUCT_OFFSET(XPV, xpv_cur), 961 SVt_PV, FALSE, NONV, HASARENA, 962 FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) }, 963 964 { sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur), 965 copy_length(XINVLIST, is_offset) - STRUCT_OFFSET(XPV, xpv_cur), 966 + STRUCT_OFFSET(XPV, xpv_cur), 967 SVt_INVLIST, TRUE, NONV, HASARENA, 968 FIT_ARENA(0, sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur)) }, 969 970 { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur), 971 copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur), 972 + STRUCT_OFFSET(XPV, xpv_cur), 973 SVt_PVIV, FALSE, NONV, HASARENA, 974 FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) }, 975 976 { sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur), 977 copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur), 978 + STRUCT_OFFSET(XPV, xpv_cur), 979 SVt_PVNV, FALSE, HADNV, HASARENA, 980 FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) }, 981 982 { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV, 983 HASARENA, FIT_ARENA(0, sizeof(XPVMG)) }, 984 985 { sizeof(regexp), 986 sizeof(regexp), 987 0, 988 SVt_REGEXP, TRUE, NONV, HASARENA, 989 FIT_ARENA(0, sizeof(regexp)) 990 }, 991 992 { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV, 993 HASARENA, FIT_ARENA(0, sizeof(XPVGV)) }, 994 995 { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV, 996 HASARENA, FIT_ARENA(0, sizeof(XPVLV)) }, 997 998 { sizeof(XPVAV), 999 copy_length(XPVAV, xav_alloc), 1000 0, 1001 SVt_PVAV, TRUE, NONV, HASARENA, 1002 FIT_ARENA(0, sizeof(XPVAV)) }, 1003 1004 { sizeof(XPVHV), 1005 copy_length(XPVHV, xhv_max), 1006 0, 1007 SVt_PVHV, TRUE, NONV, HASARENA, 1008 FIT_ARENA(0, sizeof(XPVHV)) }, 1009 1010 { sizeof(XPVCV), 1011 sizeof(XPVCV), 1012 0, 1013 SVt_PVCV, TRUE, NONV, HASARENA, 1014 FIT_ARENA(0, sizeof(XPVCV)) }, 1015 1016 { sizeof(XPVFM), 1017 sizeof(XPVFM), 1018 0, 1019 SVt_PVFM, TRUE, NONV, NOARENA, 1020 FIT_ARENA(20, sizeof(XPVFM)) }, 1021 1022 { sizeof(XPVIO), 1023 sizeof(XPVIO), 1024 0, 1025 SVt_PVIO, TRUE, NONV, HASARENA, 1026 FIT_ARENA(24, sizeof(XPVIO)) }, 1027 }; 1028 1029 #define new_body_allocated(sv_type) \ 1030 (void *)((char *)S_new_body(aTHX_ sv_type) \ 1031 - bodies_by_type[sv_type].offset) 1032 1033 /* return a thing to the free list */ 1034 1035 #define del_body(thing, root) \ 1036 STMT_START { \ 1037 void ** const thing_copy = (void **)thing; \ 1038 *thing_copy = *root; \ 1039 *root = (void*)thing_copy; \ 1040 } STMT_END 1041 1042 #ifdef PURIFY 1043 1044 #define new_XNV() safemalloc(sizeof(XPVNV)) 1045 #define new_XPVNV() safemalloc(sizeof(XPVNV)) 1046 #define new_XPVMG() safemalloc(sizeof(XPVMG)) 1047 1048 #define del_XPVGV(p) safefree(p) 1049 1050 #else /* !PURIFY */ 1051 1052 #define new_XNV() new_body_allocated(SVt_NV) 1053 #define new_XPVNV() new_body_allocated(SVt_PVNV) 1054 #define new_XPVMG() new_body_allocated(SVt_PVMG) 1055 1056 #define del_XPVGV(p) del_body(p + bodies_by_type[SVt_PVGV].offset, \ 1057 &PL_body_roots[SVt_PVGV]) 1058 1059 #endif /* PURIFY */ 1060 1061 /* no arena for you! */ 1062 1063 #define new_NOARENA(details) \ 1064 safemalloc((details)->body_size + (details)->offset) 1065 #define new_NOARENAZ(details) \ 1066 safecalloc((details)->body_size + (details)->offset, 1) 1067 1068 void * 1069 Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size, 1070 const size_t arena_size) 1071 { 1072 dVAR; 1073 void ** const root = &PL_body_roots[sv_type]; 1074 struct arena_desc *adesc; 1075 struct arena_set *aroot = (struct arena_set *) PL_body_arenas; 1076 unsigned int curr; 1077 char *start; 1078 const char *end; 1079 const size_t good_arena_size = Perl_malloc_good_size(arena_size); 1080 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE) 1081 static bool done_sanity_check; 1082 1083 /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global 1084 * variables like done_sanity_check. */ 1085 if (!done_sanity_check) { 1086 unsigned int i = SVt_LAST; 1087 1088 done_sanity_check = TRUE; 1089 1090 while (i--) 1091 assert (bodies_by_type[i].type == i); 1092 } 1093 #endif 1094 1095 assert(arena_size); 1096 1097 /* may need new arena-set to hold new arena */ 1098 if (!aroot || aroot->curr >= aroot->set_size) { 1099 struct arena_set *newroot; 1100 Newxz(newroot, 1, struct arena_set); 1101 newroot->set_size = ARENAS_PER_SET; 1102 newroot->next = aroot; 1103 aroot = newroot; 1104 PL_body_arenas = (void *) newroot; 1105 DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot)); 1106 } 1107 1108 /* ok, now have arena-set with at least 1 empty/available arena-desc */ 1109 curr = aroot->curr++; 1110 adesc = &(aroot->set[curr]); 1111 assert(!adesc->arena); 1112 1113 Newx(adesc->arena, good_arena_size, char); 1114 adesc->size = good_arena_size; 1115 adesc->utype = sv_type; 1116 DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n", 1117 curr, (void*)adesc->arena, (UV)good_arena_size)); 1118 1119 start = (char *) adesc->arena; 1120 1121 /* Get the address of the byte after the end of the last body we can fit. 1122 Remember, this is integer division: */ 1123 end = start + good_arena_size / body_size * body_size; 1124 1125 /* computed count doesn't reflect the 1st slot reservation */ 1126 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE) 1127 DEBUG_m(PerlIO_printf(Perl_debug_log, 1128 "arena %p end %p arena-size %d (from %d) type %d " 1129 "size %d ct %d\n", 1130 (void*)start, (void*)end, (int)good_arena_size, 1131 (int)arena_size, sv_type, (int)body_size, 1132 (int)good_arena_size / (int)body_size)); 1133 #else 1134 DEBUG_m(PerlIO_printf(Perl_debug_log, 1135 "arena %p end %p arena-size %d type %d size %d ct %d\n", 1136 (void*)start, (void*)end, 1137 (int)arena_size, sv_type, (int)body_size, 1138 (int)good_arena_size / (int)body_size)); 1139 #endif 1140 *root = (void *)start; 1141 1142 while (1) { 1143 /* Where the next body would start: */ 1144 char * const next = start + body_size; 1145 1146 if (next >= end) { 1147 /* This is the last body: */ 1148 assert(next == end); 1149 1150 *(void **)start = 0; 1151 return *root; 1152 } 1153 1154 *(void**) start = (void *)next; 1155 start = next; 1156 } 1157 } 1158 1159 /* grab a new thing from the free list, allocating more if necessary. 1160 The inline version is used for speed in hot routines, and the 1161 function using it serves the rest (unless PURIFY). 1162 */ 1163 #define new_body_inline(xpv, sv_type) \ 1164 STMT_START { \ 1165 void ** const r3wt = &PL_body_roots[sv_type]; \ 1166 xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \ 1167 ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ sv_type, \ 1168 bodies_by_type[sv_type].body_size,\ 1169 bodies_by_type[sv_type].arena_size)); \ 1170 *(r3wt) = *(void**)(xpv); \ 1171 } STMT_END 1172 1173 #ifndef PURIFY 1174 1175 STATIC void * 1176 S_new_body(pTHX_ const svtype sv_type) 1177 { 1178 dVAR; 1179 void *xpv; 1180 new_body_inline(xpv, sv_type); 1181 return xpv; 1182 } 1183 1184 #endif 1185 1186 static const struct body_details fake_rv = 1187 { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 }; 1188 1189 /* 1190 =for apidoc sv_upgrade 1191 1192 Upgrade an SV to a more complex form. Generally adds a new body type to the 1193 SV, then copies across as much information as possible from the old body. 1194 It croaks if the SV is already in a more complex form than requested. You 1195 generally want to use the C<SvUPGRADE> macro wrapper, which checks the type 1196 before calling C<sv_upgrade>, and hence does not croak. See also 1197 C<svtype>. 1198 1199 =cut 1200 */ 1201 1202 void 1203 Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type) 1204 { 1205 dVAR; 1206 void* old_body; 1207 void* new_body; 1208 const svtype old_type = SvTYPE(sv); 1209 const struct body_details *new_type_details; 1210 const struct body_details *old_type_details 1211 = bodies_by_type + old_type; 1212 SV *referant = NULL; 1213 1214 PERL_ARGS_ASSERT_SV_UPGRADE; 1215 1216 if (old_type == new_type) 1217 return; 1218 1219 /* This clause was purposefully added ahead of the early return above to 1220 the shared string hackery for (sort {$a <=> $b} keys %hash), with the 1221 inference by Nick I-S that it would fix other troublesome cases. See 1222 changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent) 1223 1224 Given that shared hash key scalars are no longer PVIV, but PV, there is 1225 no longer need to unshare so as to free up the IVX slot for its proper 1226 purpose. So it's safe to move the early return earlier. */ 1227 1228 if (new_type > SVt_PVMG && SvIsCOW(sv)) { 1229 sv_force_normal_flags(sv, 0); 1230 } 1231 1232 old_body = SvANY(sv); 1233 1234 /* Copying structures onto other structures that have been neatly zeroed 1235 has a subtle gotcha. Consider XPVMG 1236 1237 +------+------+------+------+------+-------+-------+ 1238 | NV | CUR | LEN | IV | MAGIC | STASH | 1239 +------+------+------+------+------+-------+-------+ 1240 0 4 8 12 16 20 24 28 1241 1242 where NVs are aligned to 8 bytes, so that sizeof that structure is 1243 actually 32 bytes long, with 4 bytes of padding at the end: 1244 1245 +------+------+------+------+------+-------+-------+------+ 1246 | NV | CUR | LEN | IV | MAGIC | STASH | ??? | 1247 +------+------+------+------+------+-------+-------+------+ 1248 0 4 8 12 16 20 24 28 32 1249 1250 so what happens if you allocate memory for this structure: 1251 1252 +------+------+------+------+------+-------+-------+------+------+... 1253 | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME | 1254 +------+------+------+------+------+-------+-------+------+------+... 1255 0 4 8 12 16 20 24 28 32 36 1256 1257 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you 1258 expect, because you copy the area marked ??? onto GP. Now, ??? may have 1259 started out as zero once, but it's quite possible that it isn't. So now, 1260 rather than a nicely zeroed GP, you have it pointing somewhere random. 1261 Bugs ensue. 1262 1263 (In fact, GP ends up pointing at a previous GP structure, because the 1264 principle cause of the padding in XPVMG getting garbage is a copy of 1265 sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now 1266 this happens to be moot because XPVGV has been re-ordered, with GP 1267 no longer after STASH) 1268 1269 So we are careful and work out the size of used parts of all the 1270 structures. */ 1271 1272 switch (old_type) { 1273 case SVt_NULL: 1274 break; 1275 case SVt_IV: 1276 if (SvROK(sv)) { 1277 referant = SvRV(sv); 1278 old_type_details = &fake_rv; 1279 if (new_type == SVt_NV) 1280 new_type = SVt_PVNV; 1281 } else { 1282 if (new_type < SVt_PVIV) { 1283 new_type = (new_type == SVt_NV) 1284 ? SVt_PVNV : SVt_PVIV; 1285 } 1286 } 1287 break; 1288 case SVt_NV: 1289 if (new_type < SVt_PVNV) { 1290 new_type = SVt_PVNV; 1291 } 1292 break; 1293 case SVt_PV: 1294 assert(new_type > SVt_PV); 1295 assert(SVt_IV < SVt_PV); 1296 assert(SVt_NV < SVt_PV); 1297 break; 1298 case SVt_PVIV: 1299 break; 1300 case SVt_PVNV: 1301 break; 1302 case SVt_PVMG: 1303 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena, 1304 there's no way that it can be safely upgraded, because perl.c 1305 expects to Safefree(SvANY(PL_mess_sv)) */ 1306 assert(sv != PL_mess_sv); 1307 /* This flag bit is used to mean other things in other scalar types. 1308 Given that it only has meaning inside the pad, it shouldn't be set 1309 on anything that can get upgraded. */ 1310 assert(!SvPAD_TYPED(sv)); 1311 break; 1312 default: 1313 if (UNLIKELY(old_type_details->cant_upgrade)) 1314 Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf, 1315 sv_reftype(sv, 0), (UV) old_type, (UV) new_type); 1316 } 1317 1318 if (UNLIKELY(old_type > new_type)) 1319 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d", 1320 (int)old_type, (int)new_type); 1321 1322 new_type_details = bodies_by_type + new_type; 1323 1324 SvFLAGS(sv) &= ~SVTYPEMASK; 1325 SvFLAGS(sv) |= new_type; 1326 1327 /* This can't happen, as SVt_NULL is <= all values of new_type, so one of 1328 the return statements above will have triggered. */ 1329 assert (new_type != SVt_NULL); 1330 switch (new_type) { 1331 case SVt_IV: 1332 assert(old_type == SVt_NULL); 1333 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv)); 1334 SvIV_set(sv, 0); 1335 return; 1336 case SVt_NV: 1337 assert(old_type == SVt_NULL); 1338 SvANY(sv) = new_XNV(); 1339 SvNV_set(sv, 0); 1340 return; 1341 case SVt_PVHV: 1342 case SVt_PVAV: 1343 assert(new_type_details->body_size); 1344 1345 #ifndef PURIFY 1346 assert(new_type_details->arena); 1347 assert(new_type_details->arena_size); 1348 /* This points to the start of the allocated area. */ 1349 new_body_inline(new_body, new_type); 1350 Zero(new_body, new_type_details->body_size, char); 1351 new_body = ((char *)new_body) - new_type_details->offset; 1352 #else 1353 /* We always allocated the full length item with PURIFY. To do this 1354 we fake things so that arena is false for all 16 types.. */ 1355 new_body = new_NOARENAZ(new_type_details); 1356 #endif 1357 SvANY(sv) = new_body; 1358 if (new_type == SVt_PVAV) { 1359 AvMAX(sv) = -1; 1360 AvFILLp(sv) = -1; 1361 AvREAL_only(sv); 1362 if (old_type_details->body_size) { 1363 AvALLOC(sv) = 0; 1364 } else { 1365 /* It will have been zeroed when the new body was allocated. 1366 Lets not write to it, in case it confuses a write-back 1367 cache. */ 1368 } 1369 } else { 1370 assert(!SvOK(sv)); 1371 SvOK_off(sv); 1372 #ifndef NODEFAULT_SHAREKEYS 1373 HvSHAREKEYS_on(sv); /* key-sharing on by default */ 1374 #endif 1375 /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */ 1376 HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX; 1377 } 1378 1379 /* SVt_NULL isn't the only thing upgraded to AV or HV. 1380 The target created by newSVrv also is, and it can have magic. 1381 However, it never has SvPVX set. 1382 */ 1383 if (old_type == SVt_IV) { 1384 assert(!SvROK(sv)); 1385 } else if (old_type >= SVt_PV) { 1386 assert(SvPVX_const(sv) == 0); 1387 } 1388 1389 if (old_type >= SVt_PVMG) { 1390 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic); 1391 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash); 1392 } else { 1393 sv->sv_u.svu_array = NULL; /* or svu_hash */ 1394 } 1395 break; 1396 1397 case SVt_PVIV: 1398 /* XXX Is this still needed? Was it ever needed? Surely as there is 1399 no route from NV to PVIV, NOK can never be true */ 1400 assert(!SvNOKp(sv)); 1401 assert(!SvNOK(sv)); 1402 case SVt_PVIO: 1403 case SVt_PVFM: 1404 case SVt_PVGV: 1405 case SVt_PVCV: 1406 case SVt_PVLV: 1407 case SVt_INVLIST: 1408 case SVt_REGEXP: 1409 case SVt_PVMG: 1410 case SVt_PVNV: 1411 case SVt_PV: 1412 1413 assert(new_type_details->body_size); 1414 /* We always allocated the full length item with PURIFY. To do this 1415 we fake things so that arena is false for all 16 types.. */ 1416 if(new_type_details->arena) { 1417 /* This points to the start of the allocated area. */ 1418 new_body_inline(new_body, new_type); 1419 Zero(new_body, new_type_details->body_size, char); 1420 new_body = ((char *)new_body) - new_type_details->offset; 1421 } else { 1422 new_body = new_NOARENAZ(new_type_details); 1423 } 1424 SvANY(sv) = new_body; 1425 1426 if (old_type_details->copy) { 1427 /* There is now the potential for an upgrade from something without 1428 an offset (PVNV or PVMG) to something with one (PVCV, PVFM) */ 1429 int offset = old_type_details->offset; 1430 int length = old_type_details->copy; 1431 1432 if (new_type_details->offset > old_type_details->offset) { 1433 const int difference 1434 = new_type_details->offset - old_type_details->offset; 1435 offset += difference; 1436 length -= difference; 1437 } 1438 assert (length >= 0); 1439 1440 Copy((char *)old_body + offset, (char *)new_body + offset, length, 1441 char); 1442 } 1443 1444 #ifndef NV_ZERO_IS_ALLBITS_ZERO 1445 /* If NV 0.0 is stores as all bits 0 then Zero() already creates a 1446 * correct 0.0 for us. Otherwise, if the old body didn't have an 1447 * NV slot, but the new one does, then we need to initialise the 1448 * freshly created NV slot with whatever the correct bit pattern is 1449 * for 0.0 */ 1450 if (old_type_details->zero_nv && !new_type_details->zero_nv 1451 && !isGV_with_GP(sv)) 1452 SvNV_set(sv, 0); 1453 #endif 1454 1455 if (UNLIKELY(new_type == SVt_PVIO)) { 1456 IO * const io = MUTABLE_IO(sv); 1457 GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV); 1458 1459 SvOBJECT_on(io); 1460 /* Clear the stashcache because a new IO could overrule a package 1461 name */ 1462 DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n")); 1463 hv_clear(PL_stashcache); 1464 1465 SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv)))); 1466 IoPAGE_LEN(sv) = 60; 1467 } 1468 if (UNLIKELY(new_type == SVt_REGEXP)) 1469 sv->sv_u.svu_rx = (regexp *)new_body; 1470 else if (old_type < SVt_PV) { 1471 /* referant will be NULL unless the old type was SVt_IV emulating 1472 SVt_RV */ 1473 sv->sv_u.svu_rv = referant; 1474 } 1475 break; 1476 default: 1477 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", 1478 (unsigned long)new_type); 1479 } 1480 1481 if (old_type > SVt_IV) { 1482 #ifdef PURIFY 1483 safefree(old_body); 1484 #else 1485 /* Note that there is an assumption that all bodies of types that 1486 can be upgraded came from arenas. Only the more complex non- 1487 upgradable types are allowed to be directly malloc()ed. */ 1488 assert(old_type_details->arena); 1489 del_body((void*)((char*)old_body + old_type_details->offset), 1490 &PL_body_roots[old_type]); 1491 #endif 1492 } 1493 } 1494 1495 /* 1496 =for apidoc sv_backoff 1497 1498 Remove any string offset. You should normally use the C<SvOOK_off> macro 1499 wrapper instead. 1500 1501 =cut 1502 */ 1503 1504 int 1505 Perl_sv_backoff(pTHX_ SV *const sv) 1506 { 1507 STRLEN delta; 1508 const char * const s = SvPVX_const(sv); 1509 1510 PERL_ARGS_ASSERT_SV_BACKOFF; 1511 PERL_UNUSED_CONTEXT; 1512 1513 assert(SvOOK(sv)); 1514 assert(SvTYPE(sv) != SVt_PVHV); 1515 assert(SvTYPE(sv) != SVt_PVAV); 1516 1517 SvOOK_offset(sv, delta); 1518 1519 SvLEN_set(sv, SvLEN(sv) + delta); 1520 SvPV_set(sv, SvPVX(sv) - delta); 1521 Move(s, SvPVX(sv), SvCUR(sv)+1, char); 1522 SvFLAGS(sv) &= ~SVf_OOK; 1523 return 0; 1524 } 1525 1526 /* 1527 =for apidoc sv_grow 1528 1529 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and 1530 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer. 1531 Use the C<SvGROW> wrapper instead. 1532 1533 =cut 1534 */ 1535 1536 static void S_sv_uncow(pTHX_ SV * const sv, const U32 flags); 1537 1538 char * 1539 Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen) 1540 { 1541 char *s; 1542 1543 PERL_ARGS_ASSERT_SV_GROW; 1544 1545 if (SvROK(sv)) 1546 sv_unref(sv); 1547 if (SvTYPE(sv) < SVt_PV) { 1548 sv_upgrade(sv, SVt_PV); 1549 s = SvPVX_mutable(sv); 1550 } 1551 else if (SvOOK(sv)) { /* pv is offset? */ 1552 sv_backoff(sv); 1553 s = SvPVX_mutable(sv); 1554 if (newlen > SvLEN(sv)) 1555 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */ 1556 } 1557 else 1558 { 1559 if (SvIsCOW(sv)) S_sv_uncow(aTHX_ sv, 0); 1560 s = SvPVX_mutable(sv); 1561 } 1562 1563 #ifdef PERL_NEW_COPY_ON_WRITE 1564 /* the new COW scheme uses SvPVX(sv)[SvLEN(sv)-1] (if spare) 1565 * to store the COW count. So in general, allocate one more byte than 1566 * asked for, to make it likely this byte is always spare: and thus 1567 * make more strings COW-able. 1568 * If the new size is a big power of two, don't bother: we assume the 1569 * caller wanted a nice 2^N sized block and will be annoyed at getting 1570 * 2^N+1 */ 1571 if (newlen & 0xff) 1572 newlen++; 1573 #endif 1574 1575 #if defined(PERL_USE_MALLOC_SIZE) && defined(Perl_safesysmalloc_size) 1576 #define PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC 1577 #endif 1578 1579 if (newlen > SvLEN(sv)) { /* need more room? */ 1580 STRLEN minlen = SvCUR(sv); 1581 minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10; 1582 if (newlen < minlen) 1583 newlen = minlen; 1584 #ifndef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC 1585 if (SvLEN(sv)) { 1586 newlen = PERL_STRLEN_ROUNDUP(newlen); 1587 } 1588 #endif 1589 if (SvLEN(sv) && s) { 1590 s = (char*)saferealloc(s, newlen); 1591 } 1592 else { 1593 s = (char*)safemalloc(newlen); 1594 if (SvPVX_const(sv) && SvCUR(sv)) { 1595 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char); 1596 } 1597 } 1598 SvPV_set(sv, s); 1599 #ifdef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC 1600 /* Do this here, do it once, do it right, and then we will never get 1601 called back into sv_grow() unless there really is some growing 1602 needed. */ 1603 SvLEN_set(sv, Perl_safesysmalloc_size(s)); 1604 #else 1605 SvLEN_set(sv, newlen); 1606 #endif 1607 } 1608 return s; 1609 } 1610 1611 /* 1612 =for apidoc sv_setiv 1613 1614 Copies an integer into the given SV, upgrading first if necessary. 1615 Does not handle 'set' magic. See also C<sv_setiv_mg>. 1616 1617 =cut 1618 */ 1619 1620 void 1621 Perl_sv_setiv(pTHX_ SV *const sv, const IV i) 1622 { 1623 dVAR; 1624 1625 PERL_ARGS_ASSERT_SV_SETIV; 1626 1627 SV_CHECK_THINKFIRST_COW_DROP(sv); 1628 switch (SvTYPE(sv)) { 1629 case SVt_NULL: 1630 case SVt_NV: 1631 sv_upgrade(sv, SVt_IV); 1632 break; 1633 case SVt_PV: 1634 sv_upgrade(sv, SVt_PVIV); 1635 break; 1636 1637 case SVt_PVGV: 1638 if (!isGV_with_GP(sv)) 1639 break; 1640 case SVt_PVAV: 1641 case SVt_PVHV: 1642 case SVt_PVCV: 1643 case SVt_PVFM: 1644 case SVt_PVIO: 1645 /* diag_listed_as: Can't coerce %s to %s in %s */ 1646 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0), 1647 OP_DESC(PL_op)); 1648 default: NOOP; 1649 } 1650 (void)SvIOK_only(sv); /* validate number */ 1651 SvIV_set(sv, i); 1652 SvTAINT(sv); 1653 } 1654 1655 /* 1656 =for apidoc sv_setiv_mg 1657 1658 Like C<sv_setiv>, but also handles 'set' magic. 1659 1660 =cut 1661 */ 1662 1663 void 1664 Perl_sv_setiv_mg(pTHX_ SV *const sv, const IV i) 1665 { 1666 PERL_ARGS_ASSERT_SV_SETIV_MG; 1667 1668 sv_setiv(sv,i); 1669 SvSETMAGIC(sv); 1670 } 1671 1672 /* 1673 =for apidoc sv_setuv 1674 1675 Copies an unsigned integer into the given SV, upgrading first if necessary. 1676 Does not handle 'set' magic. See also C<sv_setuv_mg>. 1677 1678 =cut 1679 */ 1680 1681 void 1682 Perl_sv_setuv(pTHX_ SV *const sv, const UV u) 1683 { 1684 PERL_ARGS_ASSERT_SV_SETUV; 1685 1686 /* With the if statement to ensure that integers are stored as IVs whenever 1687 possible: 1688 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865 1689 1690 without 1691 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865 1692 1693 If you wish to remove the following if statement, so that this routine 1694 (and its callers) always return UVs, please benchmark to see what the 1695 effect is. Modern CPUs may be different. Or may not :-) 1696 */ 1697 if (u <= (UV)IV_MAX) { 1698 sv_setiv(sv, (IV)u); 1699 return; 1700 } 1701 sv_setiv(sv, 0); 1702 SvIsUV_on(sv); 1703 SvUV_set(sv, u); 1704 } 1705 1706 /* 1707 =for apidoc sv_setuv_mg 1708 1709 Like C<sv_setuv>, but also handles 'set' magic. 1710 1711 =cut 1712 */ 1713 1714 void 1715 Perl_sv_setuv_mg(pTHX_ SV *const sv, const UV u) 1716 { 1717 PERL_ARGS_ASSERT_SV_SETUV_MG; 1718 1719 sv_setuv(sv,u); 1720 SvSETMAGIC(sv); 1721 } 1722 1723 /* 1724 =for apidoc sv_setnv 1725 1726 Copies a double into the given SV, upgrading first if necessary. 1727 Does not handle 'set' magic. See also C<sv_setnv_mg>. 1728 1729 =cut 1730 */ 1731 1732 void 1733 Perl_sv_setnv(pTHX_ SV *const sv, const NV num) 1734 { 1735 dVAR; 1736 1737 PERL_ARGS_ASSERT_SV_SETNV; 1738 1739 SV_CHECK_THINKFIRST_COW_DROP(sv); 1740 switch (SvTYPE(sv)) { 1741 case SVt_NULL: 1742 case SVt_IV: 1743 sv_upgrade(sv, SVt_NV); 1744 break; 1745 case SVt_PV: 1746 case SVt_PVIV: 1747 sv_upgrade(sv, SVt_PVNV); 1748 break; 1749 1750 case SVt_PVGV: 1751 if (!isGV_with_GP(sv)) 1752 break; 1753 case SVt_PVAV: 1754 case SVt_PVHV: 1755 case SVt_PVCV: 1756 case SVt_PVFM: 1757 case SVt_PVIO: 1758 /* diag_listed_as: Can't coerce %s to %s in %s */ 1759 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0), 1760 OP_DESC(PL_op)); 1761 default: NOOP; 1762 } 1763 SvNV_set(sv, num); 1764 (void)SvNOK_only(sv); /* validate number */ 1765 SvTAINT(sv); 1766 } 1767 1768 /* 1769 =for apidoc sv_setnv_mg 1770 1771 Like C<sv_setnv>, but also handles 'set' magic. 1772 1773 =cut 1774 */ 1775 1776 void 1777 Perl_sv_setnv_mg(pTHX_ SV *const sv, const NV num) 1778 { 1779 PERL_ARGS_ASSERT_SV_SETNV_MG; 1780 1781 sv_setnv(sv,num); 1782 SvSETMAGIC(sv); 1783 } 1784 1785 /* Print an "isn't numeric" warning, using a cleaned-up, 1786 * printable version of the offending string 1787 */ 1788 1789 STATIC void 1790 S_not_a_number(pTHX_ SV *const sv) 1791 { 1792 dVAR; 1793 SV *dsv; 1794 char tmpbuf[64]; 1795 const char *pv; 1796 1797 PERL_ARGS_ASSERT_NOT_A_NUMBER; 1798 1799 if (DO_UTF8(sv)) { 1800 dsv = newSVpvs_flags("", SVs_TEMP); 1801 pv = sv_uni_display(dsv, sv, 10, UNI_DISPLAY_ISPRINT); 1802 } else { 1803 char *d = tmpbuf; 1804 const char * const limit = tmpbuf + sizeof(tmpbuf) - 8; 1805 /* each *s can expand to 4 chars + "...\0", 1806 i.e. need room for 8 chars */ 1807 1808 const char *s = SvPVX_const(sv); 1809 const char * const end = s + SvCUR(sv); 1810 for ( ; s < end && d < limit; s++ ) { 1811 int ch = *s & 0xFF; 1812 if (! isASCII(ch) && !isPRINT_LC(ch)) { 1813 *d++ = 'M'; 1814 *d++ = '-'; 1815 1816 /* Map to ASCII "equivalent" of Latin1 */ 1817 ch = LATIN1_TO_NATIVE(NATIVE_TO_LATIN1(ch) & 127); 1818 } 1819 if (ch == '\n') { 1820 *d++ = '\\'; 1821 *d++ = 'n'; 1822 } 1823 else if (ch == '\r') { 1824 *d++ = '\\'; 1825 *d++ = 'r'; 1826 } 1827 else if (ch == '\f') { 1828 *d++ = '\\'; 1829 *d++ = 'f'; 1830 } 1831 else if (ch == '\\') { 1832 *d++ = '\\'; 1833 *d++ = '\\'; 1834 } 1835 else if (ch == '\0') { 1836 *d++ = '\\'; 1837 *d++ = '0'; 1838 } 1839 else if (isPRINT_LC(ch)) 1840 *d++ = ch; 1841 else { 1842 *d++ = '^'; 1843 *d++ = toCTRL(ch); 1844 } 1845 } 1846 if (s < end) { 1847 *d++ = '.'; 1848 *d++ = '.'; 1849 *d++ = '.'; 1850 } 1851 *d = '\0'; 1852 pv = tmpbuf; 1853 } 1854 1855 if (PL_op) 1856 Perl_warner(aTHX_ packWARN(WARN_NUMERIC), 1857 /* diag_listed_as: Argument "%s" isn't numeric%s */ 1858 "Argument \"%s\" isn't numeric in %s", pv, 1859 OP_DESC(PL_op)); 1860 else 1861 Perl_warner(aTHX_ packWARN(WARN_NUMERIC), 1862 /* diag_listed_as: Argument "%s" isn't numeric%s */ 1863 "Argument \"%s\" isn't numeric", pv); 1864 } 1865 1866 /* 1867 =for apidoc looks_like_number 1868 1869 Test if the content of an SV looks like a number (or is a number). 1870 C<Inf> and C<Infinity> are treated as numbers (so will not issue a 1871 non-numeric warning), even if your atof() doesn't grok them. Get-magic is 1872 ignored. 1873 1874 =cut 1875 */ 1876 1877 I32 1878 Perl_looks_like_number(pTHX_ SV *const sv) 1879 { 1880 const char *sbegin; 1881 STRLEN len; 1882 1883 PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER; 1884 1885 if (SvPOK(sv) || SvPOKp(sv)) { 1886 sbegin = SvPV_nomg_const(sv, len); 1887 } 1888 else 1889 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK); 1890 return grok_number(sbegin, len, NULL); 1891 } 1892 1893 STATIC bool 1894 S_glob_2number(pTHX_ GV * const gv) 1895 { 1896 PERL_ARGS_ASSERT_GLOB_2NUMBER; 1897 1898 /* We know that all GVs stringify to something that is not-a-number, 1899 so no need to test that. */ 1900 if (ckWARN(WARN_NUMERIC)) 1901 { 1902 SV *const buffer = sv_newmortal(); 1903 gv_efullname3(buffer, gv, "*"); 1904 not_a_number(buffer); 1905 } 1906 /* We just want something true to return, so that S_sv_2iuv_common 1907 can tail call us and return true. */ 1908 return TRUE; 1909 } 1910 1911 /* Actually, ISO C leaves conversion of UV to IV undefined, but 1912 until proven guilty, assume that things are not that bad... */ 1913 1914 /* 1915 NV_PRESERVES_UV: 1916 1917 As 64 bit platforms often have an NV that doesn't preserve all bits of 1918 an IV (an assumption perl has been based on to date) it becomes necessary 1919 to remove the assumption that the NV always carries enough precision to 1920 recreate the IV whenever needed, and that the NV is the canonical form. 1921 Instead, IV/UV and NV need to be given equal rights. So as to not lose 1922 precision as a side effect of conversion (which would lead to insanity 1923 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is 1924 1) to distinguish between IV/UV/NV slots that have cached a valid 1925 conversion where precision was lost and IV/UV/NV slots that have a 1926 valid conversion which has lost no precision 1927 2) to ensure that if a numeric conversion to one form is requested that 1928 would lose precision, the precise conversion (or differently 1929 imprecise conversion) is also performed and cached, to prevent 1930 requests for different numeric formats on the same SV causing 1931 lossy conversion chains. (lossless conversion chains are perfectly 1932 acceptable (still)) 1933 1934 1935 flags are used: 1936 SvIOKp is true if the IV slot contains a valid value 1937 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true) 1938 SvNOKp is true if the NV slot contains a valid value 1939 SvNOK is true only if the NV value is accurate 1940 1941 so 1942 while converting from PV to NV, check to see if converting that NV to an 1943 IV(or UV) would lose accuracy over a direct conversion from PV to 1944 IV(or UV). If it would, cache both conversions, return NV, but mark 1945 SV as IOK NOKp (ie not NOK). 1946 1947 While converting from PV to IV, check to see if converting that IV to an 1948 NV would lose accuracy over a direct conversion from PV to NV. If it 1949 would, cache both conversions, flag similarly. 1950 1951 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite 1952 correctly because if IV & NV were set NV *always* overruled. 1953 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning 1954 changes - now IV and NV together means that the two are interchangeable: 1955 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX; 1956 1957 The benefit of this is that operations such as pp_add know that if 1958 SvIOK is true for both left and right operands, then integer addition 1959 can be used instead of floating point (for cases where the result won't 1960 overflow). Before, floating point was always used, which could lead to 1961 loss of precision compared with integer addition. 1962 1963 * making IV and NV equal status should make maths accurate on 64 bit 1964 platforms 1965 * may speed up maths somewhat if pp_add and friends start to use 1966 integers when possible instead of fp. (Hopefully the overhead in 1967 looking for SvIOK and checking for overflow will not outweigh the 1968 fp to integer speedup) 1969 * will slow down integer operations (callers of SvIV) on "inaccurate" 1970 values, as the change from SvIOK to SvIOKp will cause a call into 1971 sv_2iv each time rather than a macro access direct to the IV slot 1972 * should speed up number->string conversion on integers as IV is 1973 favoured when IV and NV are equally accurate 1974 1975 #################################################################### 1976 You had better be using SvIOK_notUV if you want an IV for arithmetic: 1977 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV. 1978 On the other hand, SvUOK is true iff UV. 1979 #################################################################### 1980 1981 Your mileage will vary depending your CPU's relative fp to integer 1982 performance ratio. 1983 */ 1984 1985 #ifndef NV_PRESERVES_UV 1986 # define IS_NUMBER_UNDERFLOW_IV 1 1987 # define IS_NUMBER_UNDERFLOW_UV 2 1988 # define IS_NUMBER_IV_AND_UV 2 1989 # define IS_NUMBER_OVERFLOW_IV 4 1990 # define IS_NUMBER_OVERFLOW_UV 5 1991 1992 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */ 1993 1994 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */ 1995 STATIC int 1996 S_sv_2iuv_non_preserve(pTHX_ SV *const sv 1997 # ifdef DEBUGGING 1998 , I32 numtype 1999 # endif 2000 ) 2001 { 2002 dVAR; 2003 2004 PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE; 2005 2006 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv), (UV)numtype)); 2007 if (SvNVX(sv) < (NV)IV_MIN) { 2008 (void)SvIOKp_on(sv); 2009 (void)SvNOK_on(sv); 2010 SvIV_set(sv, IV_MIN); 2011 return IS_NUMBER_UNDERFLOW_IV; 2012 } 2013 if (SvNVX(sv) > (NV)UV_MAX) { 2014 (void)SvIOKp_on(sv); 2015 (void)SvNOK_on(sv); 2016 SvIsUV_on(sv); 2017 SvUV_set(sv, UV_MAX); 2018 return IS_NUMBER_OVERFLOW_UV; 2019 } 2020 (void)SvIOKp_on(sv); 2021 (void)SvNOK_on(sv); 2022 /* Can't use strtol etc to convert this string. (See truth table in 2023 sv_2iv */ 2024 if (SvNVX(sv) <= (UV)IV_MAX) { 2025 SvIV_set(sv, I_V(SvNVX(sv))); 2026 if ((NV)(SvIVX(sv)) == SvNVX(sv)) { 2027 SvIOK_on(sv); /* Integer is precise. NOK, IOK */ 2028 } else { 2029 /* Integer is imprecise. NOK, IOKp */ 2030 } 2031 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV; 2032 } 2033 SvIsUV_on(sv); 2034 SvUV_set(sv, U_V(SvNVX(sv))); 2035 if ((NV)(SvUVX(sv)) == SvNVX(sv)) { 2036 if (SvUVX(sv) == UV_MAX) { 2037 /* As we know that NVs don't preserve UVs, UV_MAX cannot 2038 possibly be preserved by NV. Hence, it must be overflow. 2039 NOK, IOKp */ 2040 return IS_NUMBER_OVERFLOW_UV; 2041 } 2042 SvIOK_on(sv); /* Integer is precise. NOK, UOK */ 2043 } else { 2044 /* Integer is imprecise. NOK, IOKp */ 2045 } 2046 return IS_NUMBER_OVERFLOW_IV; 2047 } 2048 #endif /* !NV_PRESERVES_UV*/ 2049 2050 STATIC bool 2051 S_sv_2iuv_common(pTHX_ SV *const sv) 2052 { 2053 dVAR; 2054 2055 PERL_ARGS_ASSERT_SV_2IUV_COMMON; 2056 2057 if (SvNOKp(sv)) { 2058 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv 2059 * without also getting a cached IV/UV from it at the same time 2060 * (ie PV->NV conversion should detect loss of accuracy and cache 2061 * IV or UV at same time to avoid this. */ 2062 /* IV-over-UV optimisation - choose to cache IV if possible */ 2063 2064 if (SvTYPE(sv) == SVt_NV) 2065 sv_upgrade(sv, SVt_PVNV); 2066 2067 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */ 2068 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost 2069 certainly cast into the IV range at IV_MAX, whereas the correct 2070 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary 2071 cases go to UV */ 2072 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) 2073 if (Perl_isnan(SvNVX(sv))) { 2074 SvUV_set(sv, 0); 2075 SvIsUV_on(sv); 2076 return FALSE; 2077 } 2078 #endif 2079 if (SvNVX(sv) < (NV)IV_MAX + 0.5) { 2080 SvIV_set(sv, I_V(SvNVX(sv))); 2081 if (SvNVX(sv) == (NV) SvIVX(sv) 2082 #ifndef NV_PRESERVES_UV 2083 && (((UV)1 << NV_PRESERVES_UV_BITS) > 2084 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv))) 2085 /* Don't flag it as "accurately an integer" if the number 2086 came from a (by definition imprecise) NV operation, and 2087 we're outside the range of NV integer precision */ 2088 #endif 2089 ) { 2090 if (SvNOK(sv)) 2091 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */ 2092 else { 2093 /* scalar has trailing garbage, eg "42a" */ 2094 } 2095 DEBUG_c(PerlIO_printf(Perl_debug_log, 2096 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n", 2097 PTR2UV(sv), 2098 SvNVX(sv), 2099 SvIVX(sv))); 2100 2101 } else { 2102 /* IV not precise. No need to convert from PV, as NV 2103 conversion would already have cached IV if it detected 2104 that PV->IV would be better than PV->NV->IV 2105 flags already correct - don't set public IOK. */ 2106 DEBUG_c(PerlIO_printf(Perl_debug_log, 2107 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n", 2108 PTR2UV(sv), 2109 SvNVX(sv), 2110 SvIVX(sv))); 2111 } 2112 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN, 2113 but the cast (NV)IV_MIN rounds to a the value less (more 2114 negative) than IV_MIN which happens to be equal to SvNVX ?? 2115 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and 2116 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and 2117 (NV)UVX == NVX are both true, but the values differ. :-( 2118 Hopefully for 2s complement IV_MIN is something like 2119 0x8000000000000000 which will be exact. NWC */ 2120 } 2121 else { 2122 SvUV_set(sv, U_V(SvNVX(sv))); 2123 if ( 2124 (SvNVX(sv) == (NV) SvUVX(sv)) 2125 #ifndef NV_PRESERVES_UV 2126 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */ 2127 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */ 2128 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv)) 2129 /* Don't flag it as "accurately an integer" if the number 2130 came from a (by definition imprecise) NV operation, and 2131 we're outside the range of NV integer precision */ 2132 #endif 2133 && SvNOK(sv) 2134 ) 2135 SvIOK_on(sv); 2136 SvIsUV_on(sv); 2137 DEBUG_c(PerlIO_printf(Perl_debug_log, 2138 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n", 2139 PTR2UV(sv), 2140 SvUVX(sv), 2141 SvUVX(sv))); 2142 } 2143 } 2144 else if (SvPOKp(sv)) { 2145 UV value; 2146 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); 2147 /* We want to avoid a possible problem when we cache an IV/ a UV which 2148 may be later translated to an NV, and the resulting NV is not 2149 the same as the direct translation of the initial string 2150 (eg 123.456 can shortcut to the IV 123 with atol(), but we must 2151 be careful to ensure that the value with the .456 is around if the 2152 NV value is requested in the future). 2153 2154 This means that if we cache such an IV/a UV, we need to cache the 2155 NV as well. Moreover, we trade speed for space, and do not 2156 cache the NV if we are sure it's not needed. 2157 */ 2158 2159 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */ 2160 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) 2161 == IS_NUMBER_IN_UV) { 2162 /* It's definitely an integer, only upgrade to PVIV */ 2163 if (SvTYPE(sv) < SVt_PVIV) 2164 sv_upgrade(sv, SVt_PVIV); 2165 (void)SvIOK_on(sv); 2166 } else if (SvTYPE(sv) < SVt_PVNV) 2167 sv_upgrade(sv, SVt_PVNV); 2168 2169 /* If NVs preserve UVs then we only use the UV value if we know that 2170 we aren't going to call atof() below. If NVs don't preserve UVs 2171 then the value returned may have more precision than atof() will 2172 return, even though value isn't perfectly accurate. */ 2173 if ((numtype & (IS_NUMBER_IN_UV 2174 #ifdef NV_PRESERVES_UV 2175 | IS_NUMBER_NOT_INT 2176 #endif 2177 )) == IS_NUMBER_IN_UV) { 2178 /* This won't turn off the public IOK flag if it was set above */ 2179 (void)SvIOKp_on(sv); 2180 2181 if (!(numtype & IS_NUMBER_NEG)) { 2182 /* positive */; 2183 if (value <= (UV)IV_MAX) { 2184 SvIV_set(sv, (IV)value); 2185 } else { 2186 /* it didn't overflow, and it was positive. */ 2187 SvUV_set(sv, value); 2188 SvIsUV_on(sv); 2189 } 2190 } else { 2191 /* 2s complement assumption */ 2192 if (value <= (UV)IV_MIN) { 2193 SvIV_set(sv, -(IV)value); 2194 } else { 2195 /* Too negative for an IV. This is a double upgrade, but 2196 I'm assuming it will be rare. */ 2197 if (SvTYPE(sv) < SVt_PVNV) 2198 sv_upgrade(sv, SVt_PVNV); 2199 SvNOK_on(sv); 2200 SvIOK_off(sv); 2201 SvIOKp_on(sv); 2202 SvNV_set(sv, -(NV)value); 2203 SvIV_set(sv, IV_MIN); 2204 } 2205 } 2206 } 2207 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we 2208 will be in the previous block to set the IV slot, and the next 2209 block to set the NV slot. So no else here. */ 2210 2211 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) 2212 != IS_NUMBER_IN_UV) { 2213 /* It wasn't an (integer that doesn't overflow the UV). */ 2214 SvNV_set(sv, Atof(SvPVX_const(sv))); 2215 2216 if (! numtype && ckWARN(WARN_NUMERIC)) 2217 not_a_number(sv); 2218 2219 #if defined(USE_LONG_DOUBLE) 2220 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n", 2221 PTR2UV(sv), SvNVX(sv))); 2222 #else 2223 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n", 2224 PTR2UV(sv), SvNVX(sv))); 2225 #endif 2226 2227 #ifdef NV_PRESERVES_UV 2228 (void)SvIOKp_on(sv); 2229 (void)SvNOK_on(sv); 2230 if (SvNVX(sv) < (NV)IV_MAX + 0.5) { 2231 SvIV_set(sv, I_V(SvNVX(sv))); 2232 if ((NV)(SvIVX(sv)) == SvNVX(sv)) { 2233 SvIOK_on(sv); 2234 } else { 2235 NOOP; /* Integer is imprecise. NOK, IOKp */ 2236 } 2237 /* UV will not work better than IV */ 2238 } else { 2239 if (SvNVX(sv) > (NV)UV_MAX) { 2240 SvIsUV_on(sv); 2241 /* Integer is inaccurate. NOK, IOKp, is UV */ 2242 SvUV_set(sv, UV_MAX); 2243 } else { 2244 SvUV_set(sv, U_V(SvNVX(sv))); 2245 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs 2246 NV preservse UV so can do correct comparison. */ 2247 if ((NV)(SvUVX(sv)) == SvNVX(sv)) { 2248 SvIOK_on(sv); 2249 } else { 2250 NOOP; /* Integer is imprecise. NOK, IOKp, is UV */ 2251 } 2252 } 2253 SvIsUV_on(sv); 2254 } 2255 #else /* NV_PRESERVES_UV */ 2256 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) 2257 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) { 2258 /* The IV/UV slot will have been set from value returned by 2259 grok_number above. The NV slot has just been set using 2260 Atof. */ 2261 SvNOK_on(sv); 2262 assert (SvIOKp(sv)); 2263 } else { 2264 if (((UV)1 << NV_PRESERVES_UV_BITS) > 2265 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) { 2266 /* Small enough to preserve all bits. */ 2267 (void)SvIOKp_on(sv); 2268 SvNOK_on(sv); 2269 SvIV_set(sv, I_V(SvNVX(sv))); 2270 if ((NV)(SvIVX(sv)) == SvNVX(sv)) 2271 SvIOK_on(sv); 2272 /* Assumption: first non-preserved integer is < IV_MAX, 2273 this NV is in the preserved range, therefore: */ 2274 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)) 2275 < (UV)IV_MAX)) { 2276 Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs((double)SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX); 2277 } 2278 } else { 2279 /* IN_UV NOT_INT 2280 0 0 already failed to read UV. 2281 0 1 already failed to read UV. 2282 1 0 you won't get here in this case. IV/UV 2283 slot set, public IOK, Atof() unneeded. 2284 1 1 already read UV. 2285 so there's no point in sv_2iuv_non_preserve() attempting 2286 to use atol, strtol, strtoul etc. */ 2287 # ifdef DEBUGGING 2288 sv_2iuv_non_preserve (sv, numtype); 2289 # else 2290 sv_2iuv_non_preserve (sv); 2291 # endif 2292 } 2293 } 2294 #endif /* NV_PRESERVES_UV */ 2295 /* It might be more code efficient to go through the entire logic above 2296 and conditionally set with SvIOKp_on() rather than SvIOK(), but it 2297 gets complex and potentially buggy, so more programmer efficient 2298 to do it this way, by turning off the public flags: */ 2299 if (!numtype) 2300 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK); 2301 } 2302 } 2303 else { 2304 if (isGV_with_GP(sv)) 2305 return glob_2number(MUTABLE_GV(sv)); 2306 2307 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) 2308 report_uninit(sv); 2309 if (SvTYPE(sv) < SVt_IV) 2310 /* Typically the caller expects that sv_any is not NULL now. */ 2311 sv_upgrade(sv, SVt_IV); 2312 /* Return 0 from the caller. */ 2313 return TRUE; 2314 } 2315 return FALSE; 2316 } 2317 2318 /* 2319 =for apidoc sv_2iv_flags 2320 2321 Return the integer value of an SV, doing any necessary string 2322 conversion. If flags includes SV_GMAGIC, does an mg_get() first. 2323 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros. 2324 2325 =cut 2326 */ 2327 2328 IV 2329 Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags) 2330 { 2331 dVAR; 2332 2333 PERL_ARGS_ASSERT_SV_2IV_FLAGS; 2334 2335 assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV 2336 && SvTYPE(sv) != SVt_PVFM); 2337 2338 if (SvGMAGICAL(sv) && (flags & SV_GMAGIC)) 2339 mg_get(sv); 2340 2341 if (SvROK(sv)) { 2342 if (SvAMAGIC(sv)) { 2343 SV * tmpstr; 2344 if (flags & SV_SKIP_OVERLOAD) 2345 return 0; 2346 tmpstr = AMG_CALLunary(sv, numer_amg); 2347 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { 2348 return SvIV(tmpstr); 2349 } 2350 } 2351 return PTR2IV(SvRV(sv)); 2352 } 2353 2354 if (SvVALID(sv) || isREGEXP(sv)) { 2355 /* FBMs use the space for SvIVX and SvNVX for other purposes, and use 2356 the same flag bit as SVf_IVisUV, so must not let them cache IVs. 2357 In practice they are extremely unlikely to actually get anywhere 2358 accessible by user Perl code - the only way that I'm aware of is when 2359 a constant subroutine which is used as the second argument to index. 2360 2361 Regexps have no SvIVX and SvNVX fields. 2362 */ 2363 assert(isREGEXP(sv) || SvPOKp(sv)); 2364 { 2365 UV value; 2366 const char * const ptr = 2367 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv); 2368 const int numtype 2369 = grok_number(ptr, SvCUR(sv), &value); 2370 2371 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) 2372 == IS_NUMBER_IN_UV) { 2373 /* It's definitely an integer */ 2374 if (numtype & IS_NUMBER_NEG) { 2375 if (value < (UV)IV_MIN) 2376 return -(IV)value; 2377 } else { 2378 if (value < (UV)IV_MAX) 2379 return (IV)value; 2380 } 2381 } 2382 if (!numtype) { 2383 if (ckWARN(WARN_NUMERIC)) 2384 not_a_number(sv); 2385 } 2386 return I_V(Atof(ptr)); 2387 } 2388 } 2389 2390 if (SvTHINKFIRST(sv)) { 2391 #ifdef PERL_OLD_COPY_ON_WRITE 2392 if (SvIsCOW(sv)) { 2393 sv_force_normal_flags(sv, 0); 2394 } 2395 #endif 2396 if (SvREADONLY(sv) && !SvOK(sv)) { 2397 if (ckWARN(WARN_UNINITIALIZED)) 2398 report_uninit(sv); 2399 return 0; 2400 } 2401 } 2402 2403 if (!SvIOKp(sv)) { 2404 if (S_sv_2iuv_common(aTHX_ sv)) 2405 return 0; 2406 } 2407 2408 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n", 2409 PTR2UV(sv),SvIVX(sv))); 2410 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv); 2411 } 2412 2413 /* 2414 =for apidoc sv_2uv_flags 2415 2416 Return the unsigned integer value of an SV, doing any necessary string 2417 conversion. If flags includes SV_GMAGIC, does an mg_get() first. 2418 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros. 2419 2420 =cut 2421 */ 2422 2423 UV 2424 Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags) 2425 { 2426 dVAR; 2427 2428 PERL_ARGS_ASSERT_SV_2UV_FLAGS; 2429 2430 if (SvGMAGICAL(sv) && (flags & SV_GMAGIC)) 2431 mg_get(sv); 2432 2433 if (SvROK(sv)) { 2434 if (SvAMAGIC(sv)) { 2435 SV *tmpstr; 2436 if (flags & SV_SKIP_OVERLOAD) 2437 return 0; 2438 tmpstr = AMG_CALLunary(sv, numer_amg); 2439 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { 2440 return SvUV(tmpstr); 2441 } 2442 } 2443 return PTR2UV(SvRV(sv)); 2444 } 2445 2446 if (SvVALID(sv) || isREGEXP(sv)) { 2447 /* FBMs use the space for SvIVX and SvNVX for other purposes, and use 2448 the same flag bit as SVf_IVisUV, so must not let them cache IVs. 2449 Regexps have no SvIVX and SvNVX fields. */ 2450 assert(isREGEXP(sv) || SvPOKp(sv)); 2451 { 2452 UV value; 2453 const char * const ptr = 2454 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv); 2455 const int numtype 2456 = grok_number(ptr, SvCUR(sv), &value); 2457 2458 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) 2459 == IS_NUMBER_IN_UV) { 2460 /* It's definitely an integer */ 2461 if (!(numtype & IS_NUMBER_NEG)) 2462 return value; 2463 } 2464 if (!numtype) { 2465 if (ckWARN(WARN_NUMERIC)) 2466 not_a_number(sv); 2467 } 2468 return U_V(Atof(ptr)); 2469 } 2470 } 2471 2472 if (SvTHINKFIRST(sv)) { 2473 #ifdef PERL_OLD_COPY_ON_WRITE 2474 if (SvIsCOW(sv)) { 2475 sv_force_normal_flags(sv, 0); 2476 } 2477 #endif 2478 if (SvREADONLY(sv) && !SvOK(sv)) { 2479 if (ckWARN(WARN_UNINITIALIZED)) 2480 report_uninit(sv); 2481 return 0; 2482 } 2483 } 2484 2485 if (!SvIOKp(sv)) { 2486 if (S_sv_2iuv_common(aTHX_ sv)) 2487 return 0; 2488 } 2489 2490 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n", 2491 PTR2UV(sv),SvUVX(sv))); 2492 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv); 2493 } 2494 2495 /* 2496 =for apidoc sv_2nv_flags 2497 2498 Return the num value of an SV, doing any necessary string or integer 2499 conversion. If flags includes SV_GMAGIC, does an mg_get() first. 2500 Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros. 2501 2502 =cut 2503 */ 2504 2505 NV 2506 Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags) 2507 { 2508 dVAR; 2509 2510 PERL_ARGS_ASSERT_SV_2NV_FLAGS; 2511 2512 assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV 2513 && SvTYPE(sv) != SVt_PVFM); 2514 if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(sv)) { 2515 /* FBMs use the space for SvIVX and SvNVX for other purposes, and use 2516 the same flag bit as SVf_IVisUV, so must not let them cache NVs. 2517 Regexps have no SvIVX and SvNVX fields. */ 2518 const char *ptr; 2519 if (flags & SV_GMAGIC) 2520 mg_get(sv); 2521 if (SvNOKp(sv)) 2522 return SvNVX(sv); 2523 if (SvPOKp(sv) && !SvIOKp(sv)) { 2524 ptr = SvPVX_const(sv); 2525 grokpv: 2526 if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) && 2527 !grok_number(ptr, SvCUR(sv), NULL)) 2528 not_a_number(sv); 2529 return Atof(ptr); 2530 } 2531 if (SvIOKp(sv)) { 2532 if (SvIsUV(sv)) 2533 return (NV)SvUVX(sv); 2534 else 2535 return (NV)SvIVX(sv); 2536 } 2537 if (SvROK(sv)) { 2538 goto return_rok; 2539 } 2540 if (isREGEXP(sv)) { 2541 ptr = RX_WRAPPED((REGEXP *)sv); 2542 goto grokpv; 2543 } 2544 assert(SvTYPE(sv) >= SVt_PVMG); 2545 /* This falls through to the report_uninit near the end of the 2546 function. */ 2547 } else if (SvTHINKFIRST(sv)) { 2548 if (SvROK(sv)) { 2549 return_rok: 2550 if (SvAMAGIC(sv)) { 2551 SV *tmpstr; 2552 if (flags & SV_SKIP_OVERLOAD) 2553 return 0; 2554 tmpstr = AMG_CALLunary(sv, numer_amg); 2555 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { 2556 return SvNV(tmpstr); 2557 } 2558 } 2559 return PTR2NV(SvRV(sv)); 2560 } 2561 #ifdef PERL_OLD_COPY_ON_WRITE 2562 if (SvIsCOW(sv)) { 2563 sv_force_normal_flags(sv, 0); 2564 } 2565 #endif 2566 if (SvREADONLY(sv) && !SvOK(sv)) { 2567 if (ckWARN(WARN_UNINITIALIZED)) 2568 report_uninit(sv); 2569 return 0.0; 2570 } 2571 } 2572 if (SvTYPE(sv) < SVt_NV) { 2573 /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */ 2574 sv_upgrade(sv, SVt_NV); 2575 #ifdef USE_LONG_DOUBLE 2576 DEBUG_c({ 2577 STORE_NUMERIC_LOCAL_SET_STANDARD(); 2578 PerlIO_printf(Perl_debug_log, 2579 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n", 2580 PTR2UV(sv), SvNVX(sv)); 2581 RESTORE_NUMERIC_LOCAL(); 2582 }); 2583 #else 2584 DEBUG_c({ 2585 STORE_NUMERIC_LOCAL_SET_STANDARD(); 2586 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n", 2587 PTR2UV(sv), SvNVX(sv)); 2588 RESTORE_NUMERIC_LOCAL(); 2589 }); 2590 #endif 2591 } 2592 else if (SvTYPE(sv) < SVt_PVNV) 2593 sv_upgrade(sv, SVt_PVNV); 2594 if (SvNOKp(sv)) { 2595 return SvNVX(sv); 2596 } 2597 if (SvIOKp(sv)) { 2598 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv)); 2599 #ifdef NV_PRESERVES_UV 2600 if (SvIOK(sv)) 2601 SvNOK_on(sv); 2602 else 2603 SvNOKp_on(sv); 2604 #else 2605 /* Only set the public NV OK flag if this NV preserves the IV */ 2606 /* Check it's not 0xFFFFFFFFFFFFFFFF */ 2607 if (SvIOK(sv) && 2608 SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv)))) 2609 : (SvIVX(sv) == I_V(SvNVX(sv)))) 2610 SvNOK_on(sv); 2611 else 2612 SvNOKp_on(sv); 2613 #endif 2614 } 2615 else if (SvPOKp(sv)) { 2616 UV value; 2617 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); 2618 if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC)) 2619 not_a_number(sv); 2620 #ifdef NV_PRESERVES_UV 2621 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) 2622 == IS_NUMBER_IN_UV) { 2623 /* It's definitely an integer */ 2624 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value); 2625 } else 2626 SvNV_set(sv, Atof(SvPVX_const(sv))); 2627 if (numtype) 2628 SvNOK_on(sv); 2629 else 2630 SvNOKp_on(sv); 2631 #else 2632 SvNV_set(sv, Atof(SvPVX_const(sv))); 2633 /* Only set the public NV OK flag if this NV preserves the value in 2634 the PV at least as well as an IV/UV would. 2635 Not sure how to do this 100% reliably. */ 2636 /* if that shift count is out of range then Configure's test is 2637 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS == 2638 UV_BITS */ 2639 if (((UV)1 << NV_PRESERVES_UV_BITS) > 2640 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) { 2641 SvNOK_on(sv); /* Definitely small enough to preserve all bits */ 2642 } else if (!(numtype & IS_NUMBER_IN_UV)) { 2643 /* Can't use strtol etc to convert this string, so don't try. 2644 sv_2iv and sv_2uv will use the NV to convert, not the PV. */ 2645 SvNOK_on(sv); 2646 } else { 2647 /* value has been set. It may not be precise. */ 2648 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) { 2649 /* 2s complement assumption for (UV)IV_MIN */ 2650 SvNOK_on(sv); /* Integer is too negative. */ 2651 } else { 2652 SvNOKp_on(sv); 2653 SvIOKp_on(sv); 2654 2655 if (numtype & IS_NUMBER_NEG) { 2656 SvIV_set(sv, -(IV)value); 2657 } else if (value <= (UV)IV_MAX) { 2658 SvIV_set(sv, (IV)value); 2659 } else { 2660 SvUV_set(sv, value); 2661 SvIsUV_on(sv); 2662 } 2663 2664 if (numtype & IS_NUMBER_NOT_INT) { 2665 /* I believe that even if the original PV had decimals, 2666 they are lost beyond the limit of the FP precision. 2667 However, neither is canonical, so both only get p 2668 flags. NWC, 2000/11/25 */ 2669 /* Both already have p flags, so do nothing */ 2670 } else { 2671 const NV nv = SvNVX(sv); 2672 if (SvNVX(sv) < (NV)IV_MAX + 0.5) { 2673 if (SvIVX(sv) == I_V(nv)) { 2674 SvNOK_on(sv); 2675 } else { 2676 /* It had no "." so it must be integer. */ 2677 } 2678 SvIOK_on(sv); 2679 } else { 2680 /* between IV_MAX and NV(UV_MAX). 2681 Could be slightly > UV_MAX */ 2682 2683 if (numtype & IS_NUMBER_NOT_INT) { 2684 /* UV and NV both imprecise. */ 2685 } else { 2686 const UV nv_as_uv = U_V(nv); 2687 2688 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) { 2689 SvNOK_on(sv); 2690 } 2691 SvIOK_on(sv); 2692 } 2693 } 2694 } 2695 } 2696 } 2697 /* It might be more code efficient to go through the entire logic above 2698 and conditionally set with SvNOKp_on() rather than SvNOK(), but it 2699 gets complex and potentially buggy, so more programmer efficient 2700 to do it this way, by turning off the public flags: */ 2701 if (!numtype) 2702 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK); 2703 #endif /* NV_PRESERVES_UV */ 2704 } 2705 else { 2706 if (isGV_with_GP(sv)) { 2707 glob_2number(MUTABLE_GV(sv)); 2708 return 0.0; 2709 } 2710 2711 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) 2712 report_uninit(sv); 2713 assert (SvTYPE(sv) >= SVt_NV); 2714 /* Typically the caller expects that sv_any is not NULL now. */ 2715 /* XXX Ilya implies that this is a bug in callers that assume this 2716 and ideally should be fixed. */ 2717 return 0.0; 2718 } 2719 #if defined(USE_LONG_DOUBLE) 2720 DEBUG_c({ 2721 STORE_NUMERIC_LOCAL_SET_STANDARD(); 2722 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n", 2723 PTR2UV(sv), SvNVX(sv)); 2724 RESTORE_NUMERIC_LOCAL(); 2725 }); 2726 #else 2727 DEBUG_c({ 2728 STORE_NUMERIC_LOCAL_SET_STANDARD(); 2729 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n", 2730 PTR2UV(sv), SvNVX(sv)); 2731 RESTORE_NUMERIC_LOCAL(); 2732 }); 2733 #endif 2734 return SvNVX(sv); 2735 } 2736 2737 /* 2738 =for apidoc sv_2num 2739 2740 Return an SV with the numeric value of the source SV, doing any necessary 2741 reference or overload conversion. You must use the C<SvNUM(sv)> macro to 2742 access this function. 2743 2744 =cut 2745 */ 2746 2747 SV * 2748 Perl_sv_2num(pTHX_ SV *const sv) 2749 { 2750 PERL_ARGS_ASSERT_SV_2NUM; 2751 2752 if (!SvROK(sv)) 2753 return sv; 2754 if (SvAMAGIC(sv)) { 2755 SV * const tmpsv = AMG_CALLunary(sv, numer_amg); 2756 TAINT_IF(tmpsv && SvTAINTED(tmpsv)); 2757 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) 2758 return sv_2num(tmpsv); 2759 } 2760 return sv_2mortal(newSVuv(PTR2UV(SvRV(sv)))); 2761 } 2762 2763 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or 2764 * UV as a string towards the end of buf, and return pointers to start and 2765 * end of it. 2766 * 2767 * We assume that buf is at least TYPE_CHARS(UV) long. 2768 */ 2769 2770 static char * 2771 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob) 2772 { 2773 char *ptr = buf + TYPE_CHARS(UV); 2774 char * const ebuf = ptr; 2775 int sign; 2776 2777 PERL_ARGS_ASSERT_UIV_2BUF; 2778 2779 if (is_uv) 2780 sign = 0; 2781 else if (iv >= 0) { 2782 uv = iv; 2783 sign = 0; 2784 } else { 2785 uv = -iv; 2786 sign = 1; 2787 } 2788 do { 2789 *--ptr = '0' + (char)(uv % 10); 2790 } while (uv /= 10); 2791 if (sign) 2792 *--ptr = '-'; 2793 *peob = ebuf; 2794 return ptr; 2795 } 2796 2797 /* 2798 =for apidoc sv_2pv_flags 2799 2800 Returns a pointer to the string value of an SV, and sets *lp to its length. 2801 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a 2802 string if necessary. Normally invoked via the C<SvPV_flags> macro. 2803 C<sv_2pv()> and C<sv_2pv_nomg> usually end up here too. 2804 2805 =cut 2806 */ 2807 2808 char * 2809 Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) 2810 { 2811 dVAR; 2812 char *s; 2813 2814 PERL_ARGS_ASSERT_SV_2PV_FLAGS; 2815 2816 assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV 2817 && SvTYPE(sv) != SVt_PVFM); 2818 if (SvGMAGICAL(sv) && (flags & SV_GMAGIC)) 2819 mg_get(sv); 2820 if (SvROK(sv)) { 2821 if (SvAMAGIC(sv)) { 2822 SV *tmpstr; 2823 if (flags & SV_SKIP_OVERLOAD) 2824 return NULL; 2825 tmpstr = AMG_CALLunary(sv, string_amg); 2826 TAINT_IF(tmpstr && SvTAINTED(tmpstr)); 2827 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { 2828 /* Unwrap this: */ 2829 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); 2830 */ 2831 2832 char *pv; 2833 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) { 2834 if (flags & SV_CONST_RETURN) { 2835 pv = (char *) SvPVX_const(tmpstr); 2836 } else { 2837 pv = (flags & SV_MUTABLE_RETURN) 2838 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr); 2839 } 2840 if (lp) 2841 *lp = SvCUR(tmpstr); 2842 } else { 2843 pv = sv_2pv_flags(tmpstr, lp, flags); 2844 } 2845 if (SvUTF8(tmpstr)) 2846 SvUTF8_on(sv); 2847 else 2848 SvUTF8_off(sv); 2849 return pv; 2850 } 2851 } 2852 { 2853 STRLEN len; 2854 char *retval; 2855 char *buffer; 2856 SV *const referent = SvRV(sv); 2857 2858 if (!referent) { 2859 len = 7; 2860 retval = buffer = savepvn("NULLREF", len); 2861 } else if (SvTYPE(referent) == SVt_REGEXP && 2862 (!(PL_curcop->cop_hints & HINT_NO_AMAGIC) || 2863 amagic_is_enabled(string_amg))) { 2864 REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent); 2865 2866 assert(re); 2867 2868 /* If the regex is UTF-8 we want the containing scalar to 2869 have an UTF-8 flag too */ 2870 if (RX_UTF8(re)) 2871 SvUTF8_on(sv); 2872 else 2873 SvUTF8_off(sv); 2874 2875 if (lp) 2876 *lp = RX_WRAPLEN(re); 2877 2878 return RX_WRAPPED(re); 2879 } else { 2880 const char *const typestr = sv_reftype(referent, 0); 2881 const STRLEN typelen = strlen(typestr); 2882 UV addr = PTR2UV(referent); 2883 const char *stashname = NULL; 2884 STRLEN stashnamelen = 0; /* hush, gcc */ 2885 const char *buffer_end; 2886 2887 if (SvOBJECT(referent)) { 2888 const HEK *const name = HvNAME_HEK(SvSTASH(referent)); 2889 2890 if (name) { 2891 stashname = HEK_KEY(name); 2892 stashnamelen = HEK_LEN(name); 2893 2894 if (HEK_UTF8(name)) { 2895 SvUTF8_on(sv); 2896 } else { 2897 SvUTF8_off(sv); 2898 } 2899 } else { 2900 stashname = "__ANON__"; 2901 stashnamelen = 8; 2902 } 2903 len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */ 2904 + 2 * sizeof(UV) + 2 /* )\0 */; 2905 } else { 2906 len = typelen + 3 /* (0x */ 2907 + 2 * sizeof(UV) + 2 /* )\0 */; 2908 } 2909 2910 Newx(buffer, len, char); 2911 buffer_end = retval = buffer + len; 2912 2913 /* Working backwards */ 2914 *--retval = '\0'; 2915 *--retval = ')'; 2916 do { 2917 *--retval = PL_hexdigit[addr & 15]; 2918 } while (addr >>= 4); 2919 *--retval = 'x'; 2920 *--retval = '0'; 2921 *--retval = '('; 2922 2923 retval -= typelen; 2924 memcpy(retval, typestr, typelen); 2925 2926 if (stashname) { 2927 *--retval = '='; 2928 retval -= stashnamelen; 2929 memcpy(retval, stashname, stashnamelen); 2930 } 2931 /* retval may not necessarily have reached the start of the 2932 buffer here. */ 2933 assert (retval >= buffer); 2934 2935 len = buffer_end - retval - 1; /* -1 for that \0 */ 2936 } 2937 if (lp) 2938 *lp = len; 2939 SAVEFREEPV(buffer); 2940 return retval; 2941 } 2942 } 2943 2944 if (SvPOKp(sv)) { 2945 if (lp) 2946 *lp = SvCUR(sv); 2947 if (flags & SV_MUTABLE_RETURN) 2948 return SvPVX_mutable(sv); 2949 if (flags & SV_CONST_RETURN) 2950 return (char *)SvPVX_const(sv); 2951 return SvPVX(sv); 2952 } 2953 2954 if (SvIOK(sv)) { 2955 /* I'm assuming that if both IV and NV are equally valid then 2956 converting the IV is going to be more efficient */ 2957 const U32 isUIOK = SvIsUV(sv); 2958 char buf[TYPE_CHARS(UV)]; 2959 char *ebuf, *ptr; 2960 STRLEN len; 2961 2962 if (SvTYPE(sv) < SVt_PVIV) 2963 sv_upgrade(sv, SVt_PVIV); 2964 ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf); 2965 len = ebuf - ptr; 2966 /* inlined from sv_setpvn */ 2967 s = SvGROW_mutable(sv, len + 1); 2968 Move(ptr, s, len, char); 2969 s += len; 2970 *s = '\0'; 2971 SvPOK_on(sv); 2972 } 2973 else if (SvNOK(sv)) { 2974 if (SvTYPE(sv) < SVt_PVNV) 2975 sv_upgrade(sv, SVt_PVNV); 2976 if (SvNVX(sv) == 0.0) { 2977 s = SvGROW_mutable(sv, 2); 2978 *s++ = '0'; 2979 *s = '\0'; 2980 } else { 2981 dSAVE_ERRNO; 2982 /* The +20 is pure guesswork. Configure test needed. --jhi */ 2983 s = SvGROW_mutable(sv, NV_DIG + 20); 2984 /* some Xenix systems wipe out errno here */ 2985 2986 #ifndef USE_LOCALE_NUMERIC 2987 PERL_UNUSED_RESULT(Gconvert(SvNVX(sv), NV_DIG, 0, s)); 2988 SvPOK_on(sv); 2989 #else 2990 { 2991 DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED(); 2992 PERL_UNUSED_RESULT(Gconvert(SvNVX(sv), NV_DIG, 0, s)); 2993 2994 /* If the radix character is UTF-8, and actually is in the 2995 * output, turn on the UTF-8 flag for the scalar */ 2996 if (PL_numeric_local 2997 && PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv) 2998 && instr(s, SvPVX_const(PL_numeric_radix_sv))) 2999 { 3000 SvUTF8_on(sv); 3001 } 3002 RESTORE_LC_NUMERIC(); 3003 } 3004 3005 /* We don't call SvPOK_on(), because it may come to pass that the 3006 * locale changes so that the stringification we just did is no 3007 * longer correct. We will have to re-stringify every time it is 3008 * needed */ 3009 #endif 3010 RESTORE_ERRNO; 3011 while (*s) s++; 3012 } 3013 } 3014 else if (isGV_with_GP(sv)) { 3015 GV *const gv = MUTABLE_GV(sv); 3016 SV *const buffer = sv_newmortal(); 3017 3018 gv_efullname3(buffer, gv, "*"); 3019 3020 assert(SvPOK(buffer)); 3021 if (SvUTF8(buffer)) 3022 SvUTF8_on(sv); 3023 if (lp) 3024 *lp = SvCUR(buffer); 3025 return SvPVX(buffer); 3026 } 3027 else if (isREGEXP(sv)) { 3028 if (lp) *lp = RX_WRAPLEN((REGEXP *)sv); 3029 return RX_WRAPPED((REGEXP *)sv); 3030 } 3031 else { 3032 if (lp) 3033 *lp = 0; 3034 if (flags & SV_UNDEF_RETURNS_NULL) 3035 return NULL; 3036 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) 3037 report_uninit(sv); 3038 /* Typically the caller expects that sv_any is not NULL now. */ 3039 if (!SvREADONLY(sv) && SvTYPE(sv) < SVt_PV) 3040 sv_upgrade(sv, SVt_PV); 3041 return (char *)""; 3042 } 3043 3044 { 3045 const STRLEN len = s - SvPVX_const(sv); 3046 if (lp) 3047 *lp = len; 3048 SvCUR_set(sv, len); 3049 } 3050 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n", 3051 PTR2UV(sv),SvPVX_const(sv))); 3052 if (flags & SV_CONST_RETURN) 3053 return (char *)SvPVX_const(sv); 3054 if (flags & SV_MUTABLE_RETURN) 3055 return SvPVX_mutable(sv); 3056 return SvPVX(sv); 3057 } 3058 3059 /* 3060 =for apidoc sv_copypv 3061 3062 Copies a stringified representation of the source SV into the 3063 destination SV. Automatically performs any necessary mg_get and 3064 coercion of numeric values into strings. Guaranteed to preserve 3065 UTF8 flag even from overloaded objects. Similar in nature to 3066 sv_2pv[_flags] but operates directly on an SV instead of just the 3067 string. Mostly uses sv_2pv_flags to do its work, except when that 3068 would lose the UTF-8'ness of the PV. 3069 3070 =for apidoc sv_copypv_nomg 3071 3072 Like sv_copypv, but doesn't invoke get magic first. 3073 3074 =for apidoc sv_copypv_flags 3075 3076 Implementation of sv_copypv and sv_copypv_nomg. Calls get magic iff flags 3077 include SV_GMAGIC. 3078 3079 =cut 3080 */ 3081 3082 void 3083 Perl_sv_copypv(pTHX_ SV *const dsv, SV *const ssv) 3084 { 3085 PERL_ARGS_ASSERT_SV_COPYPV; 3086 3087 sv_copypv_flags(dsv, ssv, 0); 3088 } 3089 3090 void 3091 Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags) 3092 { 3093 STRLEN len; 3094 const char *s; 3095 3096 PERL_ARGS_ASSERT_SV_COPYPV_FLAGS; 3097 3098 if ((flags & SV_GMAGIC) && SvGMAGICAL(ssv)) 3099 mg_get(ssv); 3100 s = SvPV_nomg_const(ssv,len); 3101 sv_setpvn(dsv,s,len); 3102 if (SvUTF8(ssv)) 3103 SvUTF8_on(dsv); 3104 else 3105 SvUTF8_off(dsv); 3106 } 3107 3108 /* 3109 =for apidoc sv_2pvbyte 3110 3111 Return a pointer to the byte-encoded representation of the SV, and set *lp 3112 to its length. May cause the SV to be downgraded from UTF-8 as a 3113 side-effect. 3114 3115 Usually accessed via the C<SvPVbyte> macro. 3116 3117 =cut 3118 */ 3119 3120 char * 3121 Perl_sv_2pvbyte(pTHX_ SV *sv, STRLEN *const lp) 3122 { 3123 PERL_ARGS_ASSERT_SV_2PVBYTE; 3124 3125 SvGETMAGIC(sv); 3126 if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv)) 3127 || isGV_with_GP(sv) || SvROK(sv)) { 3128 SV *sv2 = sv_newmortal(); 3129 sv_copypv_nomg(sv2,sv); 3130 sv = sv2; 3131 } 3132 sv_utf8_downgrade(sv,0); 3133 return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv); 3134 } 3135 3136 /* 3137 =for apidoc sv_2pvutf8 3138 3139 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp 3140 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect. 3141 3142 Usually accessed via the C<SvPVutf8> macro. 3143 3144 =cut 3145 */ 3146 3147 char * 3148 Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp) 3149 { 3150 PERL_ARGS_ASSERT_SV_2PVUTF8; 3151 3152 if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv)) 3153 || isGV_with_GP(sv) || SvROK(sv)) 3154 sv = sv_mortalcopy(sv); 3155 else 3156 SvGETMAGIC(sv); 3157 sv_utf8_upgrade_nomg(sv); 3158 return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv); 3159 } 3160 3161 3162 /* 3163 =for apidoc sv_2bool 3164 3165 This macro is only used by sv_true() or its macro equivalent, and only if 3166 the latter's argument is neither SvPOK, SvIOK nor SvNOK. 3167 It calls sv_2bool_flags with the SV_GMAGIC flag. 3168 3169 =for apidoc sv_2bool_flags 3170 3171 This function is only used by sv_true() and friends, and only if 3172 the latter's argument is neither SvPOK, SvIOK nor SvNOK. If the flags 3173 contain SV_GMAGIC, then it does an mg_get() first. 3174 3175 3176 =cut 3177 */ 3178 3179 bool 3180 Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags) 3181 { 3182 dVAR; 3183 3184 PERL_ARGS_ASSERT_SV_2BOOL_FLAGS; 3185 3186 restart: 3187 if(flags & SV_GMAGIC) SvGETMAGIC(sv); 3188 3189 if (!SvOK(sv)) 3190 return 0; 3191 if (SvROK(sv)) { 3192 if (SvAMAGIC(sv)) { 3193 SV * const tmpsv = AMG_CALLunary(sv, bool__amg); 3194 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) { 3195 bool svb; 3196 sv = tmpsv; 3197 if(SvGMAGICAL(sv)) { 3198 flags = SV_GMAGIC; 3199 goto restart; /* call sv_2bool */ 3200 } 3201 /* expanded SvTRUE_common(sv, (flags = 0, goto restart)) */ 3202 else if(!SvOK(sv)) { 3203 svb = 0; 3204 } 3205 else if(SvPOK(sv)) { 3206 svb = SvPVXtrue(sv); 3207 } 3208 else if((SvFLAGS(sv) & (SVf_IOK|SVf_NOK))) { 3209 svb = (SvIOK(sv) && SvIVX(sv) != 0) 3210 || (SvNOK(sv) && SvNVX(sv) != 0.0); 3211 } 3212 else { 3213 flags = 0; 3214 goto restart; /* call sv_2bool_nomg */ 3215 } 3216 return cBOOL(svb); 3217 } 3218 } 3219 return SvRV(sv) != 0; 3220 } 3221 if (isREGEXP(sv)) 3222 return 3223 RX_WRAPLEN(sv) > 1 || (RX_WRAPLEN(sv) && *RX_WRAPPED(sv) != '0'); 3224 return SvTRUE_common(sv, isGV_with_GP(sv) ? 1 : 0); 3225 } 3226 3227 /* 3228 =for apidoc sv_utf8_upgrade 3229 3230 Converts the PV of an SV to its UTF-8-encoded form. 3231 Forces the SV to string form if it is not already. 3232 Will C<mg_get> on C<sv> if appropriate. 3233 Always sets the SvUTF8 flag to avoid future validity checks even 3234 if the whole string is the same in UTF-8 as not. 3235 Returns the number of bytes in the converted string 3236 3237 This is not a general purpose byte encoding to Unicode interface: 3238 use the Encode extension for that. 3239 3240 =for apidoc sv_utf8_upgrade_nomg 3241 3242 Like sv_utf8_upgrade, but doesn't do magic on C<sv>. 3243 3244 =for apidoc sv_utf8_upgrade_flags 3245 3246 Converts the PV of an SV to its UTF-8-encoded form. 3247 Forces the SV to string form if it is not already. 3248 Always sets the SvUTF8 flag to avoid future validity checks even 3249 if all the bytes are invariant in UTF-8. 3250 If C<flags> has C<SV_GMAGIC> bit set, 3251 will C<mg_get> on C<sv> if appropriate, else not. 3252 3253 If C<flags> has SV_FORCE_UTF8_UPGRADE set, this function assumes that the PV 3254 will expand when converted to UTF-8, and skips the extra work of checking for 3255 that. Typically this flag is used by a routine that has already parsed the 3256 string and found such characters, and passes this information on so that the 3257 work doesn't have to be repeated. 3258 3259 Returns the number of bytes in the converted string. 3260 3261 This is not a general purpose byte encoding to Unicode interface: 3262 use the Encode extension for that. 3263 3264 =for apidoc sv_utf8_upgrade_flags_grow 3265 3266 Like sv_utf8_upgrade_flags, but has an additional parameter C<extra>, which is 3267 the number of unused bytes the string of 'sv' is guaranteed to have free after 3268 it upon return. This allows the caller to reserve extra space that it intends 3269 to fill, to avoid extra grows. 3270 3271 C<sv_utf8_upgrade>, C<sv_utf8_upgrade_nomg>, and C<sv_utf8_upgrade_flags> 3272 are implemented in terms of this function. 3273 3274 Returns the number of bytes in the converted string (not including the spares). 3275 3276 =cut 3277 3278 (One might think that the calling routine could pass in the position of the 3279 first variant character when it has set SV_FORCE_UTF8_UPGRADE, so it wouldn't 3280 have to be found again. But that is not the case, because typically when the 3281 caller is likely to use this flag, it won't be calling this routine unless it 3282 finds something that won't fit into a byte. Otherwise it tries to not upgrade 3283 and just use bytes. But some things that do fit into a byte are variants in 3284 utf8, and the caller may not have been keeping track of these.) 3285 3286 If the routine itself changes the string, it adds a trailing C<NUL>. Such a 3287 C<NUL> isn't guaranteed due to having other routines do the work in some input 3288 cases, or if the input is already flagged as being in utf8. 3289 3290 The speed of this could perhaps be improved for many cases if someone wanted to 3291 write a fast function that counts the number of variant characters in a string, 3292 especially if it could return the position of the first one. 3293 3294 */ 3295 3296 STRLEN 3297 Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra) 3298 { 3299 dVAR; 3300 3301 PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW; 3302 3303 if (sv == &PL_sv_undef) 3304 return 0; 3305 if (!SvPOK_nog(sv)) { 3306 STRLEN len = 0; 3307 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) { 3308 (void) sv_2pv_flags(sv,&len, flags); 3309 if (SvUTF8(sv)) { 3310 if (extra) SvGROW(sv, SvCUR(sv) + extra); 3311 return len; 3312 } 3313 } else { 3314 (void) SvPV_force_flags(sv,len,flags & SV_GMAGIC); 3315 } 3316 } 3317 3318 if (SvUTF8(sv)) { 3319 if (extra) SvGROW(sv, SvCUR(sv) + extra); 3320 return SvCUR(sv); 3321 } 3322 3323 if (SvIsCOW(sv)) { 3324 S_sv_uncow(aTHX_ sv, 0); 3325 } 3326 3327 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) { 3328 sv_recode_to_utf8(sv, PL_encoding); 3329 if (extra) SvGROW(sv, SvCUR(sv) + extra); 3330 return SvCUR(sv); 3331 } 3332 3333 if (SvCUR(sv) == 0) { 3334 if (extra) SvGROW(sv, extra); 3335 } else { /* Assume Latin-1/EBCDIC */ 3336 /* This function could be much more efficient if we 3337 * had a FLAG in SVs to signal if there are any variant 3338 * chars in the PV. Given that there isn't such a flag 3339 * make the loop as fast as possible (although there are certainly ways 3340 * to speed this up, eg. through vectorization) */ 3341 U8 * s = (U8 *) SvPVX_const(sv); 3342 U8 * e = (U8 *) SvEND(sv); 3343 U8 *t = s; 3344 STRLEN two_byte_count = 0; 3345 3346 if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8; 3347 3348 /* See if really will need to convert to utf8. We mustn't rely on our 3349 * incoming SV being well formed and having a trailing '\0', as certain 3350 * code in pp_formline can send us partially built SVs. */ 3351 3352 while (t < e) { 3353 const U8 ch = *t++; 3354 if (NATIVE_BYTE_IS_INVARIANT(ch)) continue; 3355 3356 t--; /* t already incremented; re-point to first variant */ 3357 two_byte_count = 1; 3358 goto must_be_utf8; 3359 } 3360 3361 /* utf8 conversion not needed because all are invariants. Mark as 3362 * UTF-8 even if no variant - saves scanning loop */ 3363 SvUTF8_on(sv); 3364 if (extra) SvGROW(sv, SvCUR(sv) + extra); 3365 return SvCUR(sv); 3366 3367 must_be_utf8: 3368 3369 /* Here, the string should be converted to utf8, either because of an 3370 * input flag (two_byte_count = 0), or because a character that 3371 * requires 2 bytes was found (two_byte_count = 1). t points either to 3372 * the beginning of the string (if we didn't examine anything), or to 3373 * the first variant. In either case, everything from s to t - 1 will 3374 * occupy only 1 byte each on output. 3375 * 3376 * There are two main ways to convert. One is to create a new string 3377 * and go through the input starting from the beginning, appending each 3378 * converted value onto the new string as we go along. It's probably 3379 * best to allocate enough space in the string for the worst possible 3380 * case rather than possibly running out of space and having to 3381 * reallocate and then copy what we've done so far. Since everything 3382 * from s to t - 1 is invariant, the destination can be initialized 3383 * with these using a fast memory copy 3384 * 3385 * The other way is to figure out exactly how big the string should be 3386 * by parsing the entire input. Then you don't have to make it big 3387 * enough to handle the worst possible case, and more importantly, if 3388 * the string you already have is large enough, you don't have to 3389 * allocate a new string, you can copy the last character in the input 3390 * string to the final position(s) that will be occupied by the 3391 * converted string and go backwards, stopping at t, since everything 3392 * before that is invariant. 3393 * 3394 * There are advantages and disadvantages to each method. 3395 * 3396 * In the first method, we can allocate a new string, do the memory 3397 * copy from the s to t - 1, and then proceed through the rest of the 3398 * string byte-by-byte. 3399 * 3400 * In the second method, we proceed through the rest of the input 3401 * string just calculating how big the converted string will be. Then 3402 * there are two cases: 3403 * 1) if the string has enough extra space to handle the converted 3404 * value. We go backwards through the string, converting until we 3405 * get to the position we are at now, and then stop. If this 3406 * position is far enough along in the string, this method is 3407 * faster than the other method. If the memory copy were the same 3408 * speed as the byte-by-byte loop, that position would be about 3409 * half-way, as at the half-way mark, parsing to the end and back 3410 * is one complete string's parse, the same amount as starting 3411 * over and going all the way through. Actually, it would be 3412 * somewhat less than half-way, as it's faster to just count bytes 3413 * than to also copy, and we don't have the overhead of allocating 3414 * a new string, changing the scalar to use it, and freeing the 3415 * existing one. But if the memory copy is fast, the break-even 3416 * point is somewhere after half way. The counting loop could be 3417 * sped up by vectorization, etc, to move the break-even point 3418 * further towards the beginning. 3419 * 2) if the string doesn't have enough space to handle the converted 3420 * value. A new string will have to be allocated, and one might 3421 * as well, given that, start from the beginning doing the first 3422 * method. We've spent extra time parsing the string and in 3423 * exchange all we've gotten is that we know precisely how big to 3424 * make the new one. Perl is more optimized for time than space, 3425 * so this case is a loser. 3426 * So what I've decided to do is not use the 2nd method unless it is 3427 * guaranteed that a new string won't have to be allocated, assuming 3428 * the worst case. I also decided not to put any more conditions on it 3429 * than this, for now. It seems likely that, since the worst case is 3430 * twice as big as the unknown portion of the string (plus 1), we won't 3431 * be guaranteed enough space, causing us to go to the first method, 3432 * unless the string is short, or the first variant character is near 3433 * the end of it. In either of these cases, it seems best to use the 3434 * 2nd method. The only circumstance I can think of where this would 3435 * be really slower is if the string had once had much more data in it 3436 * than it does now, but there is still a substantial amount in it */ 3437 3438 { 3439 STRLEN invariant_head = t - s; 3440 STRLEN size = invariant_head + (e - t) * 2 + 1 + extra; 3441 if (SvLEN(sv) < size) { 3442 3443 /* Here, have decided to allocate a new string */ 3444 3445 U8 *dst; 3446 U8 *d; 3447 3448 Newx(dst, size, U8); 3449 3450 /* If no known invariants at the beginning of the input string, 3451 * set so starts from there. Otherwise, can use memory copy to 3452 * get up to where we are now, and then start from here */ 3453 3454 if (invariant_head == 0) { 3455 d = dst; 3456 } else { 3457 Copy(s, dst, invariant_head, char); 3458 d = dst + invariant_head; 3459 } 3460 3461 while (t < e) { 3462 append_utf8_from_native_byte(*t, &d); 3463 t++; 3464 } 3465 *d = '\0'; 3466 SvPV_free(sv); /* No longer using pre-existing string */ 3467 SvPV_set(sv, (char*)dst); 3468 SvCUR_set(sv, d - dst); 3469 SvLEN_set(sv, size); 3470 } else { 3471 3472 /* Here, have decided to get the exact size of the string. 3473 * Currently this happens only when we know that there is 3474 * guaranteed enough space to fit the converted string, so 3475 * don't have to worry about growing. If two_byte_count is 0, 3476 * then t points to the first byte of the string which hasn't 3477 * been examined yet. Otherwise two_byte_count is 1, and t 3478 * points to the first byte in the string that will expand to 3479 * two. Depending on this, start examining at t or 1 after t. 3480 * */ 3481 3482 U8 *d = t + two_byte_count; 3483 3484 3485 /* Count up the remaining bytes that expand to two */ 3486 3487 while (d < e) { 3488 const U8 chr = *d++; 3489 if (! NATIVE_BYTE_IS_INVARIANT(chr)) two_byte_count++; 3490 } 3491 3492 /* The string will expand by just the number of bytes that 3493 * occupy two positions. But we are one afterwards because of 3494 * the increment just above. This is the place to put the 3495 * trailing NUL, and to set the length before we decrement */ 3496 3497 d += two_byte_count; 3498 SvCUR_set(sv, d - s); 3499 *d-- = '\0'; 3500 3501 3502 /* Having decremented d, it points to the position to put the 3503 * very last byte of the expanded string. Go backwards through 3504 * the string, copying and expanding as we go, stopping when we 3505 * get to the part that is invariant the rest of the way down */ 3506 3507 e--; 3508 while (e >= t) { 3509 if (NATIVE_BYTE_IS_INVARIANT(*e)) { 3510 *d-- = *e; 3511 } else { 3512 *d-- = UTF8_EIGHT_BIT_LO(*e); 3513 *d-- = UTF8_EIGHT_BIT_HI(*e); 3514 } 3515 e--; 3516 } 3517 } 3518 3519 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { 3520 /* Update pos. We do it at the end rather than during 3521 * the upgrade, to avoid slowing down the common case 3522 * (upgrade without pos). 3523 * pos can be stored as either bytes or characters. Since 3524 * this was previously a byte string we can just turn off 3525 * the bytes flag. */ 3526 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global); 3527 if (mg) { 3528 mg->mg_flags &= ~MGf_BYTES; 3529 } 3530 if ((mg = mg_find(sv, PERL_MAGIC_utf8))) 3531 magic_setutf8(sv,mg); /* clear UTF8 cache */ 3532 } 3533 } 3534 } 3535 3536 /* Mark as UTF-8 even if no variant - saves scanning loop */ 3537 SvUTF8_on(sv); 3538 return SvCUR(sv); 3539 } 3540 3541 /* 3542 =for apidoc sv_utf8_downgrade 3543 3544 Attempts to convert the PV of an SV from characters to bytes. 3545 If the PV contains a character that cannot fit 3546 in a byte, this conversion will fail; 3547 in this case, either returns false or, if C<fail_ok> is not 3548 true, croaks. 3549 3550 This is not a general purpose Unicode to byte encoding interface: 3551 use the Encode extension for that. 3552 3553 =cut 3554 */ 3555 3556 bool 3557 Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok) 3558 { 3559 dVAR; 3560 3561 PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE; 3562 3563 if (SvPOKp(sv) && SvUTF8(sv)) { 3564 if (SvCUR(sv)) { 3565 U8 *s; 3566 STRLEN len; 3567 int mg_flags = SV_GMAGIC; 3568 3569 if (SvIsCOW(sv)) { 3570 S_sv_uncow(aTHX_ sv, 0); 3571 } 3572 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { 3573 /* update pos */ 3574 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global); 3575 if (mg && mg->mg_len > 0 && mg->mg_flags & MGf_BYTES) { 3576 mg->mg_len = sv_pos_b2u_flags(sv, mg->mg_len, 3577 SV_GMAGIC|SV_CONST_RETURN); 3578 mg_flags = 0; /* sv_pos_b2u does get magic */ 3579 } 3580 if ((mg = mg_find(sv, PERL_MAGIC_utf8))) 3581 magic_setutf8(sv,mg); /* clear UTF8 cache */ 3582 3583 } 3584 s = (U8 *) SvPV_flags(sv, len, mg_flags); 3585 3586 if (!utf8_to_bytes(s, &len)) { 3587 if (fail_ok) 3588 return FALSE; 3589 else { 3590 if (PL_op) 3591 Perl_croak(aTHX_ "Wide character in %s", 3592 OP_DESC(PL_op)); 3593 else 3594 Perl_croak(aTHX_ "Wide character"); 3595 } 3596 } 3597 SvCUR_set(sv, len); 3598 } 3599 } 3600 SvUTF8_off(sv); 3601 return TRUE; 3602 } 3603 3604 /* 3605 =for apidoc sv_utf8_encode 3606 3607 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8> 3608 flag off so that it looks like octets again. 3609 3610 =cut 3611 */ 3612 3613 void 3614 Perl_sv_utf8_encode(pTHX_ SV *const sv) 3615 { 3616 PERL_ARGS_ASSERT_SV_UTF8_ENCODE; 3617 3618 if (SvREADONLY(sv)) { 3619 sv_force_normal_flags(sv, 0); 3620 } 3621 (void) sv_utf8_upgrade(sv); 3622 SvUTF8_off(sv); 3623 } 3624 3625 /* 3626 =for apidoc sv_utf8_decode 3627 3628 If the PV of the SV is an octet sequence in UTF-8 3629 and contains a multiple-byte character, the C<SvUTF8> flag is turned on 3630 so that it looks like a character. If the PV contains only single-byte 3631 characters, the C<SvUTF8> flag stays off. 3632 Scans PV for validity and returns false if the PV is invalid UTF-8. 3633 3634 =cut 3635 */ 3636 3637 bool 3638 Perl_sv_utf8_decode(pTHX_ SV *const sv) 3639 { 3640 PERL_ARGS_ASSERT_SV_UTF8_DECODE; 3641 3642 if (SvPOKp(sv)) { 3643 const U8 *start, *c; 3644 const U8 *e; 3645 3646 /* The octets may have got themselves encoded - get them back as 3647 * bytes 3648 */ 3649 if (!sv_utf8_downgrade(sv, TRUE)) 3650 return FALSE; 3651 3652 /* it is actually just a matter of turning the utf8 flag on, but 3653 * we want to make sure everything inside is valid utf8 first. 3654 */ 3655 c = start = (const U8 *) SvPVX_const(sv); 3656 if (!is_utf8_string(c, SvCUR(sv))) 3657 return FALSE; 3658 e = (const U8 *) SvEND(sv); 3659 while (c < e) { 3660 const U8 ch = *c++; 3661 if (!UTF8_IS_INVARIANT(ch)) { 3662 SvUTF8_on(sv); 3663 break; 3664 } 3665 } 3666 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { 3667 /* XXX Is this dead code? XS_utf8_decode calls SvSETMAGIC 3668 after this, clearing pos. Does anything on CPAN 3669 need this? */ 3670 /* adjust pos to the start of a UTF8 char sequence */ 3671 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global); 3672 if (mg) { 3673 I32 pos = mg->mg_len; 3674 if (pos > 0) { 3675 for (c = start + pos; c > start; c--) { 3676 if (UTF8_IS_START(*c)) 3677 break; 3678 } 3679 mg->mg_len = c - start; 3680 } 3681 } 3682 if ((mg = mg_find(sv, PERL_MAGIC_utf8))) 3683 magic_setutf8(sv,mg); /* clear UTF8 cache */ 3684 } 3685 } 3686 return TRUE; 3687 } 3688 3689 /* 3690 =for apidoc sv_setsv 3691 3692 Copies the contents of the source SV C<ssv> into the destination SV 3693 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this 3694 function if the source SV needs to be reused. Does not handle 'set' magic on 3695 destination SV. Calls 'get' magic on source SV. Loosely speaking, it 3696 performs a copy-by-value, obliterating any previous content of the 3697 destination. 3698 3699 You probably want to use one of the assortment of wrappers, such as 3700 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and 3701 C<SvSetMagicSV_nosteal>. 3702 3703 =for apidoc sv_setsv_flags 3704 3705 Copies the contents of the source SV C<ssv> into the destination SV 3706 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this 3707 function if the source SV needs to be reused. Does not handle 'set' magic. 3708 Loosely speaking, it performs a copy-by-value, obliterating any previous 3709 content of the destination. 3710 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on 3711 C<ssv> if appropriate, else not. If the C<flags> 3712 parameter has the C<SV_NOSTEAL> bit set then the 3713 buffers of temps will not be stolen. <sv_setsv> 3714 and C<sv_setsv_nomg> are implemented in terms of this function. 3715 3716 You probably want to use one of the assortment of wrappers, such as 3717 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and 3718 C<SvSetMagicSV_nosteal>. 3719 3720 This is the primary function for copying scalars, and most other 3721 copy-ish functions and macros use this underneath. 3722 3723 =cut 3724 */ 3725 3726 static void 3727 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype) 3728 { 3729 I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */ 3730 HV *old_stash = NULL; 3731 3732 PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB; 3733 3734 if (dtype != SVt_PVGV && !isGV_with_GP(dstr)) { 3735 const char * const name = GvNAME(sstr); 3736 const STRLEN len = GvNAMELEN(sstr); 3737 { 3738 if (dtype >= SVt_PV) { 3739 SvPV_free(dstr); 3740 SvPV_set(dstr, 0); 3741 SvLEN_set(dstr, 0); 3742 SvCUR_set(dstr, 0); 3743 } 3744 SvUPGRADE(dstr, SVt_PVGV); 3745 (void)SvOK_off(dstr); 3746 isGV_with_GP_on(dstr); 3747 } 3748 GvSTASH(dstr) = GvSTASH(sstr); 3749 if (GvSTASH(dstr)) 3750 Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr); 3751 gv_name_set(MUTABLE_GV(dstr), name, len, 3752 GV_ADD | (GvNAMEUTF8(sstr) ? SVf_UTF8 : 0 )); 3753 SvFAKE_on(dstr); /* can coerce to non-glob */ 3754 } 3755 3756 if(GvGP(MUTABLE_GV(sstr))) { 3757 /* If source has method cache entry, clear it */ 3758 if(GvCVGEN(sstr)) { 3759 SvREFCNT_dec(GvCV(sstr)); 3760 GvCV_set(sstr, NULL); 3761 GvCVGEN(sstr) = 0; 3762 } 3763 /* If source has a real method, then a method is 3764 going to change */ 3765 else if( 3766 GvCV((const GV *)sstr) && GvSTASH(dstr) && HvENAME(GvSTASH(dstr)) 3767 ) { 3768 mro_changes = 1; 3769 } 3770 } 3771 3772 /* If dest already had a real method, that's a change as well */ 3773 if( 3774 !mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr) 3775 && GvSTASH(dstr) && HvENAME(GvSTASH(dstr)) 3776 ) { 3777 mro_changes = 1; 3778 } 3779 3780 /* We don't need to check the name of the destination if it was not a 3781 glob to begin with. */ 3782 if(dtype == SVt_PVGV) { 3783 const char * const name = GvNAME((const GV *)dstr); 3784 if( 3785 strEQ(name,"ISA") 3786 /* The stash may have been detached from the symbol table, so 3787 check its name. */ 3788 && GvSTASH(dstr) && HvENAME(GvSTASH(dstr)) 3789 ) 3790 mro_changes = 2; 3791 else { 3792 const STRLEN len = GvNAMELEN(dstr); 3793 if ((len > 1 && name[len-2] == ':' && name[len-1] == ':') 3794 || (len == 1 && name[0] == ':')) { 3795 mro_changes = 3; 3796 3797 /* Set aside the old stash, so we can reset isa caches on 3798 its subclasses. */ 3799 if((old_stash = GvHV(dstr))) 3800 /* Make sure we do not lose it early. */ 3801 SvREFCNT_inc_simple_void_NN( 3802 sv_2mortal((SV *)old_stash) 3803 ); 3804 } 3805 } 3806 3807 SvREFCNT_inc_simple_void_NN(sv_2mortal(dstr)); 3808 } 3809 3810 gp_free(MUTABLE_GV(dstr)); 3811 GvINTRO_off(dstr); /* one-shot flag */ 3812 GvGP_set(dstr, gp_ref(GvGP(sstr))); 3813 if (SvTAINTED(sstr)) 3814 SvTAINT(dstr); 3815 if (GvIMPORTED(dstr) != GVf_IMPORTED 3816 && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) 3817 { 3818 GvIMPORTED_on(dstr); 3819 } 3820 GvMULTI_on(dstr); 3821 if(mro_changes == 2) { 3822 if (GvAV((const GV *)sstr)) { 3823 MAGIC *mg; 3824 SV * const sref = (SV *)GvAV((const GV *)dstr); 3825 if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) { 3826 if (SvTYPE(mg->mg_obj) != SVt_PVAV) { 3827 AV * const ary = newAV(); 3828 av_push(ary, mg->mg_obj); /* takes the refcount */ 3829 mg->mg_obj = (SV *)ary; 3830 } 3831 av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dstr)); 3832 } 3833 else sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0); 3834 } 3835 mro_isa_changed_in(GvSTASH(dstr)); 3836 } 3837 else if(mro_changes == 3) { 3838 HV * const stash = GvHV(dstr); 3839 if(old_stash ? (HV *)HvENAME_get(old_stash) : stash) 3840 mro_package_moved( 3841 stash, old_stash, 3842 (GV *)dstr, 0 3843 ); 3844 } 3845 else if(mro_changes) mro_method_changed_in(GvSTASH(dstr)); 3846 if (GvIO(dstr) && dtype == SVt_PVGV) { 3847 DEBUG_o(Perl_deb(aTHX_ 3848 "glob_assign_glob clearing PL_stashcache\n")); 3849 /* It's a cache. It will rebuild itself quite happily. 3850 It's a lot of effort to work out exactly which key (or keys) 3851 might be invalidated by the creation of the this file handle. 3852 */ 3853 hv_clear(PL_stashcache); 3854 } 3855 return; 3856 } 3857 3858 static void 3859 S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr) 3860 { 3861 SV * const sref = SvRV(sstr); 3862 SV *dref; 3863 const int intro = GvINTRO(dstr); 3864 SV **location; 3865 U8 import_flag = 0; 3866 const U32 stype = SvTYPE(sref); 3867 3868 PERL_ARGS_ASSERT_GLOB_ASSIGN_REF; 3869 3870 if (intro) { 3871 GvINTRO_off(dstr); /* one-shot flag */ 3872 GvLINE(dstr) = CopLINE(PL_curcop); 3873 GvEGV(dstr) = MUTABLE_GV(dstr); 3874 } 3875 GvMULTI_on(dstr); 3876 switch (stype) { 3877 case SVt_PVCV: 3878 location = (SV **) &(GvGP(dstr)->gp_cv); /* XXX bypassing GvCV_set */ 3879 import_flag = GVf_IMPORTED_CV; 3880 goto common; 3881 case SVt_PVHV: 3882 location = (SV **) &GvHV(dstr); 3883 import_flag = GVf_IMPORTED_HV; 3884 goto common; 3885 case SVt_PVAV: 3886 location = (SV **) &GvAV(dstr); 3887 import_flag = GVf_IMPORTED_AV; 3888 goto common; 3889 case SVt_PVIO: 3890 location = (SV **) &GvIOp(dstr); 3891 goto common; 3892 case SVt_PVFM: 3893 location = (SV **) &GvFORM(dstr); 3894 goto common; 3895 default: 3896 location = &GvSV(dstr); 3897 import_flag = GVf_IMPORTED_SV; 3898 common: 3899 if (intro) { 3900 if (stype == SVt_PVCV) { 3901 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/ 3902 if (GvCVGEN(dstr)) { 3903 SvREFCNT_dec(GvCV(dstr)); 3904 GvCV_set(dstr, NULL); 3905 GvCVGEN(dstr) = 0; /* Switch off cacheness. */ 3906 } 3907 } 3908 /* SAVEt_GVSLOT takes more room on the savestack and has more 3909 overhead in leave_scope than SAVEt_GENERIC_SV. But for CVs 3910 leave_scope needs access to the GV so it can reset method 3911 caches. We must use SAVEt_GVSLOT whenever the type is 3912 SVt_PVCV, even if the stash is anonymous, as the stash may 3913 gain a name somehow before leave_scope. */ 3914 if (stype == SVt_PVCV) { 3915 /* There is no save_pushptrptrptr. Creating it for this 3916 one call site would be overkill. So inline the ss add 3917 routines here. */ 3918 dSS_ADD; 3919 SS_ADD_PTR(dstr); 3920 SS_ADD_PTR(location); 3921 SS_ADD_PTR(SvREFCNT_inc(*location)); 3922 SS_ADD_UV(SAVEt_GVSLOT); 3923 SS_ADD_END(4); 3924 } 3925 else SAVEGENERICSV(*location); 3926 } 3927 dref = *location; 3928 if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) { 3929 CV* const cv = MUTABLE_CV(*location); 3930 if (cv) { 3931 if (!GvCVGEN((const GV *)dstr) && 3932 (CvROOT(cv) || CvXSUB(cv)) && 3933 /* redundant check that avoids creating the extra SV 3934 most of the time: */ 3935 (CvCONST(cv) || ckWARN(WARN_REDEFINE))) 3936 { 3937 SV * const new_const_sv = 3938 CvCONST((const CV *)sref) 3939 ? cv_const_sv((const CV *)sref) 3940 : NULL; 3941 report_redefined_cv( 3942 sv_2mortal(Perl_newSVpvf(aTHX_ 3943 "%"HEKf"::%"HEKf, 3944 HEKfARG( 3945 HvNAME_HEK(GvSTASH((const GV *)dstr)) 3946 ), 3947 HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr))) 3948 )), 3949 cv, 3950 CvCONST((const CV *)sref) ? &new_const_sv : NULL 3951 ); 3952 } 3953 if (!intro) 3954 cv_ckproto_len_flags(cv, (const GV *)dstr, 3955 SvPOK(sref) ? CvPROTO(sref) : NULL, 3956 SvPOK(sref) ? CvPROTOLEN(sref) : 0, 3957 SvPOK(sref) ? SvUTF8(sref) : 0); 3958 } 3959 GvCVGEN(dstr) = 0; /* Switch off cacheness. */ 3960 GvASSUMECV_on(dstr); 3961 if(GvSTASH(dstr)) gv_method_changed(dstr); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */ 3962 } 3963 *location = SvREFCNT_inc_simple_NN(sref); 3964 if (import_flag && !(GvFLAGS(dstr) & import_flag) 3965 && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) { 3966 GvFLAGS(dstr) |= import_flag; 3967 } 3968 if (stype == SVt_PVHV) { 3969 const char * const name = GvNAME((GV*)dstr); 3970 const STRLEN len = GvNAMELEN(dstr); 3971 if ( 3972 ( 3973 (len > 1 && name[len-2] == ':' && name[len-1] == ':') 3974 || (len == 1 && name[0] == ':') 3975 ) 3976 && (!dref || HvENAME_get(dref)) 3977 ) { 3978 mro_package_moved( 3979 (HV *)sref, (HV *)dref, 3980 (GV *)dstr, 0 3981 ); 3982 } 3983 } 3984 else if ( 3985 stype == SVt_PVAV && sref != dref 3986 && strEQ(GvNAME((GV*)dstr), "ISA") 3987 /* The stash may have been detached from the symbol table, so 3988 check its name before doing anything. */ 3989 && GvSTASH(dstr) && HvENAME(GvSTASH(dstr)) 3990 ) { 3991 MAGIC *mg; 3992 MAGIC * const omg = dref && SvSMAGICAL(dref) 3993 ? mg_find(dref, PERL_MAGIC_isa) 3994 : NULL; 3995 if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) { 3996 if (SvTYPE(mg->mg_obj) != SVt_PVAV) { 3997 AV * const ary = newAV(); 3998 av_push(ary, mg->mg_obj); /* takes the refcount */ 3999 mg->mg_obj = (SV *)ary; 4000 } 4001 if (omg) { 4002 if (SvTYPE(omg->mg_obj) == SVt_PVAV) { 4003 SV **svp = AvARRAY((AV *)omg->mg_obj); 4004 I32 items = AvFILLp((AV *)omg->mg_obj) + 1; 4005 while (items--) 4006 av_push( 4007 (AV *)mg->mg_obj, 4008 SvREFCNT_inc_simple_NN(*svp++) 4009 ); 4010 } 4011 else 4012 av_push( 4013 (AV *)mg->mg_obj, 4014 SvREFCNT_inc_simple_NN(omg->mg_obj) 4015 ); 4016 } 4017 else 4018 av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dstr)); 4019 } 4020 else 4021 { 4022 sv_magic( 4023 sref, omg ? omg->mg_obj : dstr, PERL_MAGIC_isa, NULL, 0 4024 ); 4025 mg = mg_find(sref, PERL_MAGIC_isa); 4026 } 4027 /* Since the *ISA assignment could have affected more than 4028 one stash, don't call mro_isa_changed_in directly, but let 4029 magic_clearisa do it for us, as it already has the logic for 4030 dealing with globs vs arrays of globs. */ 4031 assert(mg); 4032 Perl_magic_clearisa(aTHX_ NULL, mg); 4033 } 4034 else if (stype == SVt_PVIO) { 4035 DEBUG_o(Perl_deb(aTHX_ "glob_assign_ref clearing PL_stashcache\n")); 4036 /* It's a cache. It will rebuild itself quite happily. 4037 It's a lot of effort to work out exactly which key (or keys) 4038 might be invalidated by the creation of the this file handle. 4039 */ 4040 hv_clear(PL_stashcache); 4041 } 4042 break; 4043 } 4044 if (!intro) SvREFCNT_dec(dref); 4045 if (SvTAINTED(sstr)) 4046 SvTAINT(dstr); 4047 return; 4048 } 4049 4050 4051 4052 4053 #ifdef PERL_DEBUG_READONLY_COW 4054 # include <sys/mman.h> 4055 4056 # ifndef PERL_MEMORY_DEBUG_HEADER_SIZE 4057 # define PERL_MEMORY_DEBUG_HEADER_SIZE 0 4058 # endif 4059 4060 void 4061 Perl_sv_buf_to_ro(pTHX_ SV *sv) 4062 { 4063 struct perl_memory_debug_header * const header = 4064 (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE); 4065 const MEM_SIZE len = header->size; 4066 PERL_ARGS_ASSERT_SV_BUF_TO_RO; 4067 # ifdef PERL_TRACK_MEMPOOL 4068 if (!header->readonly) header->readonly = 1; 4069 # endif 4070 if (mprotect(header, len, PROT_READ)) 4071 Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d", 4072 header, len, errno); 4073 } 4074 4075 static void 4076 S_sv_buf_to_rw(pTHX_ SV *sv) 4077 { 4078 struct perl_memory_debug_header * const header = 4079 (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE); 4080 const MEM_SIZE len = header->size; 4081 PERL_ARGS_ASSERT_SV_BUF_TO_RW; 4082 if (mprotect(header, len, PROT_READ|PROT_WRITE)) 4083 Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d", 4084 header, len, errno); 4085 # ifdef PERL_TRACK_MEMPOOL 4086 header->readonly = 0; 4087 # endif 4088 } 4089 4090 #else 4091 # define sv_buf_to_ro(sv) NOOP 4092 # define sv_buf_to_rw(sv) NOOP 4093 #endif 4094 4095 void 4096 Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags) 4097 { 4098 dVAR; 4099 U32 sflags; 4100 int dtype; 4101 svtype stype; 4102 4103 PERL_ARGS_ASSERT_SV_SETSV_FLAGS; 4104 4105 if (sstr == dstr) 4106 return; 4107 4108 if (SvIS_FREED(dstr)) { 4109 Perl_croak(aTHX_ "panic: attempt to copy value %" SVf 4110 " to a freed scalar %p", SVfARG(sstr), (void *)dstr); 4111 } 4112 SV_CHECK_THINKFIRST_COW_DROP(dstr); 4113 if (!sstr) 4114 sstr = &PL_sv_undef; 4115 if (SvIS_FREED(sstr)) { 4116 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p", 4117 (void*)sstr, (void*)dstr); 4118 } 4119 stype = SvTYPE(sstr); 4120 dtype = SvTYPE(dstr); 4121 4122 /* There's a lot of redundancy below but we're going for speed here */ 4123 4124 switch (stype) { 4125 case SVt_NULL: 4126 undef_sstr: 4127 if (dtype != SVt_PVGV && dtype != SVt_PVLV) { 4128 (void)SvOK_off(dstr); 4129 return; 4130 } 4131 break; 4132 case SVt_IV: 4133 if (SvIOK(sstr)) { 4134 switch (dtype) { 4135 case SVt_NULL: 4136 sv_upgrade(dstr, SVt_IV); 4137 break; 4138 case SVt_NV: 4139 case SVt_PV: 4140 sv_upgrade(dstr, SVt_PVIV); 4141 break; 4142 case SVt_PVGV: 4143 case SVt_PVLV: 4144 goto end_of_first_switch; 4145 } 4146 (void)SvIOK_only(dstr); 4147 SvIV_set(dstr, SvIVX(sstr)); 4148 if (SvIsUV(sstr)) 4149 SvIsUV_on(dstr); 4150 /* SvTAINTED can only be true if the SV has taint magic, which in 4151 turn means that the SV type is PVMG (or greater). This is the 4152 case statement for SVt_IV, so this cannot be true (whatever gcov 4153 may say). */ 4154 assert(!SvTAINTED(sstr)); 4155 return; 4156 } 4157 if (!SvROK(sstr)) 4158 goto undef_sstr; 4159 if (dtype < SVt_PV && dtype != SVt_IV) 4160 sv_upgrade(dstr, SVt_IV); 4161 break; 4162 4163 case SVt_NV: 4164 if (SvNOK(sstr)) { 4165 switch (dtype) { 4166 case SVt_NULL: 4167 case SVt_IV: 4168 sv_upgrade(dstr, SVt_NV); 4169 break; 4170 case SVt_PV: 4171 case SVt_PVIV: 4172 sv_upgrade(dstr, SVt_PVNV); 4173 break; 4174 case SVt_PVGV: 4175 case SVt_PVLV: 4176 goto end_of_first_switch; 4177 } 4178 SvNV_set(dstr, SvNVX(sstr)); 4179 (void)SvNOK_only(dstr); 4180 /* SvTAINTED can only be true if the SV has taint magic, which in 4181 turn means that the SV type is PVMG (or greater). This is the 4182 case statement for SVt_NV, so this cannot be true (whatever gcov 4183 may say). */ 4184 assert(!SvTAINTED(sstr)); 4185 return; 4186 } 4187 goto undef_sstr; 4188 4189 case SVt_PV: 4190 if (dtype < SVt_PV) 4191 sv_upgrade(dstr, SVt_PV); 4192 break; 4193 case SVt_PVIV: 4194 if (dtype < SVt_PVIV) 4195 sv_upgrade(dstr, SVt_PVIV); 4196 break; 4197 case SVt_PVNV: 4198 if (dtype < SVt_PVNV) 4199 sv_upgrade(dstr, SVt_PVNV); 4200 break; 4201 default: 4202 { 4203 const char * const type = sv_reftype(sstr,0); 4204 if (PL_op) 4205 /* diag_listed_as: Bizarre copy of %s */ 4206 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op)); 4207 else 4208 Perl_croak(aTHX_ "Bizarre copy of %s", type); 4209 } 4210 break; 4211 4212 case SVt_REGEXP: 4213 upgregexp: 4214 if (dtype < SVt_REGEXP) 4215 { 4216 if (dtype >= SVt_PV) { 4217 SvPV_free(dstr); 4218 SvPV_set(dstr, 0); 4219 SvLEN_set(dstr, 0); 4220 SvCUR_set(dstr, 0); 4221 } 4222 sv_upgrade(dstr, SVt_REGEXP); 4223 } 4224 break; 4225 4226 case SVt_INVLIST: 4227 case SVt_PVLV: 4228 case SVt_PVGV: 4229 case SVt_PVMG: 4230 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) { 4231 mg_get(sstr); 4232 if (SvTYPE(sstr) != stype) 4233 stype = SvTYPE(sstr); 4234 } 4235 if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) { 4236 glob_assign_glob(dstr, sstr, dtype); 4237 return; 4238 } 4239 if (stype == SVt_PVLV) 4240 { 4241 if (isREGEXP(sstr)) goto upgregexp; 4242 SvUPGRADE(dstr, SVt_PVNV); 4243 } 4244 else 4245 SvUPGRADE(dstr, (svtype)stype); 4246 } 4247 end_of_first_switch: 4248 4249 /* dstr may have been upgraded. */ 4250 dtype = SvTYPE(dstr); 4251 sflags = SvFLAGS(sstr); 4252 4253 if (dtype == SVt_PVCV) { 4254 /* Assigning to a subroutine sets the prototype. */ 4255 if (SvOK(sstr)) { 4256 STRLEN len; 4257 const char *const ptr = SvPV_const(sstr, len); 4258 4259 SvGROW(dstr, len + 1); 4260 Copy(ptr, SvPVX(dstr), len + 1, char); 4261 SvCUR_set(dstr, len); 4262 SvPOK_only(dstr); 4263 SvFLAGS(dstr) |= sflags & SVf_UTF8; 4264 CvAUTOLOAD_off(dstr); 4265 } else { 4266 SvOK_off(dstr); 4267 } 4268 } 4269 else if (dtype == SVt_PVAV || dtype == SVt_PVHV || dtype == SVt_PVFM) { 4270 const char * const type = sv_reftype(dstr,0); 4271 if (PL_op) 4272 /* diag_listed_as: Cannot copy to %s */ 4273 Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op)); 4274 else 4275 Perl_croak(aTHX_ "Cannot copy to %s", type); 4276 } else if (sflags & SVf_ROK) { 4277 if (isGV_with_GP(dstr) 4278 && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) { 4279 sstr = SvRV(sstr); 4280 if (sstr == dstr) { 4281 if (GvIMPORTED(dstr) != GVf_IMPORTED 4282 && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) 4283 { 4284 GvIMPORTED_on(dstr); 4285 } 4286 GvMULTI_on(dstr); 4287 return; 4288 } 4289 glob_assign_glob(dstr, sstr, dtype); 4290 return; 4291 } 4292 4293 if (dtype >= SVt_PV) { 4294 if (isGV_with_GP(dstr)) { 4295 glob_assign_ref(dstr, sstr); 4296 return; 4297 } 4298 if (SvPVX_const(dstr)) { 4299 SvPV_free(dstr); 4300 SvLEN_set(dstr, 0); 4301 SvCUR_set(dstr, 0); 4302 } 4303 } 4304 (void)SvOK_off(dstr); 4305 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr))); 4306 SvFLAGS(dstr) |= sflags & SVf_ROK; 4307 assert(!(sflags & SVp_NOK)); 4308 assert(!(sflags & SVp_IOK)); 4309 assert(!(sflags & SVf_NOK)); 4310 assert(!(sflags & SVf_IOK)); 4311 } 4312 else if (isGV_with_GP(dstr)) { 4313 if (!(sflags & SVf_OK)) { 4314 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), 4315 "Undefined value assigned to typeglob"); 4316 } 4317 else { 4318 GV *gv = gv_fetchsv_nomg(sstr, GV_ADD, SVt_PVGV); 4319 if (dstr != (const SV *)gv) { 4320 const char * const name = GvNAME((const GV *)dstr); 4321 const STRLEN len = GvNAMELEN(dstr); 4322 HV *old_stash = NULL; 4323 bool reset_isa = FALSE; 4324 if ((len > 1 && name[len-2] == ':' && name[len-1] == ':') 4325 || (len == 1 && name[0] == ':')) { 4326 /* Set aside the old stash, so we can reset isa caches 4327 on its subclasses. */ 4328 if((old_stash = GvHV(dstr))) { 4329 /* Make sure we do not lose it early. */ 4330 SvREFCNT_inc_simple_void_NN( 4331 sv_2mortal((SV *)old_stash) 4332 ); 4333 } 4334 reset_isa = TRUE; 4335 } 4336 4337 if (GvGP(dstr)) { 4338 SvREFCNT_inc_simple_void_NN(sv_2mortal(dstr)); 4339 gp_free(MUTABLE_GV(dstr)); 4340 } 4341 GvGP_set(dstr, gp_ref(GvGP(gv))); 4342 4343 if (reset_isa) { 4344 HV * const stash = GvHV(dstr); 4345 if( 4346 old_stash ? (HV *)HvENAME_get(old_stash) : stash 4347 ) 4348 mro_package_moved( 4349 stash, old_stash, 4350 (GV *)dstr, 0 4351 ); 4352 } 4353 } 4354 } 4355 } 4356 else if ((dtype == SVt_REGEXP || dtype == SVt_PVLV) 4357 && (stype == SVt_REGEXP || isREGEXP(sstr))) { 4358 reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr); 4359 } 4360 else if (sflags & SVp_POK) { 4361 const STRLEN cur = SvCUR(sstr); 4362 const STRLEN len = SvLEN(sstr); 4363 4364 /* 4365 * We have three basic ways to copy the string: 4366 * 4367 * 1. Swipe 4368 * 2. Copy-on-write 4369 * 3. Actual copy 4370 * 4371 * Which we choose is based on various factors. The following 4372 * things are listed in order of speed, fastest to slowest: 4373 * - Swipe 4374 * - Copying a short string 4375 * - Copy-on-write bookkeeping 4376 * - malloc 4377 * - Copying a long string 4378 * 4379 * We swipe the string (steal the string buffer) if the SV on the 4380 * rhs is about to be freed anyway (TEMP and refcnt==1). This is a 4381 * big win on long strings. It should be a win on short strings if 4382 * SvPVX_const(dstr) has to be allocated. If not, it should not 4383 * slow things down, as SvPVX_const(sstr) would have been freed 4384 * soon anyway. 4385 * 4386 * We also steal the buffer from a PADTMP (operator target) if it 4387 * is ‘long enough’. For short strings, a swipe does not help 4388 * here, as it causes more malloc calls the next time the target 4389 * is used. Benchmarks show that even if SvPVX_const(dstr) has to 4390 * be allocated it is still not worth swiping PADTMPs for short 4391 * strings, as the savings here are small. 4392 * 4393 * If the rhs is already flagged as a copy-on-write string and COW 4394 * is possible here, we use copy-on-write and make both SVs share 4395 * the string buffer. 4396 * 4397 * If the rhs is not flagged as copy-on-write, then we see whether 4398 * it is worth upgrading it to such. If the lhs already has a buf- 4399 * fer big enough and the string is short, we skip it and fall back 4400 * to method 3, since memcpy is faster for short strings than the 4401 * later bookkeeping overhead that copy-on-write entails. 4402 * 4403 * If there is no buffer on the left, or the buffer is too small, 4404 * then we use copy-on-write. 4405 */ 4406 4407 /* Whichever path we take through the next code, we want this true, 4408 and doing it now facilitates the COW check. */ 4409 (void)SvPOK_only(dstr); 4410 4411 if ( 4412 ( /* Either ... */ 4413 /* slated for free anyway (and not COW)? */ 4414 (sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP 4415 /* or a swipable TARG */ 4416 || ((sflags & (SVs_PADTMP|SVs_PADMY|SVf_READONLY 4417 |SVf_IsCOW)) 4418 == SVs_PADTMP 4419 /* whose buffer is worth stealing */ 4420 && CHECK_COWBUF_THRESHOLD(cur,len) 4421 ) 4422 ) && 4423 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */ 4424 (!(flags & SV_NOSTEAL)) && 4425 /* and we're allowed to steal temps */ 4426 SvREFCNT(sstr) == 1 && /* and no other references to it? */ 4427 len) /* and really is a string */ 4428 { /* Passes the swipe test. */ 4429 if (SvPVX_const(dstr)) /* we know that dtype >= SVt_PV */ 4430 SvPV_free(dstr); 4431 SvPV_set(dstr, SvPVX_mutable(sstr)); 4432 SvLEN_set(dstr, SvLEN(sstr)); 4433 SvCUR_set(dstr, SvCUR(sstr)); 4434 4435 SvTEMP_off(dstr); 4436 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */ 4437 SvPV_set(sstr, NULL); 4438 SvLEN_set(sstr, 0); 4439 SvCUR_set(sstr, 0); 4440 SvTEMP_off(sstr); 4441 } 4442 else if (flags & SV_COW_SHARED_HASH_KEYS 4443 && 4444 #ifdef PERL_OLD_COPY_ON_WRITE 4445 ( sflags & SVf_IsCOW 4446 || ( (sflags & CAN_COW_MASK) == CAN_COW_FLAGS 4447 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS 4448 && SvTYPE(sstr) >= SVt_PVIV && len 4449 ) 4450 ) 4451 #elif defined(PERL_NEW_COPY_ON_WRITE) 4452 (sflags & SVf_IsCOW 4453 ? (!len || 4454 ( (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dstr) < cur+1) 4455 /* If this is a regular (non-hek) COW, only so 4456 many COW "copies" are possible. */ 4457 && CowREFCNT(sstr) != SV_COW_REFCNT_MAX )) 4458 : ( (sflags & CAN_COW_MASK) == CAN_COW_FLAGS 4459 && !(SvFLAGS(dstr) & SVf_BREAK) 4460 && CHECK_COW_THRESHOLD(cur,len) && cur+1 < len 4461 && (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dstr) < cur+1) 4462 )) 4463 #else 4464 sflags & SVf_IsCOW 4465 && !(SvFLAGS(dstr) & SVf_BREAK) 4466 #endif 4467 ) { 4468 /* Either it's a shared hash key, or it's suitable for 4469 copy-on-write. */ 4470 if (DEBUG_C_TEST) { 4471 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n"); 4472 sv_dump(sstr); 4473 sv_dump(dstr); 4474 } 4475 #ifdef PERL_ANY_COW 4476 if (!(sflags & SVf_IsCOW)) { 4477 SvIsCOW_on(sstr); 4478 # ifdef PERL_OLD_COPY_ON_WRITE 4479 /* Make the source SV into a loop of 1. 4480 (about to become 2) */ 4481 SV_COW_NEXT_SV_SET(sstr, sstr); 4482 # else 4483 CowREFCNT(sstr) = 0; 4484 # endif 4485 } 4486 #endif 4487 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */ 4488 SvPV_free(dstr); 4489 } 4490 4491 #ifdef PERL_ANY_COW 4492 if (len) { 4493 # ifdef PERL_OLD_COPY_ON_WRITE 4494 assert (SvTYPE(dstr) >= SVt_PVIV); 4495 /* SvIsCOW_normal */ 4496 /* splice us in between source and next-after-source. */ 4497 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr)); 4498 SV_COW_NEXT_SV_SET(sstr, dstr); 4499 # else 4500 if (sflags & SVf_IsCOW) { 4501 sv_buf_to_rw(sstr); 4502 } 4503 CowREFCNT(sstr)++; 4504 # endif 4505 SvPV_set(dstr, SvPVX_mutable(sstr)); 4506 sv_buf_to_ro(sstr); 4507 } else 4508 #endif 4509 { 4510 /* SvIsCOW_shared_hash */ 4511 DEBUG_C(PerlIO_printf(Perl_debug_log, 4512 "Copy on write: Sharing hash\n")); 4513 4514 assert (SvTYPE(dstr) >= SVt_PV); 4515 SvPV_set(dstr, 4516 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))))); 4517 } 4518 SvLEN_set(dstr, len); 4519 SvCUR_set(dstr, cur); 4520 SvIsCOW_on(dstr); 4521 } else { 4522 /* Failed the swipe test, and we cannot do copy-on-write either. 4523 Have to copy the string. */ 4524 SvGROW(dstr, cur + 1); /* inlined from sv_setpvn */ 4525 Move(SvPVX_const(sstr),SvPVX(dstr),cur,char); 4526 SvCUR_set(dstr, cur); 4527 *SvEND(dstr) = '\0'; 4528 } 4529 if (sflags & SVp_NOK) { 4530 SvNV_set(dstr, SvNVX(sstr)); 4531 } 4532 if (sflags & SVp_IOK) { 4533 SvIV_set(dstr, SvIVX(sstr)); 4534 /* Must do this otherwise some other overloaded use of 0x80000000 4535 gets confused. I guess SVpbm_VALID */ 4536 if (sflags & SVf_IVisUV) 4537 SvIsUV_on(dstr); 4538 } 4539 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8); 4540 { 4541 const MAGIC * const smg = SvVSTRING_mg(sstr); 4542 if (smg) { 4543 sv_magic(dstr, NULL, PERL_MAGIC_vstring, 4544 smg->mg_ptr, smg->mg_len); 4545 SvRMAGICAL_on(dstr); 4546 } 4547 } 4548 } 4549 else if (sflags & (SVp_IOK|SVp_NOK)) { 4550 (void)SvOK_off(dstr); 4551 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK); 4552 if (sflags & SVp_IOK) { 4553 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */ 4554 SvIV_set(dstr, SvIVX(sstr)); 4555 } 4556 if (sflags & SVp_NOK) { 4557 SvNV_set(dstr, SvNVX(sstr)); 4558 } 4559 } 4560 else { 4561 if (isGV_with_GP(sstr)) { 4562 gv_efullname3(dstr, MUTABLE_GV(sstr), "*"); 4563 } 4564 else 4565 (void)SvOK_off(dstr); 4566 } 4567 if (SvTAINTED(sstr)) 4568 SvTAINT(dstr); 4569 } 4570 4571 /* 4572 =for apidoc sv_setsv_mg 4573 4574 Like C<sv_setsv>, but also handles 'set' magic. 4575 4576 =cut 4577 */ 4578 4579 void 4580 Perl_sv_setsv_mg(pTHX_ SV *const dstr, SV *const sstr) 4581 { 4582 PERL_ARGS_ASSERT_SV_SETSV_MG; 4583 4584 sv_setsv(dstr,sstr); 4585 SvSETMAGIC(dstr); 4586 } 4587 4588 #ifdef PERL_ANY_COW 4589 # ifdef PERL_OLD_COPY_ON_WRITE 4590 # define SVt_COW SVt_PVIV 4591 # else 4592 # define SVt_COW SVt_PV 4593 # endif 4594 SV * 4595 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr) 4596 { 4597 STRLEN cur = SvCUR(sstr); 4598 STRLEN len = SvLEN(sstr); 4599 char *new_pv; 4600 #if defined(PERL_DEBUG_READONLY_COW) && defined(PERL_NEW_COPY_ON_WRITE) 4601 const bool already = cBOOL(SvIsCOW(sstr)); 4602 #endif 4603 4604 PERL_ARGS_ASSERT_SV_SETSV_COW; 4605 4606 if (DEBUG_C_TEST) { 4607 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n", 4608 (void*)sstr, (void*)dstr); 4609 sv_dump(sstr); 4610 if (dstr) 4611 sv_dump(dstr); 4612 } 4613 4614 if (dstr) { 4615 if (SvTHINKFIRST(dstr)) 4616 sv_force_normal_flags(dstr, SV_COW_DROP_PV); 4617 else if (SvPVX_const(dstr)) 4618 Safefree(SvPVX_mutable(dstr)); 4619 } 4620 else 4621 new_SV(dstr); 4622 SvUPGRADE(dstr, SVt_COW); 4623 4624 assert (SvPOK(sstr)); 4625 assert (SvPOKp(sstr)); 4626 # ifdef PERL_OLD_COPY_ON_WRITE 4627 assert (!SvIOK(sstr)); 4628 assert (!SvIOKp(sstr)); 4629 assert (!SvNOK(sstr)); 4630 assert (!SvNOKp(sstr)); 4631 # endif 4632 4633 if (SvIsCOW(sstr)) { 4634 4635 if (SvLEN(sstr) == 0) { 4636 /* source is a COW shared hash key. */ 4637 DEBUG_C(PerlIO_printf(Perl_debug_log, 4638 "Fast copy on write: Sharing hash\n")); 4639 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))); 4640 goto common_exit; 4641 } 4642 # ifdef PERL_OLD_COPY_ON_WRITE 4643 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr)); 4644 # else 4645 assert(SvCUR(sstr)+1 < SvLEN(sstr)); 4646 assert(CowREFCNT(sstr) < SV_COW_REFCNT_MAX); 4647 # endif 4648 } else { 4649 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS); 4650 SvUPGRADE(sstr, SVt_COW); 4651 SvIsCOW_on(sstr); 4652 DEBUG_C(PerlIO_printf(Perl_debug_log, 4653 "Fast copy on write: Converting sstr to COW\n")); 4654 # ifdef PERL_OLD_COPY_ON_WRITE 4655 SV_COW_NEXT_SV_SET(dstr, sstr); 4656 # else 4657 CowREFCNT(sstr) = 0; 4658 # endif 4659 } 4660 # ifdef PERL_OLD_COPY_ON_WRITE 4661 SV_COW_NEXT_SV_SET(sstr, dstr); 4662 # else 4663 # ifdef PERL_DEBUG_READONLY_COW 4664 if (already) sv_buf_to_rw(sstr); 4665 # endif 4666 CowREFCNT(sstr)++; 4667 # endif 4668 new_pv = SvPVX_mutable(sstr); 4669 sv_buf_to_ro(sstr); 4670 4671 common_exit: 4672 SvPV_set(dstr, new_pv); 4673 SvFLAGS(dstr) = (SVt_COW|SVf_POK|SVp_POK|SVf_IsCOW); 4674 if (SvUTF8(sstr)) 4675 SvUTF8_on(dstr); 4676 SvLEN_set(dstr, len); 4677 SvCUR_set(dstr, cur); 4678 if (DEBUG_C_TEST) { 4679 sv_dump(dstr); 4680 } 4681 return dstr; 4682 } 4683 #endif 4684 4685 /* 4686 =for apidoc sv_setpvn 4687 4688 Copies a string (possibly containing embedded C<NUL> characters) into an SV. 4689 The C<len> parameter indicates the number of 4690 bytes to be copied. If the C<ptr> argument is NULL the SV will become 4691 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>. 4692 4693 =cut 4694 */ 4695 4696 void 4697 Perl_sv_setpvn(pTHX_ SV *const sv, const char *const ptr, const STRLEN len) 4698 { 4699 dVAR; 4700 char *dptr; 4701 4702 PERL_ARGS_ASSERT_SV_SETPVN; 4703 4704 SV_CHECK_THINKFIRST_COW_DROP(sv); 4705 if (!ptr) { 4706 (void)SvOK_off(sv); 4707 return; 4708 } 4709 else { 4710 /* len is STRLEN which is unsigned, need to copy to signed */ 4711 const IV iv = len; 4712 if (iv < 0) 4713 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen %" 4714 IVdf, iv); 4715 } 4716 SvUPGRADE(sv, SVt_PV); 4717 4718 dptr = SvGROW(sv, len + 1); 4719 Move(ptr,dptr,len,char); 4720 dptr[len] = '\0'; 4721 SvCUR_set(sv, len); 4722 (void)SvPOK_only_UTF8(sv); /* validate pointer */ 4723 SvTAINT(sv); 4724 if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv); 4725 } 4726 4727 /* 4728 =for apidoc sv_setpvn_mg 4729 4730 Like C<sv_setpvn>, but also handles 'set' magic. 4731 4732 =cut 4733 */ 4734 4735 void 4736 Perl_sv_setpvn_mg(pTHX_ SV *const sv, const char *const ptr, const STRLEN len) 4737 { 4738 PERL_ARGS_ASSERT_SV_SETPVN_MG; 4739 4740 sv_setpvn(sv,ptr,len); 4741 SvSETMAGIC(sv); 4742 } 4743 4744 /* 4745 =for apidoc sv_setpv 4746 4747 Copies a string into an SV. The string must be terminated with a C<NUL> 4748 character. 4749 Does not handle 'set' magic. See C<sv_setpv_mg>. 4750 4751 =cut 4752 */ 4753 4754 void 4755 Perl_sv_setpv(pTHX_ SV *const sv, const char *const ptr) 4756 { 4757 dVAR; 4758 STRLEN len; 4759 4760 PERL_ARGS_ASSERT_SV_SETPV; 4761 4762 SV_CHECK_THINKFIRST_COW_DROP(sv); 4763 if (!ptr) { 4764 (void)SvOK_off(sv); 4765 return; 4766 } 4767 len = strlen(ptr); 4768 SvUPGRADE(sv, SVt_PV); 4769 4770 SvGROW(sv, len + 1); 4771 Move(ptr,SvPVX(sv),len+1,char); 4772 SvCUR_set(sv, len); 4773 (void)SvPOK_only_UTF8(sv); /* validate pointer */ 4774 SvTAINT(sv); 4775 if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv); 4776 } 4777 4778 /* 4779 =for apidoc sv_setpv_mg 4780 4781 Like C<sv_setpv>, but also handles 'set' magic. 4782 4783 =cut 4784 */ 4785 4786 void 4787 Perl_sv_setpv_mg(pTHX_ SV *const sv, const char *const ptr) 4788 { 4789 PERL_ARGS_ASSERT_SV_SETPV_MG; 4790 4791 sv_setpv(sv,ptr); 4792 SvSETMAGIC(sv); 4793 } 4794 4795 void 4796 Perl_sv_sethek(pTHX_ SV *const sv, const HEK *const hek) 4797 { 4798 dVAR; 4799 4800 PERL_ARGS_ASSERT_SV_SETHEK; 4801 4802 if (!hek) { 4803 return; 4804 } 4805 4806 if (HEK_LEN(hek) == HEf_SVKEY) { 4807 sv_setsv(sv, *(SV**)HEK_KEY(hek)); 4808 return; 4809 } else { 4810 const int flags = HEK_FLAGS(hek); 4811 if (flags & HVhek_WASUTF8) { 4812 STRLEN utf8_len = HEK_LEN(hek); 4813 char *as_utf8 = (char *)bytes_to_utf8((U8*)HEK_KEY(hek), &utf8_len); 4814 sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL); 4815 SvUTF8_on(sv); 4816 return; 4817 } else if (flags & HVhek_UNSHARED) { 4818 sv_setpvn(sv, HEK_KEY(hek), HEK_LEN(hek)); 4819 if (HEK_UTF8(hek)) 4820 SvUTF8_on(sv); 4821 else SvUTF8_off(sv); 4822 return; 4823 } 4824 { 4825 SV_CHECK_THINKFIRST_COW_DROP(sv); 4826 SvUPGRADE(sv, SVt_PV); 4827 SvPV_free(sv); 4828 SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek))); 4829 SvCUR_set(sv, HEK_LEN(hek)); 4830 SvLEN_set(sv, 0); 4831 SvIsCOW_on(sv); 4832 SvPOK_on(sv); 4833 if (HEK_UTF8(hek)) 4834 SvUTF8_on(sv); 4835 else SvUTF8_off(sv); 4836 return; 4837 } 4838 } 4839 } 4840 4841 4842 /* 4843 =for apidoc sv_usepvn_flags 4844 4845 Tells an SV to use C<ptr> to find its string value. Normally the 4846 string is stored inside the SV, but sv_usepvn allows the SV to use an 4847 outside string. The C<ptr> should point to memory that was allocated 4848 by L<Newx|perlclib/Memory Management and String Handling>. It must be 4849 the start of a Newx-ed block of memory, and not a pointer to the 4850 middle of it (beware of L<OOK|perlguts/Offsets> and copy-on-write), 4851 and not be from a non-Newx memory allocator like C<malloc>. The 4852 string length, C<len>, must be supplied. By default this function 4853 will C<Renew> (i.e. realloc, move) the memory pointed to by C<ptr>, 4854 so that pointer should not be freed or used by the programmer after 4855 giving it to sv_usepvn, and neither should any pointers from "behind" 4856 that pointer (e.g. ptr + 1) be used. 4857 4858 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> & 4859 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be C<NUL>, and the realloc 4860 will be skipped (i.e. the buffer is actually at least 1 byte longer than 4861 C<len>, and already meets the requirements for storing in C<SvPVX>). 4862 4863 =cut 4864 */ 4865 4866 void 4867 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags) 4868 { 4869 dVAR; 4870 STRLEN allocate; 4871 4872 PERL_ARGS_ASSERT_SV_USEPVN_FLAGS; 4873 4874 SV_CHECK_THINKFIRST_COW_DROP(sv); 4875 SvUPGRADE(sv, SVt_PV); 4876 if (!ptr) { 4877 (void)SvOK_off(sv); 4878 if (flags & SV_SMAGIC) 4879 SvSETMAGIC(sv); 4880 return; 4881 } 4882 if (SvPVX_const(sv)) 4883 SvPV_free(sv); 4884 4885 #ifdef DEBUGGING 4886 if (flags & SV_HAS_TRAILING_NUL) 4887 assert(ptr[len] == '\0'); 4888 #endif 4889 4890 allocate = (flags & SV_HAS_TRAILING_NUL) 4891 ? len + 1 : 4892 #ifdef Perl_safesysmalloc_size 4893 len + 1; 4894 #else 4895 PERL_STRLEN_ROUNDUP(len + 1); 4896 #endif 4897 if (flags & SV_HAS_TRAILING_NUL) { 4898 /* It's long enough - do nothing. 4899 Specifically Perl_newCONSTSUB is relying on this. */ 4900 } else { 4901 #ifdef DEBUGGING 4902 /* Force a move to shake out bugs in callers. */ 4903 char *new_ptr = (char*)safemalloc(allocate); 4904 Copy(ptr, new_ptr, len, char); 4905 PoisonFree(ptr,len,char); 4906 Safefree(ptr); 4907 ptr = new_ptr; 4908 #else 4909 ptr = (char*) saferealloc (ptr, allocate); 4910 #endif 4911 } 4912 #ifdef Perl_safesysmalloc_size 4913 SvLEN_set(sv, Perl_safesysmalloc_size(ptr)); 4914 #else 4915 SvLEN_set(sv, allocate); 4916 #endif 4917 SvCUR_set(sv, len); 4918 SvPV_set(sv, ptr); 4919 if (!(flags & SV_HAS_TRAILING_NUL)) { 4920 ptr[len] = '\0'; 4921 } 4922 (void)SvPOK_only_UTF8(sv); /* validate pointer */ 4923 SvTAINT(sv); 4924 if (flags & SV_SMAGIC) 4925 SvSETMAGIC(sv); 4926 } 4927 4928 #ifdef PERL_OLD_COPY_ON_WRITE 4929 /* Need to do this *after* making the SV normal, as we need the buffer 4930 pointer to remain valid until after we've copied it. If we let go too early, 4931 another thread could invalidate it by unsharing last of the same hash key 4932 (which it can do by means other than releasing copy-on-write Svs) 4933 or by changing the other copy-on-write SVs in the loop. */ 4934 STATIC void 4935 S_sv_release_COW(pTHX_ SV *sv, const char *pvx, SV *after) 4936 { 4937 PERL_ARGS_ASSERT_SV_RELEASE_COW; 4938 4939 { /* this SV was SvIsCOW_normal(sv) */ 4940 /* we need to find the SV pointing to us. */ 4941 SV *current = SV_COW_NEXT_SV(after); 4942 4943 if (current == sv) { 4944 /* The SV we point to points back to us (there were only two of us 4945 in the loop.) 4946 Hence other SV is no longer copy on write either. */ 4947 SvIsCOW_off(after); 4948 sv_buf_to_rw(after); 4949 } else { 4950 /* We need to follow the pointers around the loop. */ 4951 SV *next; 4952 while ((next = SV_COW_NEXT_SV(current)) != sv) { 4953 assert (next); 4954 current = next; 4955 /* don't loop forever if the structure is bust, and we have 4956 a pointer into a closed loop. */ 4957 assert (current != after); 4958 assert (SvPVX_const(current) == pvx); 4959 } 4960 /* Make the SV before us point to the SV after us. */ 4961 SV_COW_NEXT_SV_SET(current, after); 4962 } 4963 } 4964 } 4965 #endif 4966 /* 4967 =for apidoc sv_force_normal_flags 4968 4969 Undo various types of fakery on an SV, where fakery means 4970 "more than" a string: if the PV is a shared string, make 4971 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to 4972 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when 4973 we do the copy, and is also used locally; if this is a 4974 vstring, drop the vstring magic. If C<SV_COW_DROP_PV> is set 4975 then a copy-on-write scalar drops its PV buffer (if any) and becomes 4976 SvPOK_off rather than making a copy. (Used where this 4977 scalar is about to be set to some other value.) In addition, 4978 the C<flags> parameter gets passed to C<sv_unref_flags()> 4979 when unreffing. C<sv_force_normal> calls this function 4980 with flags set to 0. 4981 4982 This function is expected to be used to signal to perl that this SV is 4983 about to be written to, and any extra book-keeping needs to be taken care 4984 of. Hence, it croaks on read-only values. 4985 4986 =cut 4987 */ 4988 4989 static void 4990 S_sv_uncow(pTHX_ SV * const sv, const U32 flags) 4991 { 4992 dVAR; 4993 4994 assert(SvIsCOW(sv)); 4995 { 4996 #ifdef PERL_ANY_COW 4997 const char * const pvx = SvPVX_const(sv); 4998 const STRLEN len = SvLEN(sv); 4999 const STRLEN cur = SvCUR(sv); 5000 # ifdef PERL_OLD_COPY_ON_WRITE 5001 /* next COW sv in the loop. If len is 0 then this is a shared-hash 5002 key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as 5003 we'll fail an assertion. */ 5004 SV * const next = len ? SV_COW_NEXT_SV(sv) : 0; 5005 # endif 5006 5007 if (DEBUG_C_TEST) { 5008 PerlIO_printf(Perl_debug_log, 5009 "Copy on write: Force normal %ld\n", 5010 (long) flags); 5011 sv_dump(sv); 5012 } 5013 SvIsCOW_off(sv); 5014 # ifdef PERL_NEW_COPY_ON_WRITE 5015 if (len && CowREFCNT(sv) == 0) 5016 /* We own the buffer ourselves. */ 5017 sv_buf_to_rw(sv); 5018 else 5019 # endif 5020 { 5021 5022 /* This SV doesn't own the buffer, so need to Newx() a new one: */ 5023 # ifdef PERL_NEW_COPY_ON_WRITE 5024 /* Must do this first, since the macro uses SvPVX. */ 5025 if (len) { 5026 sv_buf_to_rw(sv); 5027 CowREFCNT(sv)--; 5028 sv_buf_to_ro(sv); 5029 } 5030 # endif 5031 SvPV_set(sv, NULL); 5032 SvCUR_set(sv, 0); 5033 SvLEN_set(sv, 0); 5034 if (flags & SV_COW_DROP_PV) { 5035 /* OK, so we don't need to copy our buffer. */ 5036 SvPOK_off(sv); 5037 } else { 5038 SvGROW(sv, cur + 1); 5039 Move(pvx,SvPVX(sv),cur,char); 5040 SvCUR_set(sv, cur); 5041 *SvEND(sv) = '\0'; 5042 } 5043 if (len) { 5044 # ifdef PERL_OLD_COPY_ON_WRITE 5045 sv_release_COW(sv, pvx, next); 5046 # endif 5047 } else { 5048 unshare_hek(SvSHARED_HEK_FROM_PV(pvx)); 5049 } 5050 if (DEBUG_C_TEST) { 5051 sv_dump(sv); 5052 } 5053 } 5054 #else 5055 const char * const pvx = SvPVX_const(sv); 5056 const STRLEN len = SvCUR(sv); 5057 SvIsCOW_off(sv); 5058 SvPV_set(sv, NULL); 5059 SvLEN_set(sv, 0); 5060 if (flags & SV_COW_DROP_PV) { 5061 /* OK, so we don't need to copy our buffer. */ 5062 SvPOK_off(sv); 5063 } else { 5064 SvGROW(sv, len + 1); 5065 Move(pvx,SvPVX(sv),len,char); 5066 *SvEND(sv) = '\0'; 5067 } 5068 unshare_hek(SvSHARED_HEK_FROM_PV(pvx)); 5069 #endif 5070 } 5071 } 5072 5073 void 5074 Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags) 5075 { 5076 PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS; 5077 5078 if (SvREADONLY(sv)) 5079 Perl_croak_no_modify(); 5080 else if (SvIsCOW(sv)) 5081 S_sv_uncow(aTHX_ sv, flags); 5082 if (SvROK(sv)) 5083 sv_unref_flags(sv, flags); 5084 else if (SvFAKE(sv) && isGV_with_GP(sv)) 5085 sv_unglob(sv, flags); 5086 else if (SvFAKE(sv) && isREGEXP(sv)) { 5087 /* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous 5088 to sv_unglob. We only need it here, so inline it. */ 5089 const bool islv = SvTYPE(sv) == SVt_PVLV; 5090 const svtype new_type = 5091 islv ? SVt_NULL : SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV; 5092 SV *const temp = newSV_type(new_type); 5093 regexp *const temp_p = ReANY((REGEXP *)sv); 5094 5095 if (new_type == SVt_PVMG) { 5096 SvMAGIC_set(temp, SvMAGIC(sv)); 5097 SvMAGIC_set(sv, NULL); 5098 SvSTASH_set(temp, SvSTASH(sv)); 5099 SvSTASH_set(sv, NULL); 5100 } 5101 if (!islv) SvCUR_set(temp, SvCUR(sv)); 5102 /* Remember that SvPVX is in the head, not the body. But 5103 RX_WRAPPED is in the body. */ 5104 assert(ReANY((REGEXP *)sv)->mother_re); 5105 /* Their buffer is already owned by someone else. */ 5106 if (flags & SV_COW_DROP_PV) { 5107 /* SvLEN is already 0. For SVt_REGEXP, we have a brand new 5108 zeroed body. For SVt_PVLV, it should have been set to 0 5109 before turning into a regexp. */ 5110 assert(!SvLEN(islv ? sv : temp)); 5111 sv->sv_u.svu_pv = 0; 5112 } 5113 else { 5114 sv->sv_u.svu_pv = savepvn(RX_WRAPPED((REGEXP *)sv), SvCUR(sv)); 5115 SvLEN_set(islv ? sv : temp, SvCUR(sv)+1); 5116 SvPOK_on(sv); 5117 } 5118 5119 /* Now swap the rest of the bodies. */ 5120 5121 SvFAKE_off(sv); 5122 if (!islv) { 5123 SvFLAGS(sv) &= ~SVTYPEMASK; 5124 SvFLAGS(sv) |= new_type; 5125 SvANY(sv) = SvANY(temp); 5126 } 5127 5128 SvFLAGS(temp) &= ~(SVTYPEMASK); 5129 SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE; 5130 SvANY(temp) = temp_p; 5131 temp->sv_u.svu_rx = (regexp *)temp_p; 5132 5133 SvREFCNT_dec_NN(temp); 5134 } 5135 else if (SvVOK(sv)) sv_unmagic(sv, PERL_MAGIC_vstring); 5136 } 5137 5138 /* 5139 =for apidoc sv_chop 5140 5141 Efficient removal of characters from the beginning of the string buffer. 5142 SvPOK(sv), or at least SvPOKp(sv), must be true and the C<ptr> must be a 5143 pointer to somewhere inside the string buffer. The C<ptr> becomes the first 5144 character of the adjusted string. Uses the "OOK hack". On return, only 5145 SvPOK(sv) and SvPOKp(sv) among the OK flags will be true. 5146 5147 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer 5148 refer to the same chunk of data. 5149 5150 The unfortunate similarity of this function's name to that of Perl's C<chop> 5151 operator is strictly coincidental. This function works from the left; 5152 C<chop> works from the right. 5153 5154 =cut 5155 */ 5156 5157 void 5158 Perl_sv_chop(pTHX_ SV *const sv, const char *const ptr) 5159 { 5160 STRLEN delta; 5161 STRLEN old_delta; 5162 U8 *p; 5163 #ifdef DEBUGGING 5164 const U8 *evacp; 5165 STRLEN evacn; 5166 #endif 5167 STRLEN max_delta; 5168 5169 PERL_ARGS_ASSERT_SV_CHOP; 5170 5171 if (!ptr || !SvPOKp(sv)) 5172 return; 5173 delta = ptr - SvPVX_const(sv); 5174 if (!delta) { 5175 /* Nothing to do. */ 5176 return; 5177 } 5178 max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv); 5179 if (delta > max_delta) 5180 Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p", 5181 ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta); 5182 /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), so don't use ptr any more */ 5183 SV_CHECK_THINKFIRST(sv); 5184 SvPOK_only_UTF8(sv); 5185 5186 if (!SvOOK(sv)) { 5187 if (!SvLEN(sv)) { /* make copy of shared string */ 5188 const char *pvx = SvPVX_const(sv); 5189 const STRLEN len = SvCUR(sv); 5190 SvGROW(sv, len + 1); 5191 Move(pvx,SvPVX(sv),len,char); 5192 *SvEND(sv) = '\0'; 5193 } 5194 SvOOK_on(sv); 5195 old_delta = 0; 5196 } else { 5197 SvOOK_offset(sv, old_delta); 5198 } 5199 SvLEN_set(sv, SvLEN(sv) - delta); 5200 SvCUR_set(sv, SvCUR(sv) - delta); 5201 SvPV_set(sv, SvPVX(sv) + delta); 5202 5203 p = (U8 *)SvPVX_const(sv); 5204 5205 #ifdef DEBUGGING 5206 /* how many bytes were evacuated? we will fill them with sentinel 5207 bytes, except for the part holding the new offset of course. */ 5208 evacn = delta; 5209 if (old_delta) 5210 evacn += (old_delta < 0x100 ? 1 : 1 + sizeof(STRLEN)); 5211 assert(evacn); 5212 assert(evacn <= delta + old_delta); 5213 evacp = p - evacn; 5214 #endif 5215 5216 /* This sets 'delta' to the accumulated value of all deltas so far */ 5217 delta += old_delta; 5218 assert(delta); 5219 5220 /* If 'delta' fits in a byte, store it just prior to the new beginning of 5221 * the string; otherwise store a 0 byte there and store 'delta' just prior 5222 * to that, using as many bytes as a STRLEN occupies. Thus it overwrites a 5223 * portion of the chopped part of the string */ 5224 if (delta < 0x100) { 5225 *--p = (U8) delta; 5226 } else { 5227 *--p = 0; 5228 p -= sizeof(STRLEN); 5229 Copy((U8*)&delta, p, sizeof(STRLEN), U8); 5230 } 5231 5232 #ifdef DEBUGGING 5233 /* Fill the preceding buffer with sentinals to verify that no-one is 5234 using it. */ 5235 while (p > evacp) { 5236 --p; 5237 *p = (U8)PTR2UV(p); 5238 } 5239 #endif 5240 } 5241 5242 /* 5243 =for apidoc sv_catpvn 5244 5245 Concatenates the string onto the end of the string which is in the SV. The 5246 C<len> indicates number of bytes to copy. If the SV has the UTF-8 5247 status set, then the bytes appended should be valid UTF-8. 5248 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>. 5249 5250 =for apidoc sv_catpvn_flags 5251 5252 Concatenates the string onto the end of the string which is in the SV. The 5253 C<len> indicates number of bytes to copy. If the SV has the UTF-8 5254 status set, then the bytes appended should be valid UTF-8. 5255 If C<flags> has the C<SV_SMAGIC> bit set, will 5256 C<mg_set> on C<dsv> afterwards if appropriate. 5257 C<sv_catpvn> and C<sv_catpvn_nomg> are implemented 5258 in terms of this function. 5259 5260 =cut 5261 */ 5262 5263 void 5264 Perl_sv_catpvn_flags(pTHX_ SV *const dsv, const char *sstr, const STRLEN slen, const I32 flags) 5265 { 5266 dVAR; 5267 STRLEN dlen; 5268 const char * const dstr = SvPV_force_flags(dsv, dlen, flags); 5269 5270 PERL_ARGS_ASSERT_SV_CATPVN_FLAGS; 5271 assert((flags & (SV_CATBYTES|SV_CATUTF8)) != (SV_CATBYTES|SV_CATUTF8)); 5272 5273 if (!(flags & SV_CATBYTES) || !SvUTF8(dsv)) { 5274 if (flags & SV_CATUTF8 && !SvUTF8(dsv)) { 5275 sv_utf8_upgrade_flags_grow(dsv, 0, slen + 1); 5276 dlen = SvCUR(dsv); 5277 } 5278 else SvGROW(dsv, dlen + slen + 1); 5279 if (sstr == dstr) 5280 sstr = SvPVX_const(dsv); 5281 Move(sstr, SvPVX(dsv) + dlen, slen, char); 5282 SvCUR_set(dsv, SvCUR(dsv) + slen); 5283 } 5284 else { 5285 /* We inline bytes_to_utf8, to avoid an extra malloc. */ 5286 const char * const send = sstr + slen; 5287 U8 *d; 5288 5289 /* Something this code does not account for, which I think is 5290 impossible; it would require the same pv to be treated as 5291 bytes *and* utf8, which would indicate a bug elsewhere. */ 5292 assert(sstr != dstr); 5293 5294 SvGROW(dsv, dlen + slen * 2 + 1); 5295 d = (U8 *)SvPVX(dsv) + dlen; 5296 5297 while (sstr < send) { 5298 append_utf8_from_native_byte(*sstr, &d); 5299 sstr++; 5300 } 5301 SvCUR_set(dsv, d-(const U8 *)SvPVX(dsv)); 5302 } 5303 *SvEND(dsv) = '\0'; 5304 (void)SvPOK_only_UTF8(dsv); /* validate pointer */ 5305 SvTAINT(dsv); 5306 if (flags & SV_SMAGIC) 5307 SvSETMAGIC(dsv); 5308 } 5309 5310 /* 5311 =for apidoc sv_catsv 5312 5313 Concatenates the string from SV C<ssv> onto the end of the string in SV 5314 C<dsv>. If C<ssv> is null, does nothing; otherwise modifies only C<dsv>. 5315 Handles 'get' magic on both SVs, but no 'set' magic. See C<sv_catsv_mg> and 5316 C<sv_catsv_nomg>. 5317 5318 =for apidoc sv_catsv_flags 5319 5320 Concatenates the string from SV C<ssv> onto the end of the string in SV 5321 C<dsv>. If C<ssv> is null, does nothing; otherwise modifies only C<dsv>. 5322 If C<flags> include C<SV_GMAGIC> bit set, will call C<mg_get> on both SVs if 5323 appropriate. If C<flags> include C<SV_SMAGIC>, C<mg_set> will be called on 5324 the modified SV afterward, if appropriate. C<sv_catsv>, C<sv_catsv_nomg>, 5325 and C<sv_catsv_mg> are implemented in terms of this function. 5326 5327 =cut */ 5328 5329 void 5330 Perl_sv_catsv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags) 5331 { 5332 dVAR; 5333 5334 PERL_ARGS_ASSERT_SV_CATSV_FLAGS; 5335 5336 if (ssv) { 5337 STRLEN slen; 5338 const char *spv = SvPV_flags_const(ssv, slen, flags); 5339 if (spv) { 5340 if (flags & SV_GMAGIC) 5341 SvGETMAGIC(dsv); 5342 sv_catpvn_flags(dsv, spv, slen, 5343 DO_UTF8(ssv) ? SV_CATUTF8 : SV_CATBYTES); 5344 if (flags & SV_SMAGIC) 5345 SvSETMAGIC(dsv); 5346 } 5347 } 5348 } 5349 5350 /* 5351 =for apidoc sv_catpv 5352 5353 Concatenates the C<NUL>-terminated string onto the end of the string which is 5354 in the SV. 5355 If the SV has the UTF-8 status set, then the bytes appended should be 5356 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>. 5357 5358 =cut */ 5359 5360 void 5361 Perl_sv_catpv(pTHX_ SV *const sv, const char *ptr) 5362 { 5363 dVAR; 5364 STRLEN len; 5365 STRLEN tlen; 5366 char *junk; 5367 5368 PERL_ARGS_ASSERT_SV_CATPV; 5369 5370 if (!ptr) 5371 return; 5372 junk = SvPV_force(sv, tlen); 5373 len = strlen(ptr); 5374 SvGROW(sv, tlen + len + 1); 5375 if (ptr == junk) 5376 ptr = SvPVX_const(sv); 5377 Move(ptr,SvPVX(sv)+tlen,len+1,char); 5378 SvCUR_set(sv, SvCUR(sv) + len); 5379 (void)SvPOK_only_UTF8(sv); /* validate pointer */ 5380 SvTAINT(sv); 5381 } 5382 5383 /* 5384 =for apidoc sv_catpv_flags 5385 5386 Concatenates the C<NUL>-terminated string onto the end of the string which is 5387 in the SV. 5388 If the SV has the UTF-8 status set, then the bytes appended should 5389 be valid UTF-8. If C<flags> has the C<SV_SMAGIC> bit set, will C<mg_set> 5390 on the modified SV if appropriate. 5391 5392 =cut 5393 */ 5394 5395 void 5396 Perl_sv_catpv_flags(pTHX_ SV *dstr, const char *sstr, const I32 flags) 5397 { 5398 PERL_ARGS_ASSERT_SV_CATPV_FLAGS; 5399 sv_catpvn_flags(dstr, sstr, strlen(sstr), flags); 5400 } 5401 5402 /* 5403 =for apidoc sv_catpv_mg 5404 5405 Like C<sv_catpv>, but also handles 'set' magic. 5406 5407 =cut 5408 */ 5409 5410 void 5411 Perl_sv_catpv_mg(pTHX_ SV *const sv, const char *const ptr) 5412 { 5413 PERL_ARGS_ASSERT_SV_CATPV_MG; 5414 5415 sv_catpv(sv,ptr); 5416 SvSETMAGIC(sv); 5417 } 5418 5419 /* 5420 =for apidoc newSV 5421 5422 Creates a new SV. A non-zero C<len> parameter indicates the number of 5423 bytes of preallocated string space the SV should have. An extra byte for a 5424 trailing C<NUL> is also reserved. (SvPOK is not set for the SV even if string 5425 space is allocated.) The reference count for the new SV is set to 1. 5426 5427 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first 5428 parameter, I<x>, a debug aid which allowed callers to identify themselves. 5429 This aid has been superseded by a new build option, PERL_MEM_LOG (see 5430 L<perlhacktips/PERL_MEM_LOG>). The older API is still there for use in XS 5431 modules supporting older perls. 5432 5433 =cut 5434 */ 5435 5436 SV * 5437 Perl_newSV(pTHX_ const STRLEN len) 5438 { 5439 dVAR; 5440 SV *sv; 5441 5442 new_SV(sv); 5443 if (len) { 5444 sv_upgrade(sv, SVt_PV); 5445 SvGROW(sv, len + 1); 5446 } 5447 return sv; 5448 } 5449 /* 5450 =for apidoc sv_magicext 5451 5452 Adds magic to an SV, upgrading it if necessary. Applies the 5453 supplied vtable and returns a pointer to the magic added. 5454 5455 Note that C<sv_magicext> will allow things that C<sv_magic> will not. 5456 In particular, you can add magic to SvREADONLY SVs, and add more than 5457 one instance of the same 'how'. 5458 5459 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is 5460 stored, if C<namlen> is zero then C<name> is stored as-is and - as another 5461 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed 5462 to contain an C<SV*> and is stored as-is with its REFCNT incremented. 5463 5464 (This is now used as a subroutine by C<sv_magic>.) 5465 5466 =cut 5467 */ 5468 MAGIC * 5469 Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how, 5470 const MGVTBL *const vtable, const char *const name, const I32 namlen) 5471 { 5472 dVAR; 5473 MAGIC* mg; 5474 5475 PERL_ARGS_ASSERT_SV_MAGICEXT; 5476 5477 if (SvTYPE(sv)==SVt_PVAV) { assert (!AvPAD_NAMELIST(sv)); } 5478 5479 SvUPGRADE(sv, SVt_PVMG); 5480 Newxz(mg, 1, MAGIC); 5481 mg->mg_moremagic = SvMAGIC(sv); 5482 SvMAGIC_set(sv, mg); 5483 5484 /* Sometimes a magic contains a reference loop, where the sv and 5485 object refer to each other. To prevent a reference loop that 5486 would prevent such objects being freed, we look for such loops 5487 and if we find one we avoid incrementing the object refcount. 5488 5489 Note we cannot do this to avoid self-tie loops as intervening RV must 5490 have its REFCNT incremented to keep it in existence. 5491 5492 */ 5493 if (!obj || obj == sv || 5494 how == PERL_MAGIC_arylen || 5495 how == PERL_MAGIC_symtab || 5496 (SvTYPE(obj) == SVt_PVGV && 5497 (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv 5498 || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv 5499 || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv))) 5500 { 5501 mg->mg_obj = obj; 5502 } 5503 else { 5504 mg->mg_obj = SvREFCNT_inc_simple(obj); 5505 mg->mg_flags |= MGf_REFCOUNTED; 5506 } 5507 5508 /* Normal self-ties simply pass a null object, and instead of 5509 using mg_obj directly, use the SvTIED_obj macro to produce a 5510 new RV as needed. For glob "self-ties", we are tieing the PVIO 5511 with an RV obj pointing to the glob containing the PVIO. In 5512 this case, to avoid a reference loop, we need to weaken the 5513 reference. 5514 */ 5515 5516 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO && 5517 obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv) 5518 { 5519 sv_rvweaken(obj); 5520 } 5521 5522 mg->mg_type = how; 5523 mg->mg_len = namlen; 5524 if (name) { 5525 if (namlen > 0) 5526 mg->mg_ptr = savepvn(name, namlen); 5527 else if (namlen == HEf_SVKEY) { 5528 /* Yes, this is casting away const. This is only for the case of 5529 HEf_SVKEY. I think we need to document this aberation of the 5530 constness of the API, rather than making name non-const, as 5531 that change propagating outwards a long way. */ 5532 mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name); 5533 } else 5534 mg->mg_ptr = (char *) name; 5535 } 5536 mg->mg_virtual = (MGVTBL *) vtable; 5537 5538 mg_magical(sv); 5539 return mg; 5540 } 5541 5542 MAGIC * 5543 Perl_sv_magicext_mglob(pTHX_ SV *sv) 5544 { 5545 PERL_ARGS_ASSERT_SV_MAGICEXT_MGLOB; 5546 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') { 5547 /* This sv is only a delegate. //g magic must be attached to 5548 its target. */ 5549 vivify_defelem(sv); 5550 sv = LvTARG(sv); 5551 } 5552 #ifdef PERL_OLD_COPY_ON_WRITE 5553 if (SvIsCOW(sv)) 5554 sv_force_normal_flags(sv, 0); 5555 #endif 5556 return sv_magicext(sv, NULL, PERL_MAGIC_regex_global, 5557 &PL_vtbl_mglob, 0, 0); 5558 } 5559 5560 /* 5561 =for apidoc sv_magic 5562 5563 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if 5564 necessary, then adds a new magic item of type C<how> to the head of the 5565 magic list. 5566 5567 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the 5568 handling of the C<name> and C<namlen> arguments. 5569 5570 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also 5571 to add more than one instance of the same 'how'. 5572 5573 =cut 5574 */ 5575 5576 void 5577 Perl_sv_magic(pTHX_ SV *const sv, SV *const obj, const int how, 5578 const char *const name, const I32 namlen) 5579 { 5580 dVAR; 5581 const MGVTBL *vtable; 5582 MAGIC* mg; 5583 unsigned int flags; 5584 unsigned int vtable_index; 5585 5586 PERL_ARGS_ASSERT_SV_MAGIC; 5587 5588 if (how < 0 || (unsigned)how >= C_ARRAY_LENGTH(PL_magic_data) 5589 || ((flags = PL_magic_data[how]), 5590 (vtable_index = flags & PERL_MAGIC_VTABLE_MASK) 5591 > magic_vtable_max)) 5592 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how); 5593 5594 /* PERL_MAGIC_ext is reserved for use by extensions not perl internals. 5595 Useful for attaching extension internal data to perl vars. 5596 Note that multiple extensions may clash if magical scalars 5597 etc holding private data from one are passed to another. */ 5598 5599 vtable = (vtable_index == magic_vtable_max) 5600 ? NULL : PL_magic_vtables + vtable_index; 5601 5602 #ifdef PERL_OLD_COPY_ON_WRITE 5603 if (SvIsCOW(sv)) 5604 sv_force_normal_flags(sv, 0); 5605 #endif 5606 if (SvREADONLY(sv)) { 5607 if ( 5608 !PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how) 5609 ) 5610 { 5611 Perl_croak_no_modify(); 5612 } 5613 } 5614 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) { 5615 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) { 5616 /* sv_magic() refuses to add a magic of the same 'how' as an 5617 existing one 5618 */ 5619 if (how == PERL_MAGIC_taint) 5620 mg->mg_len |= 1; 5621 return; 5622 } 5623 } 5624 5625 /* Force pos to be stored as characters, not bytes. */ 5626 if (SvMAGICAL(sv) && DO_UTF8(sv) 5627 && (mg = mg_find(sv, PERL_MAGIC_regex_global)) 5628 && mg->mg_len != -1 5629 && mg->mg_flags & MGf_BYTES) { 5630 mg->mg_len = (SSize_t)sv_pos_b2u_flags(sv, (STRLEN)mg->mg_len, 5631 SV_CONST_RETURN); 5632 mg->mg_flags &= ~MGf_BYTES; 5633 } 5634 5635 /* Rest of work is done else where */ 5636 mg = sv_magicext(sv,obj,how,vtable,name,namlen); 5637 5638 switch (how) { 5639 case PERL_MAGIC_taint: 5640 mg->mg_len = 1; 5641 break; 5642 case PERL_MAGIC_ext: 5643 case PERL_MAGIC_dbfile: 5644 SvRMAGICAL_on(sv); 5645 break; 5646 } 5647 } 5648 5649 static int 5650 S_sv_unmagicext_flags(pTHX_ SV *const sv, const int type, MGVTBL *vtbl, const U32 flags) 5651 { 5652 MAGIC* mg; 5653 MAGIC** mgp; 5654 5655 assert(flags <= 1); 5656 5657 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv)) 5658 return 0; 5659 mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic); 5660 for (mg = *mgp; mg; mg = *mgp) { 5661 const MGVTBL* const virt = mg->mg_virtual; 5662 if (mg->mg_type == type && (!flags || virt == vtbl)) { 5663 *mgp = mg->mg_moremagic; 5664 if (virt && virt->svt_free) 5665 virt->svt_free(aTHX_ sv, mg); 5666 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { 5667 if (mg->mg_len > 0) 5668 Safefree(mg->mg_ptr); 5669 else if (mg->mg_len == HEf_SVKEY) 5670 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr)); 5671 else if (mg->mg_type == PERL_MAGIC_utf8) 5672 Safefree(mg->mg_ptr); 5673 } 5674 if (mg->mg_flags & MGf_REFCOUNTED) 5675 SvREFCNT_dec(mg->mg_obj); 5676 Safefree(mg); 5677 } 5678 else 5679 mgp = &mg->mg_moremagic; 5680 } 5681 if (SvMAGIC(sv)) { 5682 if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */ 5683 mg_magical(sv); /* else fix the flags now */ 5684 } 5685 else { 5686 SvMAGICAL_off(sv); 5687 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; 5688 } 5689 return 0; 5690 } 5691 5692 /* 5693 =for apidoc sv_unmagic 5694 5695 Removes all magic of type C<type> from an SV. 5696 5697 =cut 5698 */ 5699 5700 int 5701 Perl_sv_unmagic(pTHX_ SV *const sv, const int type) 5702 { 5703 PERL_ARGS_ASSERT_SV_UNMAGIC; 5704 return S_sv_unmagicext_flags(aTHX_ sv, type, NULL, 0); 5705 } 5706 5707 /* 5708 =for apidoc sv_unmagicext 5709 5710 Removes all magic of type C<type> with the specified C<vtbl> from an SV. 5711 5712 =cut 5713 */ 5714 5715 int 5716 Perl_sv_unmagicext(pTHX_ SV *const sv, const int type, MGVTBL *vtbl) 5717 { 5718 PERL_ARGS_ASSERT_SV_UNMAGICEXT; 5719 return S_sv_unmagicext_flags(aTHX_ sv, type, vtbl, 1); 5720 } 5721 5722 /* 5723 =for apidoc sv_rvweaken 5724 5725 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the 5726 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and 5727 push a back-reference to this RV onto the array of backreferences 5728 associated with that magic. If the RV is magical, set magic will be 5729 called after the RV is cleared. 5730 5731 =cut 5732 */ 5733 5734 SV * 5735 Perl_sv_rvweaken(pTHX_ SV *const sv) 5736 { 5737 SV *tsv; 5738 5739 PERL_ARGS_ASSERT_SV_RVWEAKEN; 5740 5741 if (!SvOK(sv)) /* let undefs pass */ 5742 return sv; 5743 if (!SvROK(sv)) 5744 Perl_croak(aTHX_ "Can't weaken a nonreference"); 5745 else if (SvWEAKREF(sv)) { 5746 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak"); 5747 return sv; 5748 } 5749 else if (SvREADONLY(sv)) croak_no_modify(); 5750 tsv = SvRV(sv); 5751 Perl_sv_add_backref(aTHX_ tsv, sv); 5752 SvWEAKREF_on(sv); 5753 SvREFCNT_dec_NN(tsv); 5754 return sv; 5755 } 5756 5757 /* Give tsv backref magic if it hasn't already got it, then push a 5758 * back-reference to sv onto the array associated with the backref magic. 5759 * 5760 * As an optimisation, if there's only one backref and it's not an AV, 5761 * store it directly in the HvAUX or mg_obj slot, avoiding the need to 5762 * allocate an AV. (Whether the slot holds an AV tells us whether this is 5763 * active.) 5764 */ 5765 5766 /* A discussion about the backreferences array and its refcount: 5767 * 5768 * The AV holding the backreferences is pointed to either as the mg_obj of 5769 * PERL_MAGIC_backref, or in the specific case of a HV, from the 5770 * xhv_backreferences field. The array is created with a refcount 5771 * of 2. This means that if during global destruction the array gets 5772 * picked on before its parent to have its refcount decremented by the 5773 * random zapper, it won't actually be freed, meaning it's still there for 5774 * when its parent gets freed. 5775 * 5776 * When the parent SV is freed, the extra ref is killed by 5777 * Perl_sv_kill_backrefs. The other ref is killed, in the case of magic, 5778 * by mg_free() / MGf_REFCOUNTED, or for a hash, by Perl_hv_kill_backrefs. 5779 * 5780 * When a single backref SV is stored directly, it is not reference 5781 * counted. 5782 */ 5783 5784 void 5785 Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv) 5786 { 5787 dVAR; 5788 SV **svp; 5789 AV *av = NULL; 5790 MAGIC *mg = NULL; 5791 5792 PERL_ARGS_ASSERT_SV_ADD_BACKREF; 5793 5794 /* find slot to store array or singleton backref */ 5795 5796 if (SvTYPE(tsv) == SVt_PVHV) { 5797 svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv)); 5798 } else { 5799 if (SvMAGICAL(tsv)) 5800 mg = mg_find(tsv, PERL_MAGIC_backref); 5801 if (!mg) 5802 mg = sv_magicext(tsv, NULL, PERL_MAGIC_backref, &PL_vtbl_backref, NULL, 0); 5803 svp = &(mg->mg_obj); 5804 } 5805 5806 /* create or retrieve the array */ 5807 5808 if ( (!*svp && SvTYPE(sv) == SVt_PVAV) 5809 || (*svp && SvTYPE(*svp) != SVt_PVAV) 5810 ) { 5811 /* create array */ 5812 if (mg) 5813 mg->mg_flags |= MGf_REFCOUNTED; 5814 av = newAV(); 5815 AvREAL_off(av); 5816 SvREFCNT_inc_simple_void_NN(av); 5817 /* av now has a refcnt of 2; see discussion above */ 5818 av_extend(av, *svp ? 2 : 1); 5819 if (*svp) { 5820 /* move single existing backref to the array */ 5821 AvARRAY(av)[++AvFILLp(av)] = *svp; /* av_push() */ 5822 } 5823 *svp = (SV*)av; 5824 } 5825 else { 5826 av = MUTABLE_AV(*svp); 5827 if (!av) { 5828 /* optimisation: store single backref directly in HvAUX or mg_obj */ 5829 *svp = sv; 5830 return; 5831 } 5832 assert(SvTYPE(av) == SVt_PVAV); 5833 if (AvFILLp(av) >= AvMAX(av)) { 5834 av_extend(av, AvFILLp(av)+1); 5835 } 5836 } 5837 /* push new backref */ 5838 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */ 5839 } 5840 5841 /* delete a back-reference to ourselves from the backref magic associated 5842 * with the SV we point to. 5843 */ 5844 5845 void 5846 Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv) 5847 { 5848 dVAR; 5849 SV **svp = NULL; 5850 5851 PERL_ARGS_ASSERT_SV_DEL_BACKREF; 5852 5853 if (SvTYPE(tsv) == SVt_PVHV) { 5854 if (SvOOK(tsv)) 5855 svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv)); 5856 } 5857 else if (SvIS_FREED(tsv) && PL_phase == PERL_PHASE_DESTRUCT) { 5858 /* It's possible for the the last (strong) reference to tsv to have 5859 become freed *before* the last thing holding a weak reference. 5860 If both survive longer than the backreferences array, then when 5861 the referent's reference count drops to 0 and it is freed, it's 5862 not able to chase the backreferences, so they aren't NULLed. 5863 5864 For example, a CV holds a weak reference to its stash. If both the 5865 CV and the stash survive longer than the backreferences array, 5866 and the CV gets picked for the SvBREAK() treatment first, 5867 *and* it turns out that the stash is only being kept alive because 5868 of an our variable in the pad of the CV, then midway during CV 5869 destruction the stash gets freed, but CvSTASH() isn't set to NULL. 5870 It ends up pointing to the freed HV. Hence it's chased in here, and 5871 if this block wasn't here, it would hit the !svp panic just below. 5872 5873 I don't believe that "better" destruction ordering is going to help 5874 here - during global destruction there's always going to be the 5875 chance that something goes out of order. We've tried to make it 5876 foolproof before, and it only resulted in evolutionary pressure on 5877 fools. Which made us look foolish for our hubris. :-( 5878 */ 5879 return; 5880 } 5881 else { 5882 MAGIC *const mg 5883 = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL; 5884 svp = mg ? &(mg->mg_obj) : NULL; 5885 } 5886 5887 if (!svp) 5888 Perl_croak(aTHX_ "panic: del_backref, svp=0"); 5889 if (!*svp) { 5890 /* It's possible that sv is being freed recursively part way through the 5891 freeing of tsv. If this happens, the backreferences array of tsv has 5892 already been freed, and so svp will be NULL. If this is the case, 5893 we should not panic. Instead, nothing needs doing, so return. */ 5894 if (PL_phase == PERL_PHASE_DESTRUCT && SvREFCNT(tsv) == 0) 5895 return; 5896 Perl_croak(aTHX_ "panic: del_backref, *svp=%p phase=%s refcnt=%" UVuf, 5897 *svp, PL_phase_names[PL_phase], (UV)SvREFCNT(tsv)); 5898 } 5899 5900 if (SvTYPE(*svp) == SVt_PVAV) { 5901 #ifdef DEBUGGING 5902 int count = 1; 5903 #endif 5904 AV * const av = (AV*)*svp; 5905 SSize_t fill; 5906 assert(!SvIS_FREED(av)); 5907 fill = AvFILLp(av); 5908 assert(fill > -1); 5909 svp = AvARRAY(av); 5910 /* for an SV with N weak references to it, if all those 5911 * weak refs are deleted, then sv_del_backref will be called 5912 * N times and O(N^2) compares will be done within the backref 5913 * array. To ameliorate this potential slowness, we: 5914 * 1) make sure this code is as tight as possible; 5915 * 2) when looking for SV, look for it at both the head and tail of the 5916 * array first before searching the rest, since some create/destroy 5917 * patterns will cause the backrefs to be freed in order. 5918 */ 5919 if (*svp == sv) { 5920 AvARRAY(av)++; 5921 AvMAX(av)--; 5922 } 5923 else { 5924 SV **p = &svp[fill]; 5925 SV *const topsv = *p; 5926 if (topsv != sv) { 5927 #ifdef DEBUGGING 5928 count = 0; 5929 #endif 5930 while (--p > svp) { 5931 if (*p == sv) { 5932 /* We weren't the last entry. 5933 An unordered list has this property that you 5934 can take the last element off the end to fill 5935 the hole, and it's still an unordered list :-) 5936 */ 5937 *p = topsv; 5938 #ifdef DEBUGGING 5939 count++; 5940 #else 5941 break; /* should only be one */ 5942 #endif 5943 } 5944 } 5945 } 5946 } 5947 assert(count ==1); 5948 AvFILLp(av) = fill-1; 5949 } 5950 else if (SvIS_FREED(*svp) && PL_phase == PERL_PHASE_DESTRUCT) { 5951 /* freed AV; skip */ 5952 } 5953 else { 5954 /* optimisation: only a single backref, stored directly */ 5955 if (*svp != sv) 5956 Perl_croak(aTHX_ "panic: del_backref, *svp=%p, sv=%p", *svp, sv); 5957 *svp = NULL; 5958 } 5959 5960 } 5961 5962 void 5963 Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av) 5964 { 5965 SV **svp; 5966 SV **last; 5967 bool is_array; 5968 5969 PERL_ARGS_ASSERT_SV_KILL_BACKREFS; 5970 5971 if (!av) 5972 return; 5973 5974 /* after multiple passes through Perl_sv_clean_all() for a thingy 5975 * that has badly leaked, the backref array may have gotten freed, 5976 * since we only protect it against 1 round of cleanup */ 5977 if (SvIS_FREED(av)) { 5978 if (PL_in_clean_all) /* All is fair */ 5979 return; 5980 Perl_croak(aTHX_ 5981 "panic: magic_killbackrefs (freed backref AV/SV)"); 5982 } 5983 5984 5985 is_array = (SvTYPE(av) == SVt_PVAV); 5986 if (is_array) { 5987 assert(!SvIS_FREED(av)); 5988 svp = AvARRAY(av); 5989 if (svp) 5990 last = svp + AvFILLp(av); 5991 } 5992 else { 5993 /* optimisation: only a single backref, stored directly */ 5994 svp = (SV**)&av; 5995 last = svp; 5996 } 5997 5998 if (svp) { 5999 while (svp <= last) { 6000 if (*svp) { 6001 SV *const referrer = *svp; 6002 if (SvWEAKREF(referrer)) { 6003 /* XXX Should we check that it hasn't changed? */ 6004 assert(SvROK(referrer)); 6005 SvRV_set(referrer, 0); 6006 SvOK_off(referrer); 6007 SvWEAKREF_off(referrer); 6008 SvSETMAGIC(referrer); 6009 } else if (SvTYPE(referrer) == SVt_PVGV || 6010 SvTYPE(referrer) == SVt_PVLV) { 6011 assert(SvTYPE(sv) == SVt_PVHV); /* stash backref */ 6012 /* You lookin' at me? */ 6013 assert(GvSTASH(referrer)); 6014 assert(GvSTASH(referrer) == (const HV *)sv); 6015 GvSTASH(referrer) = 0; 6016 } else if (SvTYPE(referrer) == SVt_PVCV || 6017 SvTYPE(referrer) == SVt_PVFM) { 6018 if (SvTYPE(sv) == SVt_PVHV) { /* stash backref */ 6019 /* You lookin' at me? */ 6020 assert(CvSTASH(referrer)); 6021 assert(CvSTASH(referrer) == (const HV *)sv); 6022 SvANY(MUTABLE_CV(referrer))->xcv_stash = 0; 6023 } 6024 else { 6025 assert(SvTYPE(sv) == SVt_PVGV); 6026 /* You lookin' at me? */ 6027 assert(CvGV(referrer)); 6028 assert(CvGV(referrer) == (const GV *)sv); 6029 anonymise_cv_maybe(MUTABLE_GV(sv), 6030 MUTABLE_CV(referrer)); 6031 } 6032 6033 } else { 6034 Perl_croak(aTHX_ 6035 "panic: magic_killbackrefs (flags=%"UVxf")", 6036 (UV)SvFLAGS(referrer)); 6037 } 6038 6039 if (is_array) 6040 *svp = NULL; 6041 } 6042 svp++; 6043 } 6044 } 6045 if (is_array) { 6046 AvFILLp(av) = -1; 6047 SvREFCNT_dec_NN(av); /* remove extra count added by sv_add_backref() */ 6048 } 6049 return; 6050 } 6051 6052 /* 6053 =for apidoc sv_insert 6054 6055 Inserts a string at the specified offset/length within the SV. Similar to 6056 the Perl substr() function. Handles get magic. 6057 6058 =for apidoc sv_insert_flags 6059 6060 Same as C<sv_insert>, but the extra C<flags> are passed to the 6061 C<SvPV_force_flags> that applies to C<bigstr>. 6062 6063 =cut 6064 */ 6065 6066 void 6067 Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags) 6068 { 6069 dVAR; 6070 char *big; 6071 char *mid; 6072 char *midend; 6073 char *bigend; 6074 SSize_t i; /* better be sizeof(STRLEN) or bad things happen */ 6075 STRLEN curlen; 6076 6077 PERL_ARGS_ASSERT_SV_INSERT_FLAGS; 6078 6079 if (!bigstr) 6080 Perl_croak(aTHX_ "Can't modify nonexistent substring"); 6081 SvPV_force_flags(bigstr, curlen, flags); 6082 (void)SvPOK_only_UTF8(bigstr); 6083 if (offset + len > curlen) { 6084 SvGROW(bigstr, offset+len+1); 6085 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char); 6086 SvCUR_set(bigstr, offset+len); 6087 } 6088 6089 SvTAINT(bigstr); 6090 i = littlelen - len; 6091 if (i > 0) { /* string might grow */ 6092 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1); 6093 mid = big + offset + len; 6094 midend = bigend = big + SvCUR(bigstr); 6095 bigend += i; 6096 *bigend = '\0'; 6097 while (midend > mid) /* shove everything down */ 6098 *--bigend = *--midend; 6099 Move(little,big+offset,littlelen,char); 6100 SvCUR_set(bigstr, SvCUR(bigstr) + i); 6101 SvSETMAGIC(bigstr); 6102 return; 6103 } 6104 else if (i == 0) { 6105 Move(little,SvPVX(bigstr)+offset,len,char); 6106 SvSETMAGIC(bigstr); 6107 return; 6108 } 6109 6110 big = SvPVX(bigstr); 6111 mid = big + offset; 6112 midend = mid + len; 6113 bigend = big + SvCUR(bigstr); 6114 6115 if (midend > bigend) 6116 Perl_croak(aTHX_ "panic: sv_insert, midend=%p, bigend=%p", 6117 midend, bigend); 6118 6119 if (mid - big > bigend - midend) { /* faster to shorten from end */ 6120 if (littlelen) { 6121 Move(little, mid, littlelen,char); 6122 mid += littlelen; 6123 } 6124 i = bigend - midend; 6125 if (i > 0) { 6126 Move(midend, mid, i,char); 6127 mid += i; 6128 } 6129 *mid = '\0'; 6130 SvCUR_set(bigstr, mid - big); 6131 } 6132 else if ((i = mid - big)) { /* faster from front */ 6133 midend -= littlelen; 6134 mid = midend; 6135 Move(big, midend - i, i, char); 6136 sv_chop(bigstr,midend-i); 6137 if (littlelen) 6138 Move(little, mid, littlelen,char); 6139 } 6140 else if (littlelen) { 6141 midend -= littlelen; 6142 sv_chop(bigstr,midend); 6143 Move(little,midend,littlelen,char); 6144 } 6145 else { 6146 sv_chop(bigstr,midend); 6147 } 6148 SvSETMAGIC(bigstr); 6149 } 6150 6151 /* 6152 =for apidoc sv_replace 6153 6154 Make the first argument a copy of the second, then delete the original. 6155 The target SV physically takes over ownership of the body of the source SV 6156 and inherits its flags; however, the target keeps any magic it owns, 6157 and any magic in the source is discarded. 6158 Note that this is a rather specialist SV copying operation; most of the 6159 time you'll want to use C<sv_setsv> or one of its many macro front-ends. 6160 6161 =cut 6162 */ 6163 6164 void 6165 Perl_sv_replace(pTHX_ SV *const sv, SV *const nsv) 6166 { 6167 dVAR; 6168 const U32 refcnt = SvREFCNT(sv); 6169 6170 PERL_ARGS_ASSERT_SV_REPLACE; 6171 6172 SV_CHECK_THINKFIRST_COW_DROP(sv); 6173 if (SvREFCNT(nsv) != 1) { 6174 Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace()" 6175 " (%" UVuf " != 1)", (UV) SvREFCNT(nsv)); 6176 } 6177 if (SvMAGICAL(sv)) { 6178 if (SvMAGICAL(nsv)) 6179 mg_free(nsv); 6180 else 6181 sv_upgrade(nsv, SVt_PVMG); 6182 SvMAGIC_set(nsv, SvMAGIC(sv)); 6183 SvFLAGS(nsv) |= SvMAGICAL(sv); 6184 SvMAGICAL_off(sv); 6185 SvMAGIC_set(sv, NULL); 6186 } 6187 SvREFCNT(sv) = 0; 6188 sv_clear(sv); 6189 assert(!SvREFCNT(sv)); 6190 #ifdef DEBUG_LEAKING_SCALARS 6191 sv->sv_flags = nsv->sv_flags; 6192 sv->sv_any = nsv->sv_any; 6193 sv->sv_refcnt = nsv->sv_refcnt; 6194 sv->sv_u = nsv->sv_u; 6195 #else 6196 StructCopy(nsv,sv,SV); 6197 #endif 6198 if(SvTYPE(sv) == SVt_IV) { 6199 SvANY(sv) 6200 = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv)); 6201 } 6202 6203 6204 #ifdef PERL_OLD_COPY_ON_WRITE 6205 if (SvIsCOW_normal(nsv)) { 6206 /* We need to follow the pointers around the loop to make the 6207 previous SV point to sv, rather than nsv. */ 6208 SV *next; 6209 SV *current = nsv; 6210 while ((next = SV_COW_NEXT_SV(current)) != nsv) { 6211 assert(next); 6212 current = next; 6213 assert(SvPVX_const(current) == SvPVX_const(nsv)); 6214 } 6215 /* Make the SV before us point to the SV after us. */ 6216 if (DEBUG_C_TEST) { 6217 PerlIO_printf(Perl_debug_log, "previous is\n"); 6218 sv_dump(current); 6219 PerlIO_printf(Perl_debug_log, 6220 "move it from 0x%"UVxf" to 0x%"UVxf"\n", 6221 (UV) SV_COW_NEXT_SV(current), (UV) sv); 6222 } 6223 SV_COW_NEXT_SV_SET(current, sv); 6224 } 6225 #endif 6226 SvREFCNT(sv) = refcnt; 6227 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */ 6228 SvREFCNT(nsv) = 0; 6229 del_SV(nsv); 6230 } 6231 6232 /* We're about to free a GV which has a CV that refers back to us. 6233 * If that CV will outlive us, make it anonymous (i.e. fix up its CvGV 6234 * field) */ 6235 6236 STATIC void 6237 S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv) 6238 { 6239 SV *gvname; 6240 GV *anongv; 6241 6242 PERL_ARGS_ASSERT_ANONYMISE_CV_MAYBE; 6243 6244 /* be assertive! */ 6245 assert(SvREFCNT(gv) == 0); 6246 assert(isGV(gv) && isGV_with_GP(gv)); 6247 assert(GvGP(gv)); 6248 assert(!CvANON(cv)); 6249 assert(CvGV(cv) == gv); 6250 assert(!CvNAMED(cv)); 6251 6252 /* will the CV shortly be freed by gp_free() ? */ 6253 if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) { 6254 SvANY(cv)->xcv_gv_u.xcv_gv = NULL; 6255 return; 6256 } 6257 6258 /* if not, anonymise: */ 6259 gvname = (GvSTASH(gv) && HvNAME(GvSTASH(gv)) && HvENAME(GvSTASH(gv))) 6260 ? newSVhek(HvENAME_HEK(GvSTASH(gv))) 6261 : newSVpvn_flags( "__ANON__", 8, 0 ); 6262 sv_catpvs(gvname, "::__ANON__"); 6263 anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV); 6264 SvREFCNT_dec_NN(gvname); 6265 6266 CvANON_on(cv); 6267 CvCVGV_RC_on(cv); 6268 SvANY(cv)->xcv_gv_u.xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv)); 6269 } 6270 6271 6272 /* 6273 =for apidoc sv_clear 6274 6275 Clear an SV: call any destructors, free up any memory used by the body, 6276 and free the body itself. The SV's head is I<not> freed, although 6277 its type is set to all 1's so that it won't inadvertently be assumed 6278 to be live during global destruction etc. 6279 This function should only be called when REFCNT is zero. Most of the time 6280 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>) 6281 instead. 6282 6283 =cut 6284 */ 6285 6286 void 6287 Perl_sv_clear(pTHX_ SV *const orig_sv) 6288 { 6289 dVAR; 6290 HV *stash; 6291 U32 type; 6292 const struct body_details *sv_type_details; 6293 SV* iter_sv = NULL; 6294 SV* next_sv = NULL; 6295 SV *sv = orig_sv; 6296 STRLEN hash_index; 6297 6298 PERL_ARGS_ASSERT_SV_CLEAR; 6299 6300 /* within this loop, sv is the SV currently being freed, and 6301 * iter_sv is the most recent AV or whatever that's being iterated 6302 * over to provide more SVs */ 6303 6304 while (sv) { 6305 6306 type = SvTYPE(sv); 6307 6308 assert(SvREFCNT(sv) == 0); 6309 assert(SvTYPE(sv) != (svtype)SVTYPEMASK); 6310 6311 if (type <= SVt_IV) { 6312 /* See the comment in sv.h about the collusion between this 6313 * early return and the overloading of the NULL slots in the 6314 * size table. */ 6315 if (SvROK(sv)) 6316 goto free_rv; 6317 SvFLAGS(sv) &= SVf_BREAK; 6318 SvFLAGS(sv) |= SVTYPEMASK; 6319 goto free_head; 6320 } 6321 6322 assert(!SvOBJECT(sv) || type >= SVt_PVMG); /* objs are always >= MG */ 6323 6324 if (type >= SVt_PVMG) { 6325 if (SvOBJECT(sv)) { 6326 if (!curse(sv, 1)) goto get_next_sv; 6327 type = SvTYPE(sv); /* destructor may have changed it */ 6328 } 6329 /* Free back-references before magic, in case the magic calls 6330 * Perl code that has weak references to sv. */ 6331 if (type == SVt_PVHV) { 6332 Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv)); 6333 if (SvMAGIC(sv)) 6334 mg_free(sv); 6335 } 6336 else if (type == SVt_PVMG && SvPAD_OUR(sv)) { 6337 SvREFCNT_dec(SvOURSTASH(sv)); 6338 } 6339 else if (type == SVt_PVAV && AvPAD_NAMELIST(sv)) { 6340 assert(!SvMAGICAL(sv)); 6341 } else if (SvMAGIC(sv)) { 6342 /* Free back-references before other types of magic. */ 6343 sv_unmagic(sv, PERL_MAGIC_backref); 6344 mg_free(sv); 6345 } 6346 SvMAGICAL_off(sv); 6347 if (type == SVt_PVMG && SvPAD_TYPED(sv)) 6348 SvREFCNT_dec(SvSTASH(sv)); 6349 } 6350 switch (type) { 6351 /* case SVt_INVLIST: */ 6352 case SVt_PVIO: 6353 if (IoIFP(sv) && 6354 IoIFP(sv) != PerlIO_stdin() && 6355 IoIFP(sv) != PerlIO_stdout() && 6356 IoIFP(sv) != PerlIO_stderr() && 6357 !(IoFLAGS(sv) & IOf_FAKE_DIRP)) 6358 { 6359 io_close(MUTABLE_IO(sv), FALSE); 6360 } 6361 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP)) 6362 PerlDir_close(IoDIRP(sv)); 6363 IoDIRP(sv) = (DIR*)NULL; 6364 Safefree(IoTOP_NAME(sv)); 6365 Safefree(IoFMT_NAME(sv)); 6366 Safefree(IoBOTTOM_NAME(sv)); 6367 if ((const GV *)sv == PL_statgv) 6368 PL_statgv = NULL; 6369 goto freescalar; 6370 case SVt_REGEXP: 6371 /* FIXME for plugins */ 6372 freeregexp: 6373 pregfree2((REGEXP*) sv); 6374 goto freescalar; 6375 case SVt_PVCV: 6376 case SVt_PVFM: 6377 cv_undef(MUTABLE_CV(sv)); 6378 /* If we're in a stash, we don't own a reference to it. 6379 * However it does have a back reference to us, which needs to 6380 * be cleared. */ 6381 if ((stash = CvSTASH(sv))) 6382 sv_del_backref(MUTABLE_SV(stash), sv); 6383 goto freescalar; 6384 case SVt_PVHV: 6385 if (PL_last_swash_hv == (const HV *)sv) { 6386 PL_last_swash_hv = NULL; 6387 } 6388 if (HvTOTALKEYS((HV*)sv) > 0) { 6389 const char *name; 6390 /* this statement should match the one at the beginning of 6391 * hv_undef_flags() */ 6392 if ( PL_phase != PERL_PHASE_DESTRUCT 6393 && (name = HvNAME((HV*)sv))) 6394 { 6395 if (PL_stashcache) { 6396 DEBUG_o(Perl_deb(aTHX_ "sv_clear clearing PL_stashcache for '%"SVf"'\n", 6397 sv)); 6398 (void)hv_deletehek(PL_stashcache, 6399 HvNAME_HEK((HV*)sv), G_DISCARD); 6400 } 6401 hv_name_set((HV*)sv, NULL, 0, 0); 6402 } 6403 6404 /* save old iter_sv in unused SvSTASH field */ 6405 assert(!SvOBJECT(sv)); 6406 SvSTASH(sv) = (HV*)iter_sv; 6407 iter_sv = sv; 6408 6409 /* save old hash_index in unused SvMAGIC field */ 6410 assert(!SvMAGICAL(sv)); 6411 assert(!SvMAGIC(sv)); 6412 ((XPVMG*) SvANY(sv))->xmg_u.xmg_hash_index = hash_index; 6413 hash_index = 0; 6414 6415 next_sv = Perl_hfree_next_entry(aTHX_ (HV*)sv, &hash_index); 6416 goto get_next_sv; /* process this new sv */ 6417 } 6418 /* free empty hash */ 6419 Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL); 6420 assert(!HvARRAY((HV*)sv)); 6421 break; 6422 case SVt_PVAV: 6423 { 6424 AV* av = MUTABLE_AV(sv); 6425 if (PL_comppad == av) { 6426 PL_comppad = NULL; 6427 PL_curpad = NULL; 6428 } 6429 if (AvREAL(av) && AvFILLp(av) > -1) { 6430 next_sv = AvARRAY(av)[AvFILLp(av)--]; 6431 /* save old iter_sv in top-most slot of AV, 6432 * and pray that it doesn't get wiped in the meantime */ 6433 AvARRAY(av)[AvMAX(av)] = iter_sv; 6434 iter_sv = sv; 6435 goto get_next_sv; /* process this new sv */ 6436 } 6437 Safefree(AvALLOC(av)); 6438 } 6439 6440 break; 6441 case SVt_PVLV: 6442 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */ 6443 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv))); 6444 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh; 6445 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv); 6446 } 6447 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */ 6448 SvREFCNT_dec(LvTARG(sv)); 6449 if (isREGEXP(sv)) goto freeregexp; 6450 case SVt_PVGV: 6451 if (isGV_with_GP(sv)) { 6452 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv))) 6453 && HvENAME_get(stash)) 6454 mro_method_changed_in(stash); 6455 gp_free(MUTABLE_GV(sv)); 6456 if (GvNAME_HEK(sv)) 6457 unshare_hek(GvNAME_HEK(sv)); 6458 /* If we're in a stash, we don't own a reference to it. 6459 * However it does have a back reference to us, which 6460 * needs to be cleared. */ 6461 if (!SvVALID(sv) && (stash = GvSTASH(sv))) 6462 sv_del_backref(MUTABLE_SV(stash), sv); 6463 } 6464 /* FIXME. There are probably more unreferenced pointers to SVs 6465 * in the interpreter struct that we should check and tidy in 6466 * a similar fashion to this: */ 6467 /* See also S_sv_unglob, which does the same thing. */ 6468 if ((const GV *)sv == PL_last_in_gv) 6469 PL_last_in_gv = NULL; 6470 else if ((const GV *)sv == PL_statgv) 6471 PL_statgv = NULL; 6472 else if ((const GV *)sv == PL_stderrgv) 6473 PL_stderrgv = NULL; 6474 case SVt_PVMG: 6475 case SVt_PVNV: 6476 case SVt_PVIV: 6477 case SVt_INVLIST: 6478 case SVt_PV: 6479 freescalar: 6480 /* Don't bother with SvOOK_off(sv); as we're only going to 6481 * free it. */ 6482 if (SvOOK(sv)) { 6483 STRLEN offset; 6484 SvOOK_offset(sv, offset); 6485 SvPV_set(sv, SvPVX_mutable(sv) - offset); 6486 /* Don't even bother with turning off the OOK flag. */ 6487 } 6488 if (SvROK(sv)) { 6489 free_rv: 6490 { 6491 SV * const target = SvRV(sv); 6492 if (SvWEAKREF(sv)) 6493 sv_del_backref(target, sv); 6494 else 6495 next_sv = target; 6496 } 6497 } 6498 #ifdef PERL_ANY_COW 6499 else if (SvPVX_const(sv) 6500 && !(SvTYPE(sv) == SVt_PVIO 6501 && !(IoFLAGS(sv) & IOf_FAKE_DIRP))) 6502 { 6503 if (SvIsCOW(sv)) { 6504 if (DEBUG_C_TEST) { 6505 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n"); 6506 sv_dump(sv); 6507 } 6508 if (SvLEN(sv)) { 6509 # ifdef PERL_OLD_COPY_ON_WRITE 6510 sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv)); 6511 # else 6512 if (CowREFCNT(sv)) { 6513 sv_buf_to_rw(sv); 6514 CowREFCNT(sv)--; 6515 sv_buf_to_ro(sv); 6516 SvLEN_set(sv, 0); 6517 } 6518 # endif 6519 } else { 6520 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv))); 6521 } 6522 6523 } 6524 # ifdef PERL_OLD_COPY_ON_WRITE 6525 else 6526 # endif 6527 if (SvLEN(sv)) { 6528 Safefree(SvPVX_mutable(sv)); 6529 } 6530 } 6531 #else 6532 else if (SvPVX_const(sv) && SvLEN(sv) 6533 && !(SvTYPE(sv) == SVt_PVIO 6534 && !(IoFLAGS(sv) & IOf_FAKE_DIRP))) 6535 Safefree(SvPVX_mutable(sv)); 6536 else if (SvPVX_const(sv) && SvIsCOW(sv)) { 6537 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv))); 6538 } 6539 #endif 6540 break; 6541 case SVt_NV: 6542 break; 6543 } 6544 6545 free_body: 6546 6547 SvFLAGS(sv) &= SVf_BREAK; 6548 SvFLAGS(sv) |= SVTYPEMASK; 6549 6550 sv_type_details = bodies_by_type + type; 6551 if (sv_type_details->arena) { 6552 del_body(((char *)SvANY(sv) + sv_type_details->offset), 6553 &PL_body_roots[type]); 6554 } 6555 else if (sv_type_details->body_size) { 6556 safefree(SvANY(sv)); 6557 } 6558 6559 free_head: 6560 /* caller is responsible for freeing the head of the original sv */ 6561 if (sv != orig_sv && !SvREFCNT(sv)) 6562 del_SV(sv); 6563 6564 /* grab and free next sv, if any */ 6565 get_next_sv: 6566 while (1) { 6567 sv = NULL; 6568 if (next_sv) { 6569 sv = next_sv; 6570 next_sv = NULL; 6571 } 6572 else if (!iter_sv) { 6573 break; 6574 } else if (SvTYPE(iter_sv) == SVt_PVAV) { 6575 AV *const av = (AV*)iter_sv; 6576 if (AvFILLp(av) > -1) { 6577 sv = AvARRAY(av)[AvFILLp(av)--]; 6578 } 6579 else { /* no more elements of current AV to free */ 6580 sv = iter_sv; 6581 type = SvTYPE(sv); 6582 /* restore previous value, squirrelled away */ 6583 iter_sv = AvARRAY(av)[AvMAX(av)]; 6584 Safefree(AvALLOC(av)); 6585 goto free_body; 6586 } 6587 } else if (SvTYPE(iter_sv) == SVt_PVHV) { 6588 sv = Perl_hfree_next_entry(aTHX_ (HV*)iter_sv, &hash_index); 6589 if (!sv && !HvTOTALKEYS((HV *)iter_sv)) { 6590 /* no more elements of current HV to free */ 6591 sv = iter_sv; 6592 type = SvTYPE(sv); 6593 /* Restore previous values of iter_sv and hash_index, 6594 * squirrelled away */ 6595 assert(!SvOBJECT(sv)); 6596 iter_sv = (SV*)SvSTASH(sv); 6597 assert(!SvMAGICAL(sv)); 6598 hash_index = ((XPVMG*) SvANY(sv))->xmg_u.xmg_hash_index; 6599 #ifdef DEBUGGING 6600 /* perl -DA does not like rubbish in SvMAGIC. */ 6601 SvMAGIC_set(sv, 0); 6602 #endif 6603 6604 /* free any remaining detritus from the hash struct */ 6605 Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL); 6606 assert(!HvARRAY((HV*)sv)); 6607 goto free_body; 6608 } 6609 } 6610 6611 /* unrolled SvREFCNT_dec and sv_free2 follows: */ 6612 6613 if (!sv) 6614 continue; 6615 if (!SvREFCNT(sv)) { 6616 sv_free(sv); 6617 continue; 6618 } 6619 if (--(SvREFCNT(sv))) 6620 continue; 6621 #ifdef DEBUGGING 6622 if (SvTEMP(sv)) { 6623 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), 6624 "Attempt to free temp prematurely: SV 0x%"UVxf 6625 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE); 6626 continue; 6627 } 6628 #endif 6629 if (SvIMMORTAL(sv)) { 6630 /* make sure SvREFCNT(sv)==0 happens very seldom */ 6631 SvREFCNT(sv) = SvREFCNT_IMMORTAL; 6632 continue; 6633 } 6634 break; 6635 } /* while 1 */ 6636 6637 } /* while sv */ 6638 } 6639 6640 /* This routine curses the sv itself, not the object referenced by sv. So 6641 sv does not have to be ROK. */ 6642 6643 static bool 6644 S_curse(pTHX_ SV * const sv, const bool check_refcnt) { 6645 dVAR; 6646 6647 PERL_ARGS_ASSERT_CURSE; 6648 assert(SvOBJECT(sv)); 6649 6650 if (PL_defstash && /* Still have a symbol table? */ 6651 SvDESTROYABLE(sv)) 6652 { 6653 dSP; 6654 HV* stash; 6655 do { 6656 stash = SvSTASH(sv); 6657 assert(SvTYPE(stash) == SVt_PVHV); 6658 if (HvNAME(stash)) { 6659 CV* destructor = NULL; 6660 assert (SvOOK(stash)); 6661 if (!SvOBJECT(stash)) destructor = (CV *)SvSTASH(stash); 6662 if (!destructor || HvMROMETA(stash)->destroy_gen 6663 != PL_sub_generation) 6664 { 6665 GV * const gv = 6666 gv_fetchmeth_autoload(stash, "DESTROY", 7, 0); 6667 if (gv) destructor = GvCV(gv); 6668 if (!SvOBJECT(stash)) 6669 { 6670 SvSTASH(stash) = 6671 destructor ? (HV *)destructor : ((HV *)0)+1; 6672 HvAUX(stash)->xhv_mro_meta->destroy_gen = 6673 PL_sub_generation; 6674 } 6675 } 6676 assert(!destructor || destructor == ((CV *)0)+1 6677 || SvTYPE(destructor) == SVt_PVCV); 6678 if (destructor && destructor != ((CV *)0)+1 6679 /* A constant subroutine can have no side effects, so 6680 don't bother calling it. */ 6681 && !CvCONST(destructor) 6682 /* Don't bother calling an empty destructor or one that 6683 returns immediately. */ 6684 && (CvISXSUB(destructor) 6685 || (CvSTART(destructor) 6686 && (CvSTART(destructor)->op_next->op_type 6687 != OP_LEAVESUB) 6688 && (CvSTART(destructor)->op_next->op_type 6689 != OP_PUSHMARK 6690 || CvSTART(destructor)->op_next->op_next->op_type 6691 != OP_RETURN 6692 ) 6693 )) 6694 ) 6695 { 6696 SV* const tmpref = newRV(sv); 6697 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */ 6698 ENTER; 6699 PUSHSTACKi(PERLSI_DESTROY); 6700 EXTEND(SP, 2); 6701 PUSHMARK(SP); 6702 PUSHs(tmpref); 6703 PUTBACK; 6704 call_sv(MUTABLE_SV(destructor), 6705 G_DISCARD|G_EVAL|G_KEEPERR|G_VOID); 6706 POPSTACK; 6707 SPAGAIN; 6708 LEAVE; 6709 if(SvREFCNT(tmpref) < 2) { 6710 /* tmpref is not kept alive! */ 6711 SvREFCNT(sv)--; 6712 SvRV_set(tmpref, NULL); 6713 SvROK_off(tmpref); 6714 } 6715 SvREFCNT_dec_NN(tmpref); 6716 } 6717 } 6718 } while (SvOBJECT(sv) && SvSTASH(sv) != stash); 6719 6720 6721 if (check_refcnt && SvREFCNT(sv)) { 6722 if (PL_in_clean_objs) 6723 Perl_croak(aTHX_ 6724 "DESTROY created new reference to dead object '%"HEKf"'", 6725 HEKfARG(HvNAME_HEK(stash))); 6726 /* DESTROY gave object new lease on life */ 6727 return FALSE; 6728 } 6729 } 6730 6731 if (SvOBJECT(sv)) { 6732 HV * const stash = SvSTASH(sv); 6733 /* Curse before freeing the stash, as freeing the stash could cause 6734 a recursive call into S_curse. */ 6735 SvOBJECT_off(sv); /* Curse the object. */ 6736 SvSTASH_set(sv,0); /* SvREFCNT_dec may try to read this */ 6737 SvREFCNT_dec(stash); /* possibly of changed persuasion */ 6738 } 6739 return TRUE; 6740 } 6741 6742 /* 6743 =for apidoc sv_newref 6744 6745 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper 6746 instead. 6747 6748 =cut 6749 */ 6750 6751 SV * 6752 Perl_sv_newref(pTHX_ SV *const sv) 6753 { 6754 PERL_UNUSED_CONTEXT; 6755 if (sv) 6756 (SvREFCNT(sv))++; 6757 return sv; 6758 } 6759 6760 /* 6761 =for apidoc sv_free 6762 6763 Decrement an SV's reference count, and if it drops to zero, call 6764 C<sv_clear> to invoke destructors and free up any memory used by 6765 the body; finally, deallocate the SV's head itself. 6766 Normally called via a wrapper macro C<SvREFCNT_dec>. 6767 6768 =cut 6769 */ 6770 6771 void 6772 Perl_sv_free(pTHX_ SV *const sv) 6773 { 6774 SvREFCNT_dec(sv); 6775 } 6776 6777 6778 /* Private helper function for SvREFCNT_dec(). 6779 * Called with rc set to original SvREFCNT(sv), where rc == 0 or 1 */ 6780 6781 void 6782 Perl_sv_free2(pTHX_ SV *const sv, const U32 rc) 6783 { 6784 dVAR; 6785 6786 PERL_ARGS_ASSERT_SV_FREE2; 6787 6788 if (LIKELY( rc == 1 )) { 6789 /* normal case */ 6790 SvREFCNT(sv) = 0; 6791 6792 #ifdef DEBUGGING 6793 if (SvTEMP(sv)) { 6794 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), 6795 "Attempt to free temp prematurely: SV 0x%"UVxf 6796 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE); 6797 return; 6798 } 6799 #endif 6800 if (SvIMMORTAL(sv)) { 6801 /* make sure SvREFCNT(sv)==0 happens very seldom */ 6802 SvREFCNT(sv) = SvREFCNT_IMMORTAL; 6803 return; 6804 } 6805 sv_clear(sv); 6806 if (! SvREFCNT(sv)) /* may have have been resurrected */ 6807 del_SV(sv); 6808 return; 6809 } 6810 6811 /* handle exceptional cases */ 6812 6813 assert(rc == 0); 6814 6815 if (SvFLAGS(sv) & SVf_BREAK) 6816 /* this SV's refcnt has been artificially decremented to 6817 * trigger cleanup */ 6818 return; 6819 if (PL_in_clean_all) /* All is fair */ 6820 return; 6821 if (SvIMMORTAL(sv)) { 6822 /* make sure SvREFCNT(sv)==0 happens very seldom */ 6823 SvREFCNT(sv) = SvREFCNT_IMMORTAL; 6824 return; 6825 } 6826 if (ckWARN_d(WARN_INTERNAL)) { 6827 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP 6828 Perl_dump_sv_child(aTHX_ sv); 6829 #else 6830 #ifdef DEBUG_LEAKING_SCALARS 6831 sv_dump(sv); 6832 #endif 6833 #ifdef DEBUG_LEAKING_SCALARS_ABORT 6834 if (PL_warnhook == PERL_WARNHOOK_FATAL 6835 || ckDEAD(packWARN(WARN_INTERNAL))) { 6836 /* Don't let Perl_warner cause us to escape our fate: */ 6837 abort(); 6838 } 6839 #endif 6840 /* This may not return: */ 6841 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), 6842 "Attempt to free unreferenced scalar: SV 0x%"UVxf 6843 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE); 6844 #endif 6845 } 6846 #ifdef DEBUG_LEAKING_SCALARS_ABORT 6847 abort(); 6848 #endif 6849 6850 } 6851 6852 6853 /* 6854 =for apidoc sv_len 6855 6856 Returns the length of the string in the SV. Handles magic and type 6857 coercion and sets the UTF8 flag appropriately. See also C<SvCUR>, which 6858 gives raw access to the xpv_cur slot. 6859 6860 =cut 6861 */ 6862 6863 STRLEN 6864 Perl_sv_len(pTHX_ SV *const sv) 6865 { 6866 STRLEN len; 6867 6868 if (!sv) 6869 return 0; 6870 6871 (void)SvPV_const(sv, len); 6872 return len; 6873 } 6874 6875 /* 6876 =for apidoc sv_len_utf8 6877 6878 Returns the number of characters in the string in an SV, counting wide 6879 UTF-8 bytes as a single character. Handles magic and type coercion. 6880 6881 =cut 6882 */ 6883 6884 /* 6885 * The length is cached in PERL_MAGIC_utf8, in the mg_len field. Also the 6886 * mg_ptr is used, by sv_pos_u2b() and sv_pos_b2u() - see the comments below. 6887 * (Note that the mg_len is not the length of the mg_ptr field. 6888 * This allows the cache to store the character length of the string without 6889 * needing to malloc() extra storage to attach to the mg_ptr.) 6890 * 6891 */ 6892 6893 STRLEN 6894 Perl_sv_len_utf8(pTHX_ SV *const sv) 6895 { 6896 if (!sv) 6897 return 0; 6898 6899 SvGETMAGIC(sv); 6900 return sv_len_utf8_nomg(sv); 6901 } 6902 6903 STRLEN 6904 Perl_sv_len_utf8_nomg(pTHX_ SV * const sv) 6905 { 6906 dVAR; 6907 STRLEN len; 6908 const U8 *s = (U8*)SvPV_nomg_const(sv, len); 6909 6910 PERL_ARGS_ASSERT_SV_LEN_UTF8_NOMG; 6911 6912 if (PL_utf8cache && SvUTF8(sv)) { 6913 STRLEN ulen; 6914 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL; 6915 6916 if (mg && (mg->mg_len != -1 || mg->mg_ptr)) { 6917 if (mg->mg_len != -1) 6918 ulen = mg->mg_len; 6919 else { 6920 /* We can use the offset cache for a headstart. 6921 The longer value is stored in the first pair. */ 6922 STRLEN *cache = (STRLEN *) mg->mg_ptr; 6923 6924 ulen = cache[0] + Perl_utf8_length(aTHX_ s + cache[1], 6925 s + len); 6926 } 6927 6928 if (PL_utf8cache < 0) { 6929 const STRLEN real = Perl_utf8_length(aTHX_ s, s + len); 6930 assert_uft8_cache_coherent("sv_len_utf8", ulen, real, sv); 6931 } 6932 } 6933 else { 6934 ulen = Perl_utf8_length(aTHX_ s, s + len); 6935 utf8_mg_len_cache_update(sv, &mg, ulen); 6936 } 6937 return ulen; 6938 } 6939 return SvUTF8(sv) ? Perl_utf8_length(aTHX_ s, s + len) : len; 6940 } 6941 6942 /* Walk forwards to find the byte corresponding to the passed in UTF-8 6943 offset. */ 6944 static STRLEN 6945 S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send, 6946 STRLEN *const uoffset_p, bool *const at_end) 6947 { 6948 const U8 *s = start; 6949 STRLEN uoffset = *uoffset_p; 6950 6951 PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS; 6952 6953 while (s < send && uoffset) { 6954 --uoffset; 6955 s += UTF8SKIP(s); 6956 } 6957 if (s == send) { 6958 *at_end = TRUE; 6959 } 6960 else if (s > send) { 6961 *at_end = TRUE; 6962 /* This is the existing behaviour. Possibly it should be a croak, as 6963 it's actually a bounds error */ 6964 s = send; 6965 } 6966 *uoffset_p -= uoffset; 6967 return s - start; 6968 } 6969 6970 /* Given the length of the string in both bytes and UTF-8 characters, decide 6971 whether to walk forwards or backwards to find the byte corresponding to 6972 the passed in UTF-8 offset. */ 6973 static STRLEN 6974 S_sv_pos_u2b_midway(const U8 *const start, const U8 *send, 6975 STRLEN uoffset, const STRLEN uend) 6976 { 6977 STRLEN backw = uend - uoffset; 6978 6979 PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY; 6980 6981 if (uoffset < 2 * backw) { 6982 /* The assumption is that going forwards is twice the speed of going 6983 forward (that's where the 2 * backw comes from). 6984 (The real figure of course depends on the UTF-8 data.) */ 6985 const U8 *s = start; 6986 6987 while (s < send && uoffset--) 6988 s += UTF8SKIP(s); 6989 assert (s <= send); 6990 if (s > send) 6991 s = send; 6992 return s - start; 6993 } 6994 6995 while (backw--) { 6996 send--; 6997 while (UTF8_IS_CONTINUATION(*send)) 6998 send--; 6999 } 7000 return send - start; 7001 } 7002 7003 /* For the string representation of the given scalar, find the byte 7004 corresponding to the passed in UTF-8 offset. uoffset0 and boffset0 7005 give another position in the string, *before* the sought offset, which 7006 (which is always true, as 0, 0 is a valid pair of positions), which should 7007 help reduce the amount of linear searching. 7008 If *mgp is non-NULL, it should point to the UTF-8 cache magic, which 7009 will be used to reduce the amount of linear searching. The cache will be 7010 created if necessary, and the found value offered to it for update. */ 7011 static STRLEN 7012 S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start, 7013 const U8 *const send, STRLEN uoffset, 7014 STRLEN uoffset0, STRLEN boffset0) 7015 { 7016 STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy. */ 7017 bool found = FALSE; 7018 bool at_end = FALSE; 7019 7020 PERL_ARGS_ASSERT_SV_POS_U2B_CACHED; 7021 7022 assert (uoffset >= uoffset0); 7023 7024 if (!uoffset) 7025 return 0; 7026 7027 if (!SvREADONLY(sv) && !SvGMAGICAL(sv) && SvPOK(sv) 7028 && PL_utf8cache 7029 && (*mgp || (SvTYPE(sv) >= SVt_PVMG && 7030 (*mgp = mg_find(sv, PERL_MAGIC_utf8))))) { 7031 if ((*mgp)->mg_ptr) { 7032 STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr; 7033 if (cache[0] == uoffset) { 7034 /* An exact match. */ 7035 return cache[1]; 7036 } 7037 if (cache[2] == uoffset) { 7038 /* An exact match. */ 7039 return cache[3]; 7040 } 7041 7042 if (cache[0] < uoffset) { 7043 /* The cache already knows part of the way. */ 7044 if (cache[0] > uoffset0) { 7045 /* The cache knows more than the passed in pair */ 7046 uoffset0 = cache[0]; 7047 boffset0 = cache[1]; 7048 } 7049 if ((*mgp)->mg_len != -1) { 7050 /* And we know the end too. */ 7051 boffset = boffset0 7052 + sv_pos_u2b_midway(start + boffset0, send, 7053 uoffset - uoffset0, 7054 (*mgp)->mg_len - uoffset0); 7055 } else { 7056 uoffset -= uoffset0; 7057 boffset = boffset0 7058 + sv_pos_u2b_forwards(start + boffset0, 7059 send, &uoffset, &at_end); 7060 uoffset += uoffset0; 7061 } 7062 } 7063 else if (cache[2] < uoffset) { 7064 /* We're between the two cache entries. */ 7065 if (cache[2] > uoffset0) { 7066 /* and the cache knows more than the passed in pair */ 7067 uoffset0 = cache[2]; 7068 boffset0 = cache[3]; 7069 } 7070 7071 boffset = boffset0 7072 + sv_pos_u2b_midway(start + boffset0, 7073 start + cache[1], 7074 uoffset - uoffset0, 7075 cache[0] - uoffset0); 7076 } else { 7077 boffset = boffset0 7078 + sv_pos_u2b_midway(start + boffset0, 7079 start + cache[3], 7080 uoffset - uoffset0, 7081 cache[2] - uoffset0); 7082 } 7083 found = TRUE; 7084 } 7085 else if ((*mgp)->mg_len != -1) { 7086 /* If we can take advantage of a passed in offset, do so. */ 7087 /* In fact, offset0 is either 0, or less than offset, so don't 7088 need to worry about the other possibility. */ 7089 boffset = boffset0 7090 + sv_pos_u2b_midway(start + boffset0, send, 7091 uoffset - uoffset0, 7092 (*mgp)->mg_len - uoffset0); 7093 found = TRUE; 7094 } 7095 } 7096 7097 if (!found || PL_utf8cache < 0) { 7098 STRLEN real_boffset; 7099 uoffset -= uoffset0; 7100 real_boffset = boffset0 + sv_pos_u2b_forwards(start + boffset0, 7101 send, &uoffset, &at_end); 7102 uoffset += uoffset0; 7103 7104 if (found && PL_utf8cache < 0) 7105 assert_uft8_cache_coherent("sv_pos_u2b_cache", boffset, 7106 real_boffset, sv); 7107 boffset = real_boffset; 7108 } 7109 7110 if (PL_utf8cache && !SvGMAGICAL(sv) && SvPOK(sv)) { 7111 if (at_end) 7112 utf8_mg_len_cache_update(sv, mgp, uoffset); 7113 else 7114 utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start); 7115 } 7116 return boffset; 7117 } 7118 7119 7120 /* 7121 =for apidoc sv_pos_u2b_flags 7122 7123 Converts the offset from a count of UTF-8 chars from 7124 the start of the string, to a count of the equivalent number of bytes; if 7125 lenp is non-zero, it does the same to lenp, but this time starting from 7126 the offset, rather than from the start 7127 of the string. Handles type coercion. 7128 I<flags> is passed to C<SvPV_flags>, and usually should be 7129 C<SV_GMAGIC|SV_CONST_RETURN> to handle magic. 7130 7131 =cut 7132 */ 7133 7134 /* 7135 * sv_pos_u2b_flags() uses, like sv_pos_b2u(), the mg_ptr of the potential 7136 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and 7137 * byte offsets. See also the comments of S_utf8_mg_pos_cache_update(). 7138 * 7139 */ 7140 7141 STRLEN 7142 Perl_sv_pos_u2b_flags(pTHX_ SV *const sv, STRLEN uoffset, STRLEN *const lenp, 7143 U32 flags) 7144 { 7145 const U8 *start; 7146 STRLEN len; 7147 STRLEN boffset; 7148 7149 PERL_ARGS_ASSERT_SV_POS_U2B_FLAGS; 7150 7151 start = (U8*)SvPV_flags(sv, len, flags); 7152 if (len) { 7153 const U8 * const send = start + len; 7154 MAGIC *mg = NULL; 7155 boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0); 7156 7157 if (lenp 7158 && *lenp /* don't bother doing work for 0, as its bytes equivalent 7159 is 0, and *lenp is already set to that. */) { 7160 /* Convert the relative offset to absolute. */ 7161 const STRLEN uoffset2 = uoffset + *lenp; 7162 const STRLEN boffset2 7163 = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2, 7164 uoffset, boffset) - boffset; 7165 7166 *lenp = boffset2; 7167 } 7168 } else { 7169 if (lenp) 7170 *lenp = 0; 7171 boffset = 0; 7172 } 7173 7174 return boffset; 7175 } 7176 7177 /* 7178 =for apidoc sv_pos_u2b 7179 7180 Converts the value pointed to by offsetp from a count of UTF-8 chars from 7181 the start of the string, to a count of the equivalent number of bytes; if 7182 lenp is non-zero, it does the same to lenp, but this time starting from 7183 the offset, rather than from the start of the string. Handles magic and 7184 type coercion. 7185 7186 Use C<sv_pos_u2b_flags> in preference, which correctly handles strings longer 7187 than 2Gb. 7188 7189 =cut 7190 */ 7191 7192 /* 7193 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential 7194 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and 7195 * byte offsets. See also the comments of S_utf8_mg_pos_cache_update(). 7196 * 7197 */ 7198 7199 /* This function is subject to size and sign problems */ 7200 7201 void 7202 Perl_sv_pos_u2b(pTHX_ SV *const sv, I32 *const offsetp, I32 *const lenp) 7203 { 7204 PERL_ARGS_ASSERT_SV_POS_U2B; 7205 7206 if (lenp) { 7207 STRLEN ulen = (STRLEN)*lenp; 7208 *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, &ulen, 7209 SV_GMAGIC|SV_CONST_RETURN); 7210 *lenp = (I32)ulen; 7211 } else { 7212 *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, NULL, 7213 SV_GMAGIC|SV_CONST_RETURN); 7214 } 7215 } 7216 7217 static void 7218 S_utf8_mg_len_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, 7219 const STRLEN ulen) 7220 { 7221 PERL_ARGS_ASSERT_UTF8_MG_LEN_CACHE_UPDATE; 7222 if (SvREADONLY(sv) || SvGMAGICAL(sv) || !SvPOK(sv)) 7223 return; 7224 7225 if (!*mgp && (SvTYPE(sv) < SVt_PVMG || 7226 !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) { 7227 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0); 7228 } 7229 assert(*mgp); 7230 7231 (*mgp)->mg_len = ulen; 7232 } 7233 7234 /* Create and update the UTF8 magic offset cache, with the proffered utf8/ 7235 byte length pairing. The (byte) length of the total SV is passed in too, 7236 as blen, because for some (more esoteric) SVs, the call to SvPV_const() 7237 may not have updated SvCUR, so we can't rely on reading it directly. 7238 7239 The proffered utf8/byte length pairing isn't used if the cache already has 7240 two pairs, and swapping either for the proffered pair would increase the 7241 RMS of the intervals between known byte offsets. 7242 7243 The cache itself consists of 4 STRLEN values 7244 0: larger UTF-8 offset 7245 1: corresponding byte offset 7246 2: smaller UTF-8 offset 7247 3: corresponding byte offset 7248 7249 Unused cache pairs have the value 0, 0. 7250 Keeping the cache "backwards" means that the invariant of 7251 cache[0] >= cache[2] is maintained even with empty slots, which means that 7252 the code that uses it doesn't need to worry if only 1 entry has actually 7253 been set to non-zero. It also makes the "position beyond the end of the 7254 cache" logic much simpler, as the first slot is always the one to start 7255 from. 7256 */ 7257 static void 7258 S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN byte, 7259 const STRLEN utf8, const STRLEN blen) 7260 { 7261 STRLEN *cache; 7262 7263 PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE; 7264 7265 if (SvREADONLY(sv)) 7266 return; 7267 7268 if (!*mgp && (SvTYPE(sv) < SVt_PVMG || 7269 !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) { 7270 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0, 7271 0); 7272 (*mgp)->mg_len = -1; 7273 } 7274 assert(*mgp); 7275 7276 if (!(cache = (STRLEN *)(*mgp)->mg_ptr)) { 7277 Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN); 7278 (*mgp)->mg_ptr = (char *) cache; 7279 } 7280 assert(cache); 7281 7282 if (PL_utf8cache < 0 && SvPOKp(sv)) { 7283 /* SvPOKp() because it's possible that sv has string overloading, and 7284 therefore is a reference, hence SvPVX() is actually a pointer. 7285 This cures the (very real) symptoms of RT 69422, but I'm not actually 7286 sure whether we should even be caching the results of UTF-8 7287 operations on overloading, given that nothing stops overloading 7288 returning a different value every time it's called. */ 7289 const U8 *start = (const U8 *) SvPVX_const(sv); 7290 const STRLEN realutf8 = utf8_length(start, start + byte); 7291 7292 assert_uft8_cache_coherent("utf8_mg_pos_cache_update", utf8, realutf8, 7293 sv); 7294 } 7295 7296 /* Cache is held with the later position first, to simplify the code 7297 that deals with unbounded ends. */ 7298 7299 ASSERT_UTF8_CACHE(cache); 7300 if (cache[1] == 0) { 7301 /* Cache is totally empty */ 7302 cache[0] = utf8; 7303 cache[1] = byte; 7304 } else if (cache[3] == 0) { 7305 if (byte > cache[1]) { 7306 /* New one is larger, so goes first. */ 7307 cache[2] = cache[0]; 7308 cache[3] = cache[1]; 7309 cache[0] = utf8; 7310 cache[1] = byte; 7311 } else { 7312 cache[2] = utf8; 7313 cache[3] = byte; 7314 } 7315 } else { 7316 #define THREEWAY_SQUARE(a,b,c,d) \ 7317 ((float)((d) - (c))) * ((float)((d) - (c))) \ 7318 + ((float)((c) - (b))) * ((float)((c) - (b))) \ 7319 + ((float)((b) - (a))) * ((float)((b) - (a))) 7320 7321 /* Cache has 2 slots in use, and we know three potential pairs. 7322 Keep the two that give the lowest RMS distance. Do the 7323 calculation in bytes simply because we always know the byte 7324 length. squareroot has the same ordering as the positive value, 7325 so don't bother with the actual square root. */ 7326 if (byte > cache[1]) { 7327 /* New position is after the existing pair of pairs. */ 7328 const float keep_earlier 7329 = THREEWAY_SQUARE(0, cache[3], byte, blen); 7330 const float keep_later 7331 = THREEWAY_SQUARE(0, cache[1], byte, blen); 7332 7333 if (keep_later < keep_earlier) { 7334 cache[2] = cache[0]; 7335 cache[3] = cache[1]; 7336 cache[0] = utf8; 7337 cache[1] = byte; 7338 } 7339 else { 7340 cache[0] = utf8; 7341 cache[1] = byte; 7342 } 7343 } 7344 else if (byte > cache[3]) { 7345 /* New position is between the existing pair of pairs. */ 7346 const float keep_earlier 7347 = THREEWAY_SQUARE(0, cache[3], byte, blen); 7348 const float keep_later 7349 = THREEWAY_SQUARE(0, byte, cache[1], blen); 7350 7351 if (keep_later < keep_earlier) { 7352 cache[2] = utf8; 7353 cache[3] = byte; 7354 } 7355 else { 7356 cache[0] = utf8; 7357 cache[1] = byte; 7358 } 7359 } 7360 else { 7361 /* New position is before the existing pair of pairs. */ 7362 const float keep_earlier 7363 = THREEWAY_SQUARE(0, byte, cache[3], blen); 7364 const float keep_later 7365 = THREEWAY_SQUARE(0, byte, cache[1], blen); 7366 7367 if (keep_later < keep_earlier) { 7368 cache[2] = utf8; 7369 cache[3] = byte; 7370 } 7371 else { 7372 cache[0] = cache[2]; 7373 cache[1] = cache[3]; 7374 cache[2] = utf8; 7375 cache[3] = byte; 7376 } 7377 } 7378 } 7379 ASSERT_UTF8_CACHE(cache); 7380 } 7381 7382 /* We already know all of the way, now we may be able to walk back. The same 7383 assumption is made as in S_sv_pos_u2b_midway(), namely that walking 7384 backward is half the speed of walking forward. */ 7385 static STRLEN 7386 S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target, 7387 const U8 *end, STRLEN endu) 7388 { 7389 const STRLEN forw = target - s; 7390 STRLEN backw = end - target; 7391 7392 PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY; 7393 7394 if (forw < 2 * backw) { 7395 return utf8_length(s, target); 7396 } 7397 7398 while (end > target) { 7399 end--; 7400 while (UTF8_IS_CONTINUATION(*end)) { 7401 end--; 7402 } 7403 endu--; 7404 } 7405 return endu; 7406 } 7407 7408 /* 7409 =for apidoc sv_pos_b2u_flags 7410 7411 Converts the offset from a count of bytes from the start of the string, to 7412 a count of the equivalent number of UTF-8 chars. Handles type coercion. 7413 I<flags> is passed to C<SvPV_flags>, and usually should be 7414 C<SV_GMAGIC|SV_CONST_RETURN> to handle magic. 7415 7416 =cut 7417 */ 7418 7419 /* 7420 * sv_pos_b2u_flags() uses, like sv_pos_u2b_flags(), the mg_ptr of the 7421 * potential PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 7422 * and byte offsets. 7423 * 7424 */ 7425 STRLEN 7426 Perl_sv_pos_b2u_flags(pTHX_ SV *const sv, STRLEN const offset, U32 flags) 7427 { 7428 const U8* s; 7429 STRLEN len = 0; /* Actually always set, but let's keep gcc happy. */ 7430 STRLEN blen; 7431 MAGIC* mg = NULL; 7432 const U8* send; 7433 bool found = FALSE; 7434 7435 PERL_ARGS_ASSERT_SV_POS_B2U_FLAGS; 7436 7437 s = (const U8*)SvPV_flags(sv, blen, flags); 7438 7439 if (blen < offset) 7440 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset, blen=%"UVuf 7441 ", byte=%"UVuf, (UV)blen, (UV)offset); 7442 7443 send = s + offset; 7444 7445 if (!SvREADONLY(sv) 7446 && PL_utf8cache 7447 && SvTYPE(sv) >= SVt_PVMG 7448 && (mg = mg_find(sv, PERL_MAGIC_utf8))) 7449 { 7450 if (mg->mg_ptr) { 7451 STRLEN * const cache = (STRLEN *) mg->mg_ptr; 7452 if (cache[1] == offset) { 7453 /* An exact match. */ 7454 return cache[0]; 7455 } 7456 if (cache[3] == offset) { 7457 /* An exact match. */ 7458 return cache[2]; 7459 } 7460 7461 if (cache[1] < offset) { 7462 /* We already know part of the way. */ 7463 if (mg->mg_len != -1) { 7464 /* Actually, we know the end too. */ 7465 len = cache[0] 7466 + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send, 7467 s + blen, mg->mg_len - cache[0]); 7468 } else { 7469 len = cache[0] + utf8_length(s + cache[1], send); 7470 } 7471 } 7472 else if (cache[3] < offset) { 7473 /* We're between the two cached pairs, so we do the calculation 7474 offset by the byte/utf-8 positions for the earlier pair, 7475 then add the utf-8 characters from the string start to 7476 there. */ 7477 len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send, 7478 s + cache[1], cache[0] - cache[2]) 7479 + cache[2]; 7480 7481 } 7482 else { /* cache[3] > offset */ 7483 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3], 7484 cache[2]); 7485 7486 } 7487 ASSERT_UTF8_CACHE(cache); 7488 found = TRUE; 7489 } else if (mg->mg_len != -1) { 7490 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len); 7491 found = TRUE; 7492 } 7493 } 7494 if (!found || PL_utf8cache < 0) { 7495 const STRLEN real_len = utf8_length(s, send); 7496 7497 if (found && PL_utf8cache < 0) 7498 assert_uft8_cache_coherent("sv_pos_b2u", len, real_len, sv); 7499 len = real_len; 7500 } 7501 7502 if (PL_utf8cache) { 7503 if (blen == offset) 7504 utf8_mg_len_cache_update(sv, &mg, len); 7505 else 7506 utf8_mg_pos_cache_update(sv, &mg, offset, len, blen); 7507 } 7508 7509 return len; 7510 } 7511 7512 /* 7513 =for apidoc sv_pos_b2u 7514 7515 Converts the value pointed to by offsetp from a count of bytes from the 7516 start of the string, to a count of the equivalent number of UTF-8 chars. 7517 Handles magic and type coercion. 7518 7519 Use C<sv_pos_b2u_flags> in preference, which correctly handles strings 7520 longer than 2Gb. 7521 7522 =cut 7523 */ 7524 7525 /* 7526 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential 7527 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and 7528 * byte offsets. 7529 * 7530 */ 7531 void 7532 Perl_sv_pos_b2u(pTHX_ SV *const sv, I32 *const offsetp) 7533 { 7534 PERL_ARGS_ASSERT_SV_POS_B2U; 7535 7536 if (!sv) 7537 return; 7538 7539 *offsetp = (I32)sv_pos_b2u_flags(sv, (STRLEN)*offsetp, 7540 SV_GMAGIC|SV_CONST_RETURN); 7541 } 7542 7543 static void 7544 S_assert_uft8_cache_coherent(pTHX_ const char *const func, STRLEN from_cache, 7545 STRLEN real, SV *const sv) 7546 { 7547 PERL_ARGS_ASSERT_ASSERT_UFT8_CACHE_COHERENT; 7548 7549 /* As this is debugging only code, save space by keeping this test here, 7550 rather than inlining it in all the callers. */ 7551 if (from_cache == real) 7552 return; 7553 7554 /* Need to turn the assertions off otherwise we may recurse infinitely 7555 while printing error messages. */ 7556 SAVEI8(PL_utf8cache); 7557 PL_utf8cache = 0; 7558 Perl_croak(aTHX_ "panic: %s cache %"UVuf" real %"UVuf" for %"SVf, 7559 func, (UV) from_cache, (UV) real, SVfARG(sv)); 7560 } 7561 7562 /* 7563 =for apidoc sv_eq 7564 7565 Returns a boolean indicating whether the strings in the two SVs are 7566 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will 7567 coerce its args to strings if necessary. 7568 7569 =for apidoc sv_eq_flags 7570 7571 Returns a boolean indicating whether the strings in the two SVs are 7572 identical. Is UTF-8 and 'use bytes' aware and coerces its args to strings 7573 if necessary. If the flags include SV_GMAGIC, it handles get-magic, too. 7574 7575 =cut 7576 */ 7577 7578 I32 7579 Perl_sv_eq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags) 7580 { 7581 dVAR; 7582 const char *pv1; 7583 STRLEN cur1; 7584 const char *pv2; 7585 STRLEN cur2; 7586 I32 eq = 0; 7587 SV* svrecode = NULL; 7588 7589 if (!sv1) { 7590 pv1 = ""; 7591 cur1 = 0; 7592 } 7593 else { 7594 /* if pv1 and pv2 are the same, second SvPV_const call may 7595 * invalidate pv1 (if we are handling magic), so we may need to 7596 * make a copy */ 7597 if (sv1 == sv2 && flags & SV_GMAGIC 7598 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) { 7599 pv1 = SvPV_const(sv1, cur1); 7600 sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2)); 7601 } 7602 pv1 = SvPV_flags_const(sv1, cur1, flags); 7603 } 7604 7605 if (!sv2){ 7606 pv2 = ""; 7607 cur2 = 0; 7608 } 7609 else 7610 pv2 = SvPV_flags_const(sv2, cur2, flags); 7611 7612 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) { 7613 /* Differing utf8ness. 7614 * Do not UTF8size the comparands as a side-effect. */ 7615 if (PL_encoding) { 7616 if (SvUTF8(sv1)) { 7617 svrecode = newSVpvn(pv2, cur2); 7618 sv_recode_to_utf8(svrecode, PL_encoding); 7619 pv2 = SvPV_const(svrecode, cur2); 7620 } 7621 else { 7622 svrecode = newSVpvn(pv1, cur1); 7623 sv_recode_to_utf8(svrecode, PL_encoding); 7624 pv1 = SvPV_const(svrecode, cur1); 7625 } 7626 /* Now both are in UTF-8. */ 7627 if (cur1 != cur2) { 7628 SvREFCNT_dec_NN(svrecode); 7629 return FALSE; 7630 } 7631 } 7632 else { 7633 if (SvUTF8(sv1)) { 7634 /* sv1 is the UTF-8 one */ 7635 return bytes_cmp_utf8((const U8*)pv2, cur2, 7636 (const U8*)pv1, cur1) == 0; 7637 } 7638 else { 7639 /* sv2 is the UTF-8 one */ 7640 return bytes_cmp_utf8((const U8*)pv1, cur1, 7641 (const U8*)pv2, cur2) == 0; 7642 } 7643 } 7644 } 7645 7646 if (cur1 == cur2) 7647 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1); 7648 7649 SvREFCNT_dec(svrecode); 7650 7651 return eq; 7652 } 7653 7654 /* 7655 =for apidoc sv_cmp 7656 7657 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the 7658 string in C<sv1> is less than, equal to, or greater than the string in 7659 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will 7660 coerce its args to strings if necessary. See also C<sv_cmp_locale>. 7661 7662 =for apidoc sv_cmp_flags 7663 7664 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the 7665 string in C<sv1> is less than, equal to, or greater than the string in 7666 C<sv2>. Is UTF-8 and 'use bytes' aware and will coerce its args to strings 7667 if necessary. If the flags include SV_GMAGIC, it handles get magic. See 7668 also C<sv_cmp_locale_flags>. 7669 7670 =cut 7671 */ 7672 7673 I32 7674 Perl_sv_cmp(pTHX_ SV *const sv1, SV *const sv2) 7675 { 7676 return sv_cmp_flags(sv1, sv2, SV_GMAGIC); 7677 } 7678 7679 I32 7680 Perl_sv_cmp_flags(pTHX_ SV *const sv1, SV *const sv2, 7681 const U32 flags) 7682 { 7683 dVAR; 7684 STRLEN cur1, cur2; 7685 const char *pv1, *pv2; 7686 I32 cmp; 7687 SV *svrecode = NULL; 7688 7689 if (!sv1) { 7690 pv1 = ""; 7691 cur1 = 0; 7692 } 7693 else 7694 pv1 = SvPV_flags_const(sv1, cur1, flags); 7695 7696 if (!sv2) { 7697 pv2 = ""; 7698 cur2 = 0; 7699 } 7700 else 7701 pv2 = SvPV_flags_const(sv2, cur2, flags); 7702 7703 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) { 7704 /* Differing utf8ness. 7705 * Do not UTF8size the comparands as a side-effect. */ 7706 if (SvUTF8(sv1)) { 7707 if (PL_encoding) { 7708 svrecode = newSVpvn(pv2, cur2); 7709 sv_recode_to_utf8(svrecode, PL_encoding); 7710 pv2 = SvPV_const(svrecode, cur2); 7711 } 7712 else { 7713 const int retval = -bytes_cmp_utf8((const U8*)pv2, cur2, 7714 (const U8*)pv1, cur1); 7715 return retval ? retval < 0 ? -1 : +1 : 0; 7716 } 7717 } 7718 else { 7719 if (PL_encoding) { 7720 svrecode = newSVpvn(pv1, cur1); 7721 sv_recode_to_utf8(svrecode, PL_encoding); 7722 pv1 = SvPV_const(svrecode, cur1); 7723 } 7724 else { 7725 const int retval = bytes_cmp_utf8((const U8*)pv1, cur1, 7726 (const U8*)pv2, cur2); 7727 return retval ? retval < 0 ? -1 : +1 : 0; 7728 } 7729 } 7730 } 7731 7732 if (!cur1) { 7733 cmp = cur2 ? -1 : 0; 7734 } else if (!cur2) { 7735 cmp = 1; 7736 } else { 7737 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2); 7738 7739 if (retval) { 7740 cmp = retval < 0 ? -1 : 1; 7741 } else if (cur1 == cur2) { 7742 cmp = 0; 7743 } else { 7744 cmp = cur1 < cur2 ? -1 : 1; 7745 } 7746 } 7747 7748 SvREFCNT_dec(svrecode); 7749 7750 return cmp; 7751 } 7752 7753 /* 7754 =for apidoc sv_cmp_locale 7755 7756 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and 7757 'use bytes' aware, handles get magic, and will coerce its args to strings 7758 if necessary. See also C<sv_cmp>. 7759 7760 =for apidoc sv_cmp_locale_flags 7761 7762 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and 7763 'use bytes' aware and will coerce its args to strings if necessary. If the 7764 flags contain SV_GMAGIC, it handles get magic. See also C<sv_cmp_flags>. 7765 7766 =cut 7767 */ 7768 7769 I32 7770 Perl_sv_cmp_locale(pTHX_ SV *const sv1, SV *const sv2) 7771 { 7772 return sv_cmp_locale_flags(sv1, sv2, SV_GMAGIC); 7773 } 7774 7775 I32 7776 Perl_sv_cmp_locale_flags(pTHX_ SV *const sv1, SV *const sv2, 7777 const U32 flags) 7778 { 7779 dVAR; 7780 #ifdef USE_LOCALE_COLLATE 7781 7782 char *pv1, *pv2; 7783 STRLEN len1, len2; 7784 I32 retval; 7785 7786 if (PL_collation_standard) 7787 goto raw_compare; 7788 7789 len1 = 0; 7790 pv1 = sv1 ? sv_collxfrm_flags(sv1, &len1, flags) : (char *) NULL; 7791 len2 = 0; 7792 pv2 = sv2 ? sv_collxfrm_flags(sv2, &len2, flags) : (char *) NULL; 7793 7794 if (!pv1 || !len1) { 7795 if (pv2 && len2) 7796 return -1; 7797 else 7798 goto raw_compare; 7799 } 7800 else { 7801 if (!pv2 || !len2) 7802 return 1; 7803 } 7804 7805 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2); 7806 7807 if (retval) 7808 return retval < 0 ? -1 : 1; 7809 7810 /* 7811 * When the result of collation is equality, that doesn't mean 7812 * that there are no differences -- some locales exclude some 7813 * characters from consideration. So to avoid false equalities, 7814 * we use the raw string as a tiebreaker. 7815 */ 7816 7817 raw_compare: 7818 /*FALLTHROUGH*/ 7819 7820 #else 7821 PERL_UNUSED_ARG(flags); 7822 #endif /* USE_LOCALE_COLLATE */ 7823 7824 return sv_cmp(sv1, sv2); 7825 } 7826 7827 7828 #ifdef USE_LOCALE_COLLATE 7829 7830 /* 7831 =for apidoc sv_collxfrm 7832 7833 This calls C<sv_collxfrm_flags> with the SV_GMAGIC flag. See 7834 C<sv_collxfrm_flags>. 7835 7836 =for apidoc sv_collxfrm_flags 7837 7838 Add Collate Transform magic to an SV if it doesn't already have it. If the 7839 flags contain SV_GMAGIC, it handles get-magic. 7840 7841 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the 7842 scalar data of the variable, but transformed to such a format that a normal 7843 memory comparison can be used to compare the data according to the locale 7844 settings. 7845 7846 =cut 7847 */ 7848 7849 char * 7850 Perl_sv_collxfrm_flags(pTHX_ SV *const sv, STRLEN *const nxp, const I32 flags) 7851 { 7852 dVAR; 7853 MAGIC *mg; 7854 7855 PERL_ARGS_ASSERT_SV_COLLXFRM_FLAGS; 7856 7857 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL; 7858 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) { 7859 const char *s; 7860 char *xf; 7861 STRLEN len, xlen; 7862 7863 if (mg) 7864 Safefree(mg->mg_ptr); 7865 s = SvPV_flags_const(sv, len, flags); 7866 if ((xf = mem_collxfrm(s, len, &xlen))) { 7867 if (! mg) { 7868 #ifdef PERL_OLD_COPY_ON_WRITE 7869 if (SvIsCOW(sv)) 7870 sv_force_normal_flags(sv, 0); 7871 #endif 7872 mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm, 7873 0, 0); 7874 assert(mg); 7875 } 7876 mg->mg_ptr = xf; 7877 mg->mg_len = xlen; 7878 } 7879 else { 7880 if (mg) { 7881 mg->mg_ptr = NULL; 7882 mg->mg_len = -1; 7883 } 7884 } 7885 } 7886 if (mg && mg->mg_ptr) { 7887 *nxp = mg->mg_len; 7888 return mg->mg_ptr + sizeof(PL_collation_ix); 7889 } 7890 else { 7891 *nxp = 0; 7892 return NULL; 7893 } 7894 } 7895 7896 #endif /* USE_LOCALE_COLLATE */ 7897 7898 static char * 7899 S_sv_gets_append_to_utf8(pTHX_ SV *const sv, PerlIO *const fp, I32 append) 7900 { 7901 SV * const tsv = newSV(0); 7902 ENTER; 7903 SAVEFREESV(tsv); 7904 sv_gets(tsv, fp, 0); 7905 sv_utf8_upgrade_nomg(tsv); 7906 SvCUR_set(sv,append); 7907 sv_catsv(sv,tsv); 7908 LEAVE; 7909 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL; 7910 } 7911 7912 static char * 7913 S_sv_gets_read_record(pTHX_ SV *const sv, PerlIO *const fp, I32 append) 7914 { 7915 SSize_t bytesread; 7916 const STRLEN recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */ 7917 /* Grab the size of the record we're getting */ 7918 char *buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append; 7919 7920 /* Go yank in */ 7921 #ifdef VMS 7922 #include <rms.h> 7923 int fd; 7924 Stat_t st; 7925 7926 /* With a true, record-oriented file on VMS, we need to use read directly 7927 * to ensure that we respect RMS record boundaries. The user is responsible 7928 * for providing a PL_rs value that corresponds to the FAB$W_MRS (maximum 7929 * record size) field. N.B. This is likely to produce invalid results on 7930 * varying-width character data when a record ends mid-character. 7931 */ 7932 fd = PerlIO_fileno(fp); 7933 if (fd != -1 7934 && PerlLIO_fstat(fd, &st) == 0 7935 && (st.st_fab_rfm == FAB$C_VAR 7936 || st.st_fab_rfm == FAB$C_VFC 7937 || st.st_fab_rfm == FAB$C_FIX)) { 7938 7939 bytesread = PerlLIO_read(fd, buffer, recsize); 7940 } 7941 else /* in-memory file from PerlIO::Scalar 7942 * or not a record-oriented file 7943 */ 7944 #endif 7945 { 7946 bytesread = PerlIO_read(fp, buffer, recsize); 7947 7948 /* At this point, the logic in sv_get() means that sv will 7949 be treated as utf-8 if the handle is utf8. 7950 */ 7951 if (PerlIO_isutf8(fp) && bytesread > 0) { 7952 char *bend = buffer + bytesread; 7953 char *bufp = buffer; 7954 size_t charcount = 0; 7955 bool charstart = TRUE; 7956 STRLEN skip = 0; 7957 7958 while (charcount < recsize) { 7959 /* count accumulated characters */ 7960 while (bufp < bend) { 7961 if (charstart) { 7962 skip = UTF8SKIP(bufp); 7963 } 7964 if (bufp + skip > bend) { 7965 /* partial at the end */ 7966 charstart = FALSE; 7967 break; 7968 } 7969 else { 7970 ++charcount; 7971 bufp += skip; 7972 charstart = TRUE; 7973 } 7974 } 7975 7976 if (charcount < recsize) { 7977 STRLEN readsize; 7978 STRLEN bufp_offset = bufp - buffer; 7979 SSize_t morebytesread; 7980 7981 /* originally I read enough to fill any incomplete 7982 character and the first byte of the next 7983 character if needed, but if there's many 7984 multi-byte encoded characters we're going to be 7985 making a read call for every character beyond 7986 the original read size. 7987 7988 So instead, read the rest of the character if 7989 any, and enough bytes to match at least the 7990 start bytes for each character we're going to 7991 read. 7992 */ 7993 if (charstart) 7994 readsize = recsize - charcount; 7995 else 7996 readsize = skip - (bend - bufp) + recsize - charcount - 1; 7997 buffer = SvGROW(sv, append + bytesread + readsize + 1) + append; 7998 bend = buffer + bytesread; 7999 morebytesread = PerlIO_read(fp, bend, readsize); 8000 if (morebytesread <= 0) { 8001 /* we're done, if we still have incomplete 8002 characters the check code in sv_gets() will 8003 warn about them. 8004 8005 I'd originally considered doing 8006 PerlIO_ungetc() on all but the lead 8007 character of the incomplete character, but 8008 read() doesn't do that, so I don't. 8009 */ 8010 break; 8011 } 8012 8013 /* prepare to scan some more */ 8014 bytesread += morebytesread; 8015 bend = buffer + bytesread; 8016 bufp = buffer + bufp_offset; 8017 } 8018 } 8019 } 8020 } 8021 8022 if (bytesread < 0) 8023 bytesread = 0; 8024 SvCUR_set(sv, bytesread + append); 8025 buffer[bytesread] = '\0'; 8026 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL; 8027 } 8028 8029 /* 8030 =for apidoc sv_gets 8031 8032 Get a line from the filehandle and store it into the SV, optionally 8033 appending to the currently-stored string. If C<append> is not 0, the 8034 line is appended to the SV instead of overwriting it. C<append> should 8035 be set to the byte offset that the appended string should start at 8036 in the SV (typically, C<SvCUR(sv)> is a suitable choice). 8037 8038 =cut 8039 */ 8040 8041 char * 8042 Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append) 8043 { 8044 dVAR; 8045 const char *rsptr; 8046 STRLEN rslen; 8047 STDCHAR rslast; 8048 STDCHAR *bp; 8049 SSize_t cnt; 8050 int i = 0; 8051 int rspara = 0; 8052 8053 PERL_ARGS_ASSERT_SV_GETS; 8054 8055 if (SvTHINKFIRST(sv)) 8056 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV); 8057 /* XXX. If you make this PVIV, then copy on write can copy scalars read 8058 from <>. 8059 However, perlbench says it's slower, because the existing swipe code 8060 is faster than copy on write. 8061 Swings and roundabouts. */ 8062 SvUPGRADE(sv, SVt_PV); 8063 8064 if (append) { 8065 /* line is going to be appended to the existing buffer in the sv */ 8066 if (PerlIO_isutf8(fp)) { 8067 if (!SvUTF8(sv)) { 8068 sv_utf8_upgrade_nomg(sv); 8069 sv_pos_u2b(sv,&append,0); 8070 } 8071 } else if (SvUTF8(sv)) { 8072 return S_sv_gets_append_to_utf8(aTHX_ sv, fp, append); 8073 } 8074 } 8075 8076 SvPOK_only(sv); 8077 if (!append) { 8078 /* not appending - "clear" the string by setting SvCUR to 0, 8079 * the pv is still avaiable. */ 8080 SvCUR_set(sv,0); 8081 } 8082 if (PerlIO_isutf8(fp)) 8083 SvUTF8_on(sv); 8084 8085 if (IN_PERL_COMPILETIME) { 8086 /* we always read code in line mode */ 8087 rsptr = "\n"; 8088 rslen = 1; 8089 } 8090 else if (RsSNARF(PL_rs)) { 8091 /* If it is a regular disk file use size from stat() as estimate 8092 of amount we are going to read -- may result in mallocing 8093 more memory than we really need if the layers below reduce 8094 the size we read (e.g. CRLF or a gzip layer). 8095 */ 8096 Stat_t st; 8097 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) { 8098 const Off_t offset = PerlIO_tell(fp); 8099 if (offset != (Off_t) -1 && st.st_size + append > offset) { 8100 #ifdef PERL_NEW_COPY_ON_WRITE 8101 /* Add an extra byte for the sake of copy-on-write's 8102 * buffer reference count. */ 8103 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 2)); 8104 #else 8105 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1)); 8106 #endif 8107 } 8108 } 8109 rsptr = NULL; 8110 rslen = 0; 8111 } 8112 else if (RsRECORD(PL_rs)) { 8113 return S_sv_gets_read_record(aTHX_ sv, fp, append); 8114 } 8115 else if (RsPARA(PL_rs)) { 8116 rsptr = "\n\n"; 8117 rslen = 2; 8118 rspara = 1; 8119 } 8120 else { 8121 /* Get $/ i.e. PL_rs into same encoding as stream wants */ 8122 if (PerlIO_isutf8(fp)) { 8123 rsptr = SvPVutf8(PL_rs, rslen); 8124 } 8125 else { 8126 if (SvUTF8(PL_rs)) { 8127 if (!sv_utf8_downgrade(PL_rs, TRUE)) { 8128 Perl_croak(aTHX_ "Wide character in $/"); 8129 } 8130 } 8131 /* extract the raw pointer to the record separator */ 8132 rsptr = SvPV_const(PL_rs, rslen); 8133 } 8134 } 8135 8136 /* rslast is the last character in the record separator 8137 * note we don't use rslast except when rslen is true, so the 8138 * null assign is a placeholder. */ 8139 rslast = rslen ? rsptr[rslen - 1] : '\0'; 8140 8141 if (rspara) { /* have to do this both before and after */ 8142 do { /* to make sure file boundaries work right */ 8143 if (PerlIO_eof(fp)) 8144 return 0; 8145 i = PerlIO_getc(fp); 8146 if (i != '\n') { 8147 if (i == -1) 8148 return 0; 8149 PerlIO_ungetc(fp,i); 8150 break; 8151 } 8152 } while (i != EOF); 8153 } 8154 8155 /* See if we know enough about I/O mechanism to cheat it ! */ 8156 8157 /* This used to be #ifdef test - it is made run-time test for ease 8158 of abstracting out stdio interface. One call should be cheap 8159 enough here - and may even be a macro allowing compile 8160 time optimization. 8161 */ 8162 8163 if (PerlIO_fast_gets(fp)) { 8164 /* 8165 * We can do buffer based IO operations on this filehandle. 8166 * 8167 * This means we can bypass a lot of subcalls and process 8168 * the buffer directly, it also means we know the upper bound 8169 * on the amount of data we might read of the current buffer 8170 * into our sv. Knowing this allows us to preallocate the pv 8171 * to be able to hold that maximum, which allows us to simplify 8172 * a lot of logic. */ 8173 8174 /* 8175 * We're going to steal some values from the stdio struct 8176 * and put EVERYTHING in the innermost loop into registers. 8177 */ 8178 STDCHAR *ptr; /* pointer into fp's read-ahead buffer */ 8179 STRLEN bpx; /* length of the data in the target sv 8180 used to fix pointers after a SvGROW */ 8181 I32 shortbuffered; /* If the pv buffer is shorter than the amount 8182 of data left in the read-ahead buffer. 8183 If 0 then the pv buffer can hold the full 8184 amount left, otherwise this is the amount it 8185 can hold. */ 8186 8187 #if defined(VMS) && defined(PERLIO_IS_STDIO) 8188 /* An ungetc()d char is handled separately from the regular 8189 * buffer, so we getc() it back out and stuff it in the buffer. 8190 */ 8191 i = PerlIO_getc(fp); 8192 if (i == EOF) return 0; 8193 *(--((*fp)->_ptr)) = (unsigned char) i; 8194 (*fp)->_cnt++; 8195 #endif 8196 8197 /* Here is some breathtakingly efficient cheating */ 8198 8199 /* When you read the following logic resist the urge to think 8200 * of record separators that are 1 byte long. They are an 8201 * uninteresting special (simple) case. 8202 * 8203 * Instead think of record separators which are at least 2 bytes 8204 * long, and keep in mind that we need to deal with such 8205 * separators when they cross a read-ahead buffer boundary. 8206 * 8207 * Also consider that we need to gracefully deal with separators 8208 * that may be longer than a single read ahead buffer. 8209 * 8210 * Lastly do not forget we want to copy the delimiter as well. We 8211 * are copying all data in the file _up_to_and_including_ the separator 8212 * itself. 8213 * 8214 * Now that you have all that in mind here is what is happening below: 8215 * 8216 * 1. When we first enter the loop we do some memory book keeping to see 8217 * how much free space there is in the target SV. (This sub assumes that 8218 * it is operating on the same SV most of the time via $_ and that it is 8219 * going to be able to reuse the same pv buffer each call.) If there is 8220 * "enough" room then we set "shortbuffered" to how much space there is 8221 * and start reading forward. 8222 * 8223 * 2. When we scan forward we copy from the read-ahead buffer to the target 8224 * SV's pv buffer. While we go we watch for the end of the read-ahead buffer, 8225 * and the end of the of pv, as well as for the "rslast", which is the last 8226 * char of the separator. 8227 * 8228 * 3. When scanning forward if we see rslast then we jump backwards in *pv* 8229 * (which has a "complete" record up to the point we saw rslast) and check 8230 * it to see if it matches the separator. If it does we are done. If it doesn't 8231 * we continue on with the scan/copy. 8232 * 8233 * 4. If we run out of read-ahead buffer (cnt goes to 0) then we have to get 8234 * the IO system to read the next buffer. We do this by doing a getc(), which 8235 * returns a single char read (or EOF), and prefills the buffer, and also 8236 * allows us to find out how full the buffer is. We use this information to 8237 * SvGROW() the sv to the size remaining in the buffer, after which we copy 8238 * the returned single char into the target sv, and then go back into scan 8239 * forward mode. 8240 * 8241 * 5. If we run out of write-buffer then we SvGROW() it by the size of the 8242 * remaining space in the read-buffer. 8243 * 8244 * Note that this code despite its twisty-turny nature is pretty darn slick. 8245 * It manages single byte separators, multi-byte cross boundary separators, 8246 * and cross-read-buffer separators cleanly and efficiently at the cost 8247 * of potentially greatly overallocating the target SV. 8248 * 8249 * Yves 8250 */ 8251 8252 8253 /* get the number of bytes remaining in the read-ahead buffer 8254 * on first call on a given fp this will return 0.*/ 8255 cnt = PerlIO_get_cnt(fp); 8256 8257 /* make sure we have the room */ 8258 if ((I32)(SvLEN(sv) - append) <= cnt + 1) { 8259 /* Not room for all of it 8260 if we are looking for a separator and room for some 8261 */ 8262 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) { 8263 /* just process what we have room for */ 8264 shortbuffered = cnt - SvLEN(sv) + append + 1; 8265 cnt -= shortbuffered; 8266 } 8267 else { 8268 /* ensure that the target sv has enough room to hold 8269 * the rest of the read-ahead buffer */ 8270 shortbuffered = 0; 8271 /* remember that cnt can be negative */ 8272 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1)))); 8273 } 8274 } 8275 else { 8276 /* we have enough room to hold the full buffer, lets scream */ 8277 shortbuffered = 0; 8278 } 8279 8280 /* extract the pointer to sv's string buffer, offset by append as necessary */ 8281 bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */ 8282 /* extract the point to the read-ahead buffer */ 8283 ptr = (STDCHAR*)PerlIO_get_ptr(fp); 8284 8285 /* some trace debug output */ 8286 DEBUG_P(PerlIO_printf(Perl_debug_log, 8287 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt)); 8288 DEBUG_P(PerlIO_printf(Perl_debug_log, 8289 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%zd, base=%" 8290 UVuf"\n", 8291 PTR2UV(PerlIO_get_ptr(fp)), PerlIO_get_cnt(fp), 8292 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0))); 8293 8294 for (;;) { 8295 screamer: 8296 /* if there is stuff left in the read-ahead buffer */ 8297 if (cnt > 0) { 8298 /* if there is a separator */ 8299 if (rslen) { 8300 /* loop until we hit the end of the read-ahead buffer */ 8301 while (cnt > 0) { /* this | eat */ 8302 /* scan forward copying and searching for rslast as we go */ 8303 cnt--; 8304 if ((*bp++ = *ptr++) == rslast) /* really | dust */ 8305 goto thats_all_folks; /* screams | sed :-) */ 8306 } 8307 } 8308 else { 8309 /* no separator, slurp the full buffer */ 8310 Copy(ptr, bp, cnt, char); /* this | eat */ 8311 bp += cnt; /* screams | dust */ 8312 ptr += cnt; /* louder | sed :-) */ 8313 cnt = 0; 8314 assert (!shortbuffered); 8315 goto cannot_be_shortbuffered; 8316 } 8317 } 8318 8319 if (shortbuffered) { /* oh well, must extend */ 8320 /* we didnt have enough room to fit the line into the target buffer 8321 * so we must extend the target buffer and keep going */ 8322 cnt = shortbuffered; 8323 shortbuffered = 0; 8324 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */ 8325 SvCUR_set(sv, bpx); 8326 /* extned the target sv's buffer so it can hold the full read-ahead buffer */ 8327 SvGROW(sv, SvLEN(sv) + append + cnt + 2); 8328 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */ 8329 continue; 8330 } 8331 8332 cannot_be_shortbuffered: 8333 /* we need to refill the read-ahead buffer if possible */ 8334 8335 DEBUG_P(PerlIO_printf(Perl_debug_log, 8336 "Screamer: going to getc, ptr=%"UVuf", cnt=%zd\n", 8337 PTR2UV(ptr),cnt)); 8338 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */ 8339 8340 DEBUG_Pv(PerlIO_printf(Perl_debug_log, 8341 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%zd, base=%"UVuf"\n", 8342 PTR2UV(PerlIO_get_ptr(fp)), PerlIO_get_cnt(fp), 8343 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); 8344 8345 /* 8346 call PerlIO_getc() to let it prefill the lookahead buffer 8347 8348 This used to call 'filbuf' in stdio form, but as that behaves like 8349 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing 8350 another abstraction. 8351 8352 Note we have to deal with the char in 'i' if we are not at EOF 8353 */ 8354 i = PerlIO_getc(fp); /* get more characters */ 8355 8356 DEBUG_Pv(PerlIO_printf(Perl_debug_log, 8357 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%zd, base=%"UVuf"\n", 8358 PTR2UV(PerlIO_get_ptr(fp)), PerlIO_get_cnt(fp), 8359 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); 8360 8361 /* find out how much is left in the read-ahead buffer, and rextract its pointer */ 8362 cnt = PerlIO_get_cnt(fp); 8363 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */ 8364 DEBUG_P(PerlIO_printf(Perl_debug_log, 8365 "Screamer: after getc, ptr=%"UVuf", cnt=%zd\n", 8366 PTR2UV(ptr),cnt)); 8367 8368 if (i == EOF) /* all done for ever? */ 8369 goto thats_really_all_folks; 8370 8371 /* make sure we have enough space in the target sv */ 8372 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */ 8373 SvCUR_set(sv, bpx); 8374 SvGROW(sv, bpx + cnt + 2); 8375 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */ 8376 8377 /* copy of the char we got from getc() */ 8378 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */ 8379 8380 /* make sure we deal with the i being the last character of a separator */ 8381 if (rslen && (STDCHAR)i == rslast) /* all done for now? */ 8382 goto thats_all_folks; 8383 } 8384 8385 thats_all_folks: 8386 /* check if we have actually found the separator - only really applies 8387 * when rslen > 1 */ 8388 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) || 8389 memNE((char*)bp - rslen, rsptr, rslen)) 8390 goto screamer; /* go back to the fray */ 8391 thats_really_all_folks: 8392 if (shortbuffered) 8393 cnt += shortbuffered; 8394 DEBUG_P(PerlIO_printf(Perl_debug_log, 8395 "Screamer: quitting, ptr=%"UVuf", cnt=%zd\n",PTR2UV(ptr),cnt)); 8396 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */ 8397 DEBUG_P(PerlIO_printf(Perl_debug_log, 8398 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%zd, base=%"UVuf 8399 "\n", 8400 PTR2UV(PerlIO_get_ptr(fp)), PerlIO_get_cnt(fp), 8401 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); 8402 *bp = '\0'; 8403 SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */ 8404 DEBUG_P(PerlIO_printf(Perl_debug_log, 8405 "Screamer: done, len=%ld, string=|%.*s|\n", 8406 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv))); 8407 } 8408 else 8409 { 8410 /*The big, slow, and stupid way. */ 8411 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */ 8412 STDCHAR *buf = NULL; 8413 Newx(buf, 8192, STDCHAR); 8414 assert(buf); 8415 #else 8416 STDCHAR buf[8192]; 8417 #endif 8418 8419 screamer2: 8420 if (rslen) { 8421 const STDCHAR * const bpe = buf + sizeof(buf); 8422 bp = buf; 8423 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe) 8424 ; /* keep reading */ 8425 cnt = bp - buf; 8426 } 8427 else { 8428 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf)); 8429 /* Accommodate broken VAXC compiler, which applies U8 cast to 8430 * both args of ?: operator, causing EOF to change into 255 8431 */ 8432 if (cnt > 0) 8433 i = (U8)buf[cnt - 1]; 8434 else 8435 i = EOF; 8436 } 8437 8438 if (cnt < 0) 8439 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */ 8440 if (append) 8441 sv_catpvn_nomg(sv, (char *) buf, cnt); 8442 else 8443 sv_setpvn(sv, (char *) buf, cnt); /* "nomg" is implied */ 8444 8445 if (i != EOF && /* joy */ 8446 (!rslen || 8447 SvCUR(sv) < rslen || 8448 memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen))) 8449 { 8450 append = -1; 8451 /* 8452 * If we're reading from a TTY and we get a short read, 8453 * indicating that the user hit his EOF character, we need 8454 * to notice it now, because if we try to read from the TTY 8455 * again, the EOF condition will disappear. 8456 * 8457 * The comparison of cnt to sizeof(buf) is an optimization 8458 * that prevents unnecessary calls to feof(). 8459 * 8460 * - jik 9/25/96 8461 */ 8462 if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp))) 8463 goto screamer2; 8464 } 8465 8466 #ifdef USE_HEAP_INSTEAD_OF_STACK 8467 Safefree(buf); 8468 #endif 8469 } 8470 8471 if (rspara) { /* have to do this both before and after */ 8472 while (i != EOF) { /* to make sure file boundaries work right */ 8473 i = PerlIO_getc(fp); 8474 if (i != '\n') { 8475 PerlIO_ungetc(fp,i); 8476 break; 8477 } 8478 } 8479 } 8480 8481 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL; 8482 } 8483 8484 /* 8485 =for apidoc sv_inc 8486 8487 Auto-increment of the value in the SV, doing string to numeric conversion 8488 if necessary. Handles 'get' magic and operator overloading. 8489 8490 =cut 8491 */ 8492 8493 void 8494 Perl_sv_inc(pTHX_ SV *const sv) 8495 { 8496 if (!sv) 8497 return; 8498 SvGETMAGIC(sv); 8499 sv_inc_nomg(sv); 8500 } 8501 8502 /* 8503 =for apidoc sv_inc_nomg 8504 8505 Auto-increment of the value in the SV, doing string to numeric conversion 8506 if necessary. Handles operator overloading. Skips handling 'get' magic. 8507 8508 =cut 8509 */ 8510 8511 void 8512 Perl_sv_inc_nomg(pTHX_ SV *const sv) 8513 { 8514 dVAR; 8515 char *d; 8516 int flags; 8517 8518 if (!sv) 8519 return; 8520 if (SvTHINKFIRST(sv)) { 8521 if (SvREADONLY(sv)) { 8522 Perl_croak_no_modify(); 8523 } 8524 if (SvROK(sv)) { 8525 IV i; 8526 if (SvAMAGIC(sv) && AMG_CALLunary(sv, inc_amg)) 8527 return; 8528 i = PTR2IV(SvRV(sv)); 8529 sv_unref(sv); 8530 sv_setiv(sv, i); 8531 } 8532 else sv_force_normal_flags(sv, 0); 8533 } 8534 flags = SvFLAGS(sv); 8535 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) { 8536 /* It's (privately or publicly) a float, but not tested as an 8537 integer, so test it to see. */ 8538 (void) SvIV(sv); 8539 flags = SvFLAGS(sv); 8540 } 8541 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) { 8542 /* It's publicly an integer, or privately an integer-not-float */ 8543 #ifdef PERL_PRESERVE_IVUV 8544 oops_its_int: 8545 #endif 8546 if (SvIsUV(sv)) { 8547 if (SvUVX(sv) == UV_MAX) 8548 sv_setnv(sv, UV_MAX_P1); 8549 else 8550 (void)SvIOK_only_UV(sv); 8551 SvUV_set(sv, SvUVX(sv) + 1); 8552 } else { 8553 if (SvIVX(sv) == IV_MAX) 8554 sv_setuv(sv, (UV)IV_MAX + 1); 8555 else { 8556 (void)SvIOK_only(sv); 8557 SvIV_set(sv, SvIVX(sv) + 1); 8558 } 8559 } 8560 return; 8561 } 8562 if (flags & SVp_NOK) { 8563 const NV was = SvNVX(sv); 8564 if (NV_OVERFLOWS_INTEGERS_AT && 8565 was >= NV_OVERFLOWS_INTEGERS_AT) { 8566 /* diag_listed_as: Lost precision when %s %f by 1 */ 8567 Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION), 8568 "Lost precision when incrementing %" NVff " by 1", 8569 was); 8570 } 8571 (void)SvNOK_only(sv); 8572 SvNV_set(sv, was + 1.0); 8573 return; 8574 } 8575 8576 if (!(flags & SVp_POK) || !*SvPVX_const(sv)) { 8577 if ((flags & SVTYPEMASK) < SVt_PVIV) 8578 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV)); 8579 (void)SvIOK_only(sv); 8580 SvIV_set(sv, 1); 8581 return; 8582 } 8583 d = SvPVX(sv); 8584 while (isALPHA(*d)) d++; 8585 while (isDIGIT(*d)) d++; 8586 if (d < SvEND(sv)) { 8587 #ifdef PERL_PRESERVE_IVUV 8588 /* Got to punt this as an integer if needs be, but we don't issue 8589 warnings. Probably ought to make the sv_iv_please() that does 8590 the conversion if possible, and silently. */ 8591 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL); 8592 if (numtype && !(numtype & IS_NUMBER_INFINITY)) { 8593 /* Need to try really hard to see if it's an integer. 8594 9.22337203685478e+18 is an integer. 8595 but "9.22337203685478e+18" + 0 is UV=9223372036854779904 8596 so $a="9.22337203685478e+18"; $a+0; $a++ 8597 needs to be the same as $a="9.22337203685478e+18"; $a++ 8598 or we go insane. */ 8599 8600 (void) sv_2iv(sv); 8601 if (SvIOK(sv)) 8602 goto oops_its_int; 8603 8604 /* sv_2iv *should* have made this an NV */ 8605 if (flags & SVp_NOK) { 8606 (void)SvNOK_only(sv); 8607 SvNV_set(sv, SvNVX(sv) + 1.0); 8608 return; 8609 } 8610 /* I don't think we can get here. Maybe I should assert this 8611 And if we do get here I suspect that sv_setnv will croak. NWC 8612 Fall through. */ 8613 #if defined(USE_LONG_DOUBLE) 8614 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n", 8615 SvPVX_const(sv), SvIVX(sv), SvNVX(sv))); 8616 #else 8617 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n", 8618 SvPVX_const(sv), SvIVX(sv), SvNVX(sv))); 8619 #endif 8620 } 8621 #endif /* PERL_PRESERVE_IVUV */ 8622 sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0); 8623 return; 8624 } 8625 d--; 8626 while (d >= SvPVX_const(sv)) { 8627 if (isDIGIT(*d)) { 8628 if (++*d <= '9') 8629 return; 8630 *(d--) = '0'; 8631 } 8632 else { 8633 #ifdef EBCDIC 8634 /* MKS: The original code here died if letters weren't consecutive. 8635 * at least it didn't have to worry about non-C locales. The 8636 * new code assumes that ('z'-'a')==('Z'-'A'), letters are 8637 * arranged in order (although not consecutively) and that only 8638 * [A-Za-z] are accepted by isALPHA in the C locale. 8639 */ 8640 if (*d != 'z' && *d != 'Z') { 8641 do { ++*d; } while (!isALPHA(*d)); 8642 return; 8643 } 8644 *(d--) -= 'z' - 'a'; 8645 #else 8646 ++*d; 8647 if (isALPHA(*d)) 8648 return; 8649 *(d--) -= 'z' - 'a' + 1; 8650 #endif 8651 } 8652 } 8653 /* oh,oh, the number grew */ 8654 SvGROW(sv, SvCUR(sv) + 2); 8655 SvCUR_set(sv, SvCUR(sv) + 1); 8656 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--) 8657 *d = d[-1]; 8658 if (isDIGIT(d[1])) 8659 *d = '1'; 8660 else 8661 *d = d[1]; 8662 } 8663 8664 /* 8665 =for apidoc sv_dec 8666 8667 Auto-decrement of the value in the SV, doing string to numeric conversion 8668 if necessary. Handles 'get' magic and operator overloading. 8669 8670 =cut 8671 */ 8672 8673 void 8674 Perl_sv_dec(pTHX_ SV *const sv) 8675 { 8676 dVAR; 8677 if (!sv) 8678 return; 8679 SvGETMAGIC(sv); 8680 sv_dec_nomg(sv); 8681 } 8682 8683 /* 8684 =for apidoc sv_dec_nomg 8685 8686 Auto-decrement of the value in the SV, doing string to numeric conversion 8687 if necessary. Handles operator overloading. Skips handling 'get' magic. 8688 8689 =cut 8690 */ 8691 8692 void 8693 Perl_sv_dec_nomg(pTHX_ SV *const sv) 8694 { 8695 dVAR; 8696 int flags; 8697 8698 if (!sv) 8699 return; 8700 if (SvTHINKFIRST(sv)) { 8701 if (SvREADONLY(sv)) { 8702 Perl_croak_no_modify(); 8703 } 8704 if (SvROK(sv)) { 8705 IV i; 8706 if (SvAMAGIC(sv) && AMG_CALLunary(sv, dec_amg)) 8707 return; 8708 i = PTR2IV(SvRV(sv)); 8709 sv_unref(sv); 8710 sv_setiv(sv, i); 8711 } 8712 else sv_force_normal_flags(sv, 0); 8713 } 8714 /* Unlike sv_inc we don't have to worry about string-never-numbers 8715 and keeping them magic. But we mustn't warn on punting */ 8716 flags = SvFLAGS(sv); 8717 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) { 8718 /* It's publicly an integer, or privately an integer-not-float */ 8719 #ifdef PERL_PRESERVE_IVUV 8720 oops_its_int: 8721 #endif 8722 if (SvIsUV(sv)) { 8723 if (SvUVX(sv) == 0) { 8724 (void)SvIOK_only(sv); 8725 SvIV_set(sv, -1); 8726 } 8727 else { 8728 (void)SvIOK_only_UV(sv); 8729 SvUV_set(sv, SvUVX(sv) - 1); 8730 } 8731 } else { 8732 if (SvIVX(sv) == IV_MIN) { 8733 sv_setnv(sv, (NV)IV_MIN); 8734 goto oops_its_num; 8735 } 8736 else { 8737 (void)SvIOK_only(sv); 8738 SvIV_set(sv, SvIVX(sv) - 1); 8739 } 8740 } 8741 return; 8742 } 8743 if (flags & SVp_NOK) { 8744 oops_its_num: 8745 { 8746 const NV was = SvNVX(sv); 8747 if (NV_OVERFLOWS_INTEGERS_AT && 8748 was <= -NV_OVERFLOWS_INTEGERS_AT) { 8749 /* diag_listed_as: Lost precision when %s %f by 1 */ 8750 Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION), 8751 "Lost precision when decrementing %" NVff " by 1", 8752 was); 8753 } 8754 (void)SvNOK_only(sv); 8755 SvNV_set(sv, was - 1.0); 8756 return; 8757 } 8758 } 8759 if (!(flags & SVp_POK)) { 8760 if ((flags & SVTYPEMASK) < SVt_PVIV) 8761 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV); 8762 SvIV_set(sv, -1); 8763 (void)SvIOK_only(sv); 8764 return; 8765 } 8766 #ifdef PERL_PRESERVE_IVUV 8767 { 8768 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL); 8769 if (numtype && !(numtype & IS_NUMBER_INFINITY)) { 8770 /* Need to try really hard to see if it's an integer. 8771 9.22337203685478e+18 is an integer. 8772 but "9.22337203685478e+18" + 0 is UV=9223372036854779904 8773 so $a="9.22337203685478e+18"; $a+0; $a-- 8774 needs to be the same as $a="9.22337203685478e+18"; $a-- 8775 or we go insane. */ 8776 8777 (void) sv_2iv(sv); 8778 if (SvIOK(sv)) 8779 goto oops_its_int; 8780 8781 /* sv_2iv *should* have made this an NV */ 8782 if (flags & SVp_NOK) { 8783 (void)SvNOK_only(sv); 8784 SvNV_set(sv, SvNVX(sv) - 1.0); 8785 return; 8786 } 8787 /* I don't think we can get here. Maybe I should assert this 8788 And if we do get here I suspect that sv_setnv will croak. NWC 8789 Fall through. */ 8790 #if defined(USE_LONG_DOUBLE) 8791 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n", 8792 SvPVX_const(sv), SvIVX(sv), SvNVX(sv))); 8793 #else 8794 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n", 8795 SvPVX_const(sv), SvIVX(sv), SvNVX(sv))); 8796 #endif 8797 } 8798 } 8799 #endif /* PERL_PRESERVE_IVUV */ 8800 sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */ 8801 } 8802 8803 /* this define is used to eliminate a chunk of duplicated but shared logic 8804 * it has the suffix __SV_C to signal that it isnt API, and isnt meant to be 8805 * used anywhere but here - yves 8806 */ 8807 #define PUSH_EXTEND_MORTAL__SV_C(AnSv) \ 8808 STMT_START { \ 8809 EXTEND_MORTAL(1); \ 8810 PL_tmps_stack[++PL_tmps_ix] = (AnSv); \ 8811 } STMT_END 8812 8813 /* 8814 =for apidoc sv_mortalcopy 8815 8816 Creates a new SV which is a copy of the original SV (using C<sv_setsv>). 8817 The new SV is marked as mortal. It will be destroyed "soon", either by an 8818 explicit call to FREETMPS, or by an implicit call at places such as 8819 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>. 8820 8821 =cut 8822 */ 8823 8824 /* Make a string that will exist for the duration of the expression 8825 * evaluation. Actually, it may have to last longer than that, but 8826 * hopefully we won't free it until it has been assigned to a 8827 * permanent location. */ 8828 8829 SV * 8830 Perl_sv_mortalcopy_flags(pTHX_ SV *const oldstr, U32 flags) 8831 { 8832 dVAR; 8833 SV *sv; 8834 8835 if (flags & SV_GMAGIC) 8836 SvGETMAGIC(oldstr); /* before new_SV, in case it dies */ 8837 new_SV(sv); 8838 sv_setsv_flags(sv,oldstr,flags & ~SV_GMAGIC); 8839 PUSH_EXTEND_MORTAL__SV_C(sv); 8840 SvTEMP_on(sv); 8841 return sv; 8842 } 8843 8844 /* 8845 =for apidoc sv_newmortal 8846 8847 Creates a new null SV which is mortal. The reference count of the SV is 8848 set to 1. It will be destroyed "soon", either by an explicit call to 8849 FREETMPS, or by an implicit call at places such as statement boundaries. 8850 See also C<sv_mortalcopy> and C<sv_2mortal>. 8851 8852 =cut 8853 */ 8854 8855 SV * 8856 Perl_sv_newmortal(pTHX) 8857 { 8858 dVAR; 8859 SV *sv; 8860 8861 new_SV(sv); 8862 SvFLAGS(sv) = SVs_TEMP; 8863 PUSH_EXTEND_MORTAL__SV_C(sv); 8864 return sv; 8865 } 8866 8867 8868 /* 8869 =for apidoc newSVpvn_flags 8870 8871 Creates a new SV and copies a string (which may contain C<NUL> (C<\0>) 8872 characters) into it. The reference count for the 8873 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length 8874 string. You are responsible for ensuring that the source string is at least 8875 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined. 8876 Currently the only flag bits accepted are C<SVf_UTF8> and C<SVs_TEMP>. 8877 If C<SVs_TEMP> is set, then C<sv_2mortal()> is called on the result before 8878 returning. If C<SVf_UTF8> is set, C<s> 8879 is considered to be in UTF-8 and the 8880 C<SVf_UTF8> flag will be set on the new SV. 8881 C<newSVpvn_utf8()> is a convenience wrapper for this function, defined as 8882 8883 #define newSVpvn_utf8(s, len, u) \ 8884 newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) 8885 8886 =cut 8887 */ 8888 8889 SV * 8890 Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags) 8891 { 8892 dVAR; 8893 SV *sv; 8894 8895 /* All the flags we don't support must be zero. 8896 And we're new code so I'm going to assert this from the start. */ 8897 assert(!(flags & ~(SVf_UTF8|SVs_TEMP))); 8898 new_SV(sv); 8899 sv_setpvn(sv,s,len); 8900 8901 /* This code used to do a sv_2mortal(), however we now unroll the call to 8902 * sv_2mortal() and do what it does ourselves here. Since we have asserted 8903 * that flags can only have the SVf_UTF8 and/or SVs_TEMP flags set above we 8904 * can use it to enable the sv flags directly (bypassing SvTEMP_on), which 8905 * in turn means we dont need to mask out the SVf_UTF8 flag below, which 8906 * means that we eliminate quite a few steps than it looks - Yves 8907 * (explaining patch by gfx) */ 8908 8909 SvFLAGS(sv) |= flags; 8910 8911 if(flags & SVs_TEMP){ 8912 PUSH_EXTEND_MORTAL__SV_C(sv); 8913 } 8914 8915 return sv; 8916 } 8917 8918 /* 8919 =for apidoc sv_2mortal 8920 8921 Marks an existing SV as mortal. The SV will be destroyed "soon", either 8922 by an explicit call to FREETMPS, or by an implicit call at places such as 8923 statement boundaries. SvTEMP() is turned on which means that the SV's 8924 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal> 8925 and C<sv_mortalcopy>. 8926 8927 =cut 8928 */ 8929 8930 SV * 8931 Perl_sv_2mortal(pTHX_ SV *const sv) 8932 { 8933 dVAR; 8934 if (!sv) 8935 return NULL; 8936 if (SvIMMORTAL(sv)) 8937 return sv; 8938 PUSH_EXTEND_MORTAL__SV_C(sv); 8939 SvTEMP_on(sv); 8940 return sv; 8941 } 8942 8943 /* 8944 =for apidoc newSVpv 8945 8946 Creates a new SV and copies a string (which may contain C<NUL> (C<\0>) 8947 characters) into it. The reference count for the 8948 SV is set to 1. If C<len> is zero, Perl will compute the length using 8949 strlen(), (which means if you use this option, that C<s> can't have embedded 8950 C<NUL> characters and has to have a terminating C<NUL> byte). 8951 8952 For efficiency, consider using C<newSVpvn> instead. 8953 8954 =cut 8955 */ 8956 8957 SV * 8958 Perl_newSVpv(pTHX_ const char *const s, const STRLEN len) 8959 { 8960 dVAR; 8961 SV *sv; 8962 8963 new_SV(sv); 8964 sv_setpvn(sv, s, len || s == NULL ? len : strlen(s)); 8965 return sv; 8966 } 8967 8968 /* 8969 =for apidoc newSVpvn 8970 8971 Creates a new SV and copies a string into it, which may contain C<NUL> characters 8972 (C<\0>) and other binary data. The reference count for the SV is set to 1. 8973 Note that if C<len> is zero, Perl will create a zero length (Perl) string. You 8974 are responsible for ensuring that the source buffer is at least 8975 C<len> bytes long. If the C<buffer> argument is NULL the new SV will be 8976 undefined. 8977 8978 =cut 8979 */ 8980 8981 SV * 8982 Perl_newSVpvn(pTHX_ const char *const buffer, const STRLEN len) 8983 { 8984 dVAR; 8985 SV *sv; 8986 8987 new_SV(sv); 8988 sv_setpvn(sv,buffer,len); 8989 return sv; 8990 } 8991 8992 /* 8993 =for apidoc newSVhek 8994 8995 Creates a new SV from the hash key structure. It will generate scalars that 8996 point to the shared string table where possible. Returns a new (undefined) 8997 SV if the hek is NULL. 8998 8999 =cut 9000 */ 9001 9002 SV * 9003 Perl_newSVhek(pTHX_ const HEK *const hek) 9004 { 9005 dVAR; 9006 if (!hek) { 9007 SV *sv; 9008 9009 new_SV(sv); 9010 return sv; 9011 } 9012 9013 if (HEK_LEN(hek) == HEf_SVKEY) { 9014 return newSVsv(*(SV**)HEK_KEY(hek)); 9015 } else { 9016 const int flags = HEK_FLAGS(hek); 9017 if (flags & HVhek_WASUTF8) { 9018 /* Trouble :-) 9019 Andreas would like keys he put in as utf8 to come back as utf8 9020 */ 9021 STRLEN utf8_len = HEK_LEN(hek); 9022 SV * const sv = newSV_type(SVt_PV); 9023 char *as_utf8 = (char *)bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len); 9024 /* bytes_to_utf8() allocates a new string, which we can repurpose: */ 9025 sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL); 9026 SvUTF8_on (sv); 9027 return sv; 9028 } else if (flags & HVhek_UNSHARED) { 9029 /* A hash that isn't using shared hash keys has to have 9030 the flag in every key so that we know not to try to call 9031 share_hek_hek on it. */ 9032 9033 SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek)); 9034 if (HEK_UTF8(hek)) 9035 SvUTF8_on (sv); 9036 return sv; 9037 } 9038 /* This will be overwhelminly the most common case. */ 9039 { 9040 /* Inline most of newSVpvn_share(), because share_hek_hek() is far 9041 more efficient than sharepvn(). */ 9042 SV *sv; 9043 9044 new_SV(sv); 9045 sv_upgrade(sv, SVt_PV); 9046 SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek))); 9047 SvCUR_set(sv, HEK_LEN(hek)); 9048 SvLEN_set(sv, 0); 9049 SvIsCOW_on(sv); 9050 SvPOK_on(sv); 9051 if (HEK_UTF8(hek)) 9052 SvUTF8_on(sv); 9053 return sv; 9054 } 9055 } 9056 } 9057 9058 /* 9059 =for apidoc newSVpvn_share 9060 9061 Creates a new SV with its SvPVX_const pointing to a shared string in the string 9062 table. If the string does not already exist in the table, it is 9063 created first. Turns on the SvIsCOW flag (or READONLY 9064 and FAKE in 5.16 and earlier). If the C<hash> parameter 9065 is non-zero, that value is used; otherwise the hash is computed. 9066 The string's hash can later be retrieved from the SV 9067 with the C<SvSHARED_HASH()> macro. The idea here is 9068 that as the string table is used for shared hash keys these strings will have 9069 SvPVX_const == HeKEY and hash lookup will avoid string compare. 9070 9071 =cut 9072 */ 9073 9074 SV * 9075 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash) 9076 { 9077 dVAR; 9078 SV *sv; 9079 bool is_utf8 = FALSE; 9080 const char *const orig_src = src; 9081 9082 if (len < 0) { 9083 STRLEN tmplen = -len; 9084 is_utf8 = TRUE; 9085 /* See the note in hv.c:hv_fetch() --jhi */ 9086 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8); 9087 len = tmplen; 9088 } 9089 if (!hash) 9090 PERL_HASH(hash, src, len); 9091 new_SV(sv); 9092 /* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it 9093 changes here, update it there too. */ 9094 sv_upgrade(sv, SVt_PV); 9095 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash)); 9096 SvCUR_set(sv, len); 9097 SvLEN_set(sv, 0); 9098 SvIsCOW_on(sv); 9099 SvPOK_on(sv); 9100 if (is_utf8) 9101 SvUTF8_on(sv); 9102 if (src != orig_src) 9103 Safefree(src); 9104 return sv; 9105 } 9106 9107 /* 9108 =for apidoc newSVpv_share 9109 9110 Like C<newSVpvn_share>, but takes a C<NUL>-terminated string instead of a 9111 string/length pair. 9112 9113 =cut 9114 */ 9115 9116 SV * 9117 Perl_newSVpv_share(pTHX_ const char *src, U32 hash) 9118 { 9119 return newSVpvn_share(src, strlen(src), hash); 9120 } 9121 9122 #if defined(PERL_IMPLICIT_CONTEXT) 9123 9124 /* pTHX_ magic can't cope with varargs, so this is a no-context 9125 * version of the main function, (which may itself be aliased to us). 9126 * Don't access this version directly. 9127 */ 9128 9129 SV * 9130 Perl_newSVpvf_nocontext(const char *const pat, ...) 9131 { 9132 dTHX; 9133 SV *sv; 9134 va_list args; 9135 9136 PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT; 9137 9138 va_start(args, pat); 9139 sv = vnewSVpvf(pat, &args); 9140 va_end(args); 9141 return sv; 9142 } 9143 #endif 9144 9145 /* 9146 =for apidoc newSVpvf 9147 9148 Creates a new SV and initializes it with the string formatted like 9149 C<sprintf>. 9150 9151 =cut 9152 */ 9153 9154 SV * 9155 Perl_newSVpvf(pTHX_ const char *const pat, ...) 9156 { 9157 SV *sv; 9158 va_list args; 9159 9160 PERL_ARGS_ASSERT_NEWSVPVF; 9161 9162 va_start(args, pat); 9163 sv = vnewSVpvf(pat, &args); 9164 va_end(args); 9165 return sv; 9166 } 9167 9168 /* backend for newSVpvf() and newSVpvf_nocontext() */ 9169 9170 SV * 9171 Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args) 9172 { 9173 dVAR; 9174 SV *sv; 9175 9176 PERL_ARGS_ASSERT_VNEWSVPVF; 9177 9178 new_SV(sv); 9179 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); 9180 return sv; 9181 } 9182 9183 /* 9184 =for apidoc newSVnv 9185 9186 Creates a new SV and copies a floating point value into it. 9187 The reference count for the SV is set to 1. 9188 9189 =cut 9190 */ 9191 9192 SV * 9193 Perl_newSVnv(pTHX_ const NV n) 9194 { 9195 dVAR; 9196 SV *sv; 9197 9198 new_SV(sv); 9199 sv_setnv(sv,n); 9200 return sv; 9201 } 9202 9203 /* 9204 =for apidoc newSViv 9205 9206 Creates a new SV and copies an integer into it. The reference count for the 9207 SV is set to 1. 9208 9209 =cut 9210 */ 9211 9212 SV * 9213 Perl_newSViv(pTHX_ const IV i) 9214 { 9215 dVAR; 9216 SV *sv; 9217 9218 new_SV(sv); 9219 sv_setiv(sv,i); 9220 return sv; 9221 } 9222 9223 /* 9224 =for apidoc newSVuv 9225 9226 Creates a new SV and copies an unsigned integer into it. 9227 The reference count for the SV is set to 1. 9228 9229 =cut 9230 */ 9231 9232 SV * 9233 Perl_newSVuv(pTHX_ const UV u) 9234 { 9235 dVAR; 9236 SV *sv; 9237 9238 new_SV(sv); 9239 sv_setuv(sv,u); 9240 return sv; 9241 } 9242 9243 /* 9244 =for apidoc newSV_type 9245 9246 Creates a new SV, of the type specified. The reference count for the new SV 9247 is set to 1. 9248 9249 =cut 9250 */ 9251 9252 SV * 9253 Perl_newSV_type(pTHX_ const svtype type) 9254 { 9255 SV *sv; 9256 9257 new_SV(sv); 9258 sv_upgrade(sv, type); 9259 return sv; 9260 } 9261 9262 /* 9263 =for apidoc newRV_noinc 9264 9265 Creates an RV wrapper for an SV. The reference count for the original 9266 SV is B<not> incremented. 9267 9268 =cut 9269 */ 9270 9271 SV * 9272 Perl_newRV_noinc(pTHX_ SV *const tmpRef) 9273 { 9274 dVAR; 9275 SV *sv = newSV_type(SVt_IV); 9276 9277 PERL_ARGS_ASSERT_NEWRV_NOINC; 9278 9279 SvTEMP_off(tmpRef); 9280 SvRV_set(sv, tmpRef); 9281 SvROK_on(sv); 9282 return sv; 9283 } 9284 9285 /* newRV_inc is the official function name to use now. 9286 * newRV_inc is in fact #defined to newRV in sv.h 9287 */ 9288 9289 SV * 9290 Perl_newRV(pTHX_ SV *const sv) 9291 { 9292 dVAR; 9293 9294 PERL_ARGS_ASSERT_NEWRV; 9295 9296 return newRV_noinc(SvREFCNT_inc_simple_NN(sv)); 9297 } 9298 9299 /* 9300 =for apidoc newSVsv 9301 9302 Creates a new SV which is an exact duplicate of the original SV. 9303 (Uses C<sv_setsv>.) 9304 9305 =cut 9306 */ 9307 9308 SV * 9309 Perl_newSVsv(pTHX_ SV *const old) 9310 { 9311 dVAR; 9312 SV *sv; 9313 9314 if (!old) 9315 return NULL; 9316 if (SvTYPE(old) == (svtype)SVTYPEMASK) { 9317 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string"); 9318 return NULL; 9319 } 9320 /* Do this here, otherwise we leak the new SV if this croaks. */ 9321 SvGETMAGIC(old); 9322 new_SV(sv); 9323 /* SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games 9324 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */ 9325 sv_setsv_flags(sv, old, SV_NOSTEAL); 9326 return sv; 9327 } 9328 9329 /* 9330 =for apidoc sv_reset 9331 9332 Underlying implementation for the C<reset> Perl function. 9333 Note that the perl-level function is vaguely deprecated. 9334 9335 =cut 9336 */ 9337 9338 void 9339 Perl_sv_reset(pTHX_ const char *s, HV *const stash) 9340 { 9341 PERL_ARGS_ASSERT_SV_RESET; 9342 9343 sv_resetpvn(*s ? s : NULL, strlen(s), stash); 9344 } 9345 9346 void 9347 Perl_sv_resetpvn(pTHX_ const char *s, STRLEN len, HV * const stash) 9348 { 9349 dVAR; 9350 char todo[PERL_UCHAR_MAX+1]; 9351 const char *send; 9352 9353 if (!stash || SvTYPE(stash) != SVt_PVHV) 9354 return; 9355 9356 if (!s) { /* reset ?? searches */ 9357 MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab); 9358 if (mg) { 9359 const U32 count = mg->mg_len / sizeof(PMOP**); 9360 PMOP **pmp = (PMOP**) mg->mg_ptr; 9361 PMOP *const *const end = pmp + count; 9362 9363 while (pmp < end) { 9364 #ifdef USE_ITHREADS 9365 SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]); 9366 #else 9367 (*pmp)->op_pmflags &= ~PMf_USED; 9368 #endif 9369 ++pmp; 9370 } 9371 } 9372 return; 9373 } 9374 9375 /* reset variables */ 9376 9377 if (!HvARRAY(stash)) 9378 return; 9379 9380 Zero(todo, 256, char); 9381 send = s + len; 9382 while (s < send) { 9383 I32 max; 9384 I32 i = (unsigned char)*s; 9385 if (s[1] == '-') { 9386 s += 2; 9387 } 9388 max = (unsigned char)*s++; 9389 for ( ; i <= max; i++) { 9390 todo[i] = 1; 9391 } 9392 for (i = 0; i <= (I32) HvMAX(stash); i++) { 9393 HE *entry; 9394 for (entry = HvARRAY(stash)[i]; 9395 entry; 9396 entry = HeNEXT(entry)) 9397 { 9398 GV *gv; 9399 SV *sv; 9400 9401 if (!todo[(U8)*HeKEY(entry)]) 9402 continue; 9403 gv = MUTABLE_GV(HeVAL(entry)); 9404 sv = GvSV(gv); 9405 if (sv && !SvREADONLY(sv)) { 9406 SV_CHECK_THINKFIRST_COW_DROP(sv); 9407 if (!isGV(sv)) SvOK_off(sv); 9408 } 9409 if (GvAV(gv)) { 9410 av_clear(GvAV(gv)); 9411 } 9412 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) { 9413 hv_clear(GvHV(gv)); 9414 } 9415 } 9416 } 9417 } 9418 } 9419 9420 /* 9421 =for apidoc sv_2io 9422 9423 Using various gambits, try to get an IO from an SV: the IO slot if its a 9424 GV; or the recursive result if we're an RV; or the IO slot of the symbol 9425 named after the PV if we're a string. 9426 9427 'Get' magic is ignored on the sv passed in, but will be called on 9428 C<SvRV(sv)> if sv is an RV. 9429 9430 =cut 9431 */ 9432 9433 IO* 9434 Perl_sv_2io(pTHX_ SV *const sv) 9435 { 9436 IO* io; 9437 GV* gv; 9438 9439 PERL_ARGS_ASSERT_SV_2IO; 9440 9441 switch (SvTYPE(sv)) { 9442 case SVt_PVIO: 9443 io = MUTABLE_IO(sv); 9444 break; 9445 case SVt_PVGV: 9446 case SVt_PVLV: 9447 if (isGV_with_GP(sv)) { 9448 gv = MUTABLE_GV(sv); 9449 io = GvIO(gv); 9450 if (!io) 9451 Perl_croak(aTHX_ "Bad filehandle: %"HEKf, 9452 HEKfARG(GvNAME_HEK(gv))); 9453 break; 9454 } 9455 /* FALL THROUGH */ 9456 default: 9457 if (!SvOK(sv)) 9458 Perl_croak(aTHX_ PL_no_usym, "filehandle"); 9459 if (SvROK(sv)) { 9460 SvGETMAGIC(SvRV(sv)); 9461 return sv_2io(SvRV(sv)); 9462 } 9463 gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO); 9464 if (gv) 9465 io = GvIO(gv); 9466 else 9467 io = 0; 9468 if (!io) { 9469 SV *newsv = sv; 9470 if (SvGMAGICAL(sv)) { 9471 newsv = sv_newmortal(); 9472 sv_setsv_nomg(newsv, sv); 9473 } 9474 Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(newsv)); 9475 } 9476 break; 9477 } 9478 return io; 9479 } 9480 9481 /* 9482 =for apidoc sv_2cv 9483 9484 Using various gambits, try to get a CV from an SV; in addition, try if 9485 possible to set C<*st> and C<*gvp> to the stash and GV associated with it. 9486 The flags in C<lref> are passed to gv_fetchsv. 9487 9488 =cut 9489 */ 9490 9491 CV * 9492 Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref) 9493 { 9494 dVAR; 9495 GV *gv = NULL; 9496 CV *cv = NULL; 9497 9498 PERL_ARGS_ASSERT_SV_2CV; 9499 9500 if (!sv) { 9501 *st = NULL; 9502 *gvp = NULL; 9503 return NULL; 9504 } 9505 switch (SvTYPE(sv)) { 9506 case SVt_PVCV: 9507 *st = CvSTASH(sv); 9508 *gvp = NULL; 9509 return MUTABLE_CV(sv); 9510 case SVt_PVHV: 9511 case SVt_PVAV: 9512 *st = NULL; 9513 *gvp = NULL; 9514 return NULL; 9515 default: 9516 SvGETMAGIC(sv); 9517 if (SvROK(sv)) { 9518 if (SvAMAGIC(sv)) 9519 sv = amagic_deref_call(sv, to_cv_amg); 9520 9521 sv = SvRV(sv); 9522 if (SvTYPE(sv) == SVt_PVCV) { 9523 cv = MUTABLE_CV(sv); 9524 *gvp = NULL; 9525 *st = CvSTASH(cv); 9526 return cv; 9527 } 9528 else if(SvGETMAGIC(sv), isGV_with_GP(sv)) 9529 gv = MUTABLE_GV(sv); 9530 else 9531 Perl_croak(aTHX_ "Not a subroutine reference"); 9532 } 9533 else if (isGV_with_GP(sv)) { 9534 gv = MUTABLE_GV(sv); 9535 } 9536 else { 9537 gv = gv_fetchsv_nomg(sv, lref, SVt_PVCV); 9538 } 9539 *gvp = gv; 9540 if (!gv) { 9541 *st = NULL; 9542 return NULL; 9543 } 9544 /* Some flags to gv_fetchsv mean don't really create the GV */ 9545 if (!isGV_with_GP(gv)) { 9546 *st = NULL; 9547 return NULL; 9548 } 9549 *st = GvESTASH(gv); 9550 if (lref & ~GV_ADDMG && !GvCVu(gv)) { 9551 /* XXX this is probably not what they think they're getting. 9552 * It has the same effect as "sub name;", i.e. just a forward 9553 * declaration! */ 9554 newSTUB(gv,0); 9555 } 9556 return GvCVu(gv); 9557 } 9558 } 9559 9560 /* 9561 =for apidoc sv_true 9562 9563 Returns true if the SV has a true value by Perl's rules. 9564 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may 9565 instead use an in-line version. 9566 9567 =cut 9568 */ 9569 9570 I32 9571 Perl_sv_true(pTHX_ SV *const sv) 9572 { 9573 if (!sv) 9574 return 0; 9575 if (SvPOK(sv)) { 9576 const XPV* const tXpv = (XPV*)SvANY(sv); 9577 if (tXpv && 9578 (tXpv->xpv_cur > 1 || 9579 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0'))) 9580 return 1; 9581 else 9582 return 0; 9583 } 9584 else { 9585 if (SvIOK(sv)) 9586 return SvIVX(sv) != 0; 9587 else { 9588 if (SvNOK(sv)) 9589 return SvNVX(sv) != 0.0; 9590 else 9591 return sv_2bool(sv); 9592 } 9593 } 9594 } 9595 9596 /* 9597 =for apidoc sv_pvn_force 9598 9599 Get a sensible string out of the SV somehow. 9600 A private implementation of the C<SvPV_force> macro for compilers which 9601 can't cope with complex macro expressions. Always use the macro instead. 9602 9603 =for apidoc sv_pvn_force_flags 9604 9605 Get a sensible string out of the SV somehow. 9606 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if 9607 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are 9608 implemented in terms of this function. 9609 You normally want to use the various wrapper macros instead: see 9610 C<SvPV_force> and C<SvPV_force_nomg> 9611 9612 =cut 9613 */ 9614 9615 char * 9616 Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) 9617 { 9618 dVAR; 9619 9620 PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS; 9621 9622 if (flags & SV_GMAGIC) SvGETMAGIC(sv); 9623 if (SvTHINKFIRST(sv) && (!SvROK(sv) || SvREADONLY(sv))) 9624 sv_force_normal_flags(sv, 0); 9625 9626 if (SvPOK(sv)) { 9627 if (lp) 9628 *lp = SvCUR(sv); 9629 } 9630 else { 9631 char *s; 9632 STRLEN len; 9633 9634 if (SvTYPE(sv) > SVt_PVLV 9635 || isGV_with_GP(sv)) 9636 /* diag_listed_as: Can't coerce %s to %s in %s */ 9637 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0), 9638 OP_DESC(PL_op)); 9639 s = sv_2pv_flags(sv, &len, flags &~ SV_GMAGIC); 9640 if (!s) { 9641 s = (char *)""; 9642 } 9643 if (lp) 9644 *lp = len; 9645 9646 if (SvTYPE(sv) < SVt_PV || 9647 s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */ 9648 if (SvROK(sv)) 9649 sv_unref(sv); 9650 SvUPGRADE(sv, SVt_PV); /* Never FALSE */ 9651 SvGROW(sv, len + 1); 9652 Move(s,SvPVX(sv),len,char); 9653 SvCUR_set(sv, len); 9654 SvPVX(sv)[len] = '\0'; 9655 } 9656 if (!SvPOK(sv)) { 9657 SvPOK_on(sv); /* validate pointer */ 9658 SvTAINT(sv); 9659 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n", 9660 PTR2UV(sv),SvPVX_const(sv))); 9661 } 9662 } 9663 (void)SvPOK_only_UTF8(sv); 9664 return SvPVX_mutable(sv); 9665 } 9666 9667 /* 9668 =for apidoc sv_pvbyten_force 9669 9670 The backend for the C<SvPVbytex_force> macro. Always use the macro 9671 instead. 9672 9673 =cut 9674 */ 9675 9676 char * 9677 Perl_sv_pvbyten_force(pTHX_ SV *const sv, STRLEN *const lp) 9678 { 9679 PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE; 9680 9681 sv_pvn_force(sv,lp); 9682 sv_utf8_downgrade(sv,0); 9683 *lp = SvCUR(sv); 9684 return SvPVX(sv); 9685 } 9686 9687 /* 9688 =for apidoc sv_pvutf8n_force 9689 9690 The backend for the C<SvPVutf8x_force> macro. Always use the macro 9691 instead. 9692 9693 =cut 9694 */ 9695 9696 char * 9697 Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp) 9698 { 9699 PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE; 9700 9701 sv_pvn_force(sv,0); 9702 sv_utf8_upgrade_nomg(sv); 9703 *lp = SvCUR(sv); 9704 return SvPVX(sv); 9705 } 9706 9707 /* 9708 =for apidoc sv_reftype 9709 9710 Returns a string describing what the SV is a reference to. 9711 9712 =cut 9713 */ 9714 9715 const char * 9716 Perl_sv_reftype(pTHX_ const SV *const sv, const int ob) 9717 { 9718 PERL_ARGS_ASSERT_SV_REFTYPE; 9719 if (ob && SvOBJECT(sv)) { 9720 return SvPV_nolen_const(sv_ref(NULL, sv, ob)); 9721 } 9722 else { 9723 /* WARNING - There is code, for instance in mg.c, that assumes that 9724 * the only reason that sv_reftype(sv,0) would return a string starting 9725 * with 'L' or 'S' is that it is a LVALUE or a SCALAR. 9726 * Yes this a dodgy way to do type checking, but it saves practically reimplementing 9727 * this routine inside other subs, and it saves time. 9728 * Do not change this assumption without searching for "dodgy type check" in 9729 * the code. 9730 * - Yves */ 9731 switch (SvTYPE(sv)) { 9732 case SVt_NULL: 9733 case SVt_IV: 9734 case SVt_NV: 9735 case SVt_PV: 9736 case SVt_PVIV: 9737 case SVt_PVNV: 9738 case SVt_PVMG: 9739 if (SvVOK(sv)) 9740 return "VSTRING"; 9741 if (SvROK(sv)) 9742 return "REF"; 9743 else 9744 return "SCALAR"; 9745 9746 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF" 9747 /* tied lvalues should appear to be 9748 * scalars for backwards compatibility */ 9749 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T') 9750 ? "SCALAR" : "LVALUE"); 9751 case SVt_PVAV: return "ARRAY"; 9752 case SVt_PVHV: return "HASH"; 9753 case SVt_PVCV: return "CODE"; 9754 case SVt_PVGV: return (char *) (isGV_with_GP(sv) 9755 ? "GLOB" : "SCALAR"); 9756 case SVt_PVFM: return "FORMAT"; 9757 case SVt_PVIO: return "IO"; 9758 case SVt_INVLIST: return "INVLIST"; 9759 case SVt_REGEXP: return "REGEXP"; 9760 default: return "UNKNOWN"; 9761 } 9762 } 9763 } 9764 9765 /* 9766 =for apidoc sv_ref 9767 9768 Returns a SV describing what the SV passed in is a reference to. 9769 9770 =cut 9771 */ 9772 9773 SV * 9774 Perl_sv_ref(pTHX_ SV *dst, const SV *const sv, const int ob) 9775 { 9776 PERL_ARGS_ASSERT_SV_REF; 9777 9778 if (!dst) 9779 dst = sv_newmortal(); 9780 9781 if (ob && SvOBJECT(sv)) { 9782 HvNAME_get(SvSTASH(sv)) 9783 ? sv_sethek(dst, HvNAME_HEK(SvSTASH(sv))) 9784 : sv_setpvn(dst, "__ANON__", 8); 9785 } 9786 else { 9787 const char * reftype = sv_reftype(sv, 0); 9788 sv_setpv(dst, reftype); 9789 } 9790 return dst; 9791 } 9792 9793 /* 9794 =for apidoc sv_isobject 9795 9796 Returns a boolean indicating whether the SV is an RV pointing to a blessed 9797 object. If the SV is not an RV, or if the object is not blessed, then this 9798 will return false. 9799 9800 =cut 9801 */ 9802 9803 int 9804 Perl_sv_isobject(pTHX_ SV *sv) 9805 { 9806 if (!sv) 9807 return 0; 9808 SvGETMAGIC(sv); 9809 if (!SvROK(sv)) 9810 return 0; 9811 sv = SvRV(sv); 9812 if (!SvOBJECT(sv)) 9813 return 0; 9814 return 1; 9815 } 9816 9817 /* 9818 =for apidoc sv_isa 9819 9820 Returns a boolean indicating whether the SV is blessed into the specified 9821 class. This does not check for subtypes; use C<sv_derived_from> to verify 9822 an inheritance relationship. 9823 9824 =cut 9825 */ 9826 9827 int 9828 Perl_sv_isa(pTHX_ SV *sv, const char *const name) 9829 { 9830 const char *hvname; 9831 9832 PERL_ARGS_ASSERT_SV_ISA; 9833 9834 if (!sv) 9835 return 0; 9836 SvGETMAGIC(sv); 9837 if (!SvROK(sv)) 9838 return 0; 9839 sv = SvRV(sv); 9840 if (!SvOBJECT(sv)) 9841 return 0; 9842 hvname = HvNAME_get(SvSTASH(sv)); 9843 if (!hvname) 9844 return 0; 9845 9846 return strEQ(hvname, name); 9847 } 9848 9849 /* 9850 =for apidoc newSVrv 9851 9852 Creates a new SV for the existing RV, C<rv>, to point to. If C<rv> is not an 9853 RV then it will be upgraded to one. If C<classname> is non-null then the new 9854 SV will be blessed in the specified package. The new SV is returned and its 9855 reference count is 1. The reference count 1 is owned by C<rv>. 9856 9857 =cut 9858 */ 9859 9860 SV* 9861 Perl_newSVrv(pTHX_ SV *const rv, const char *const classname) 9862 { 9863 dVAR; 9864 SV *sv; 9865 9866 PERL_ARGS_ASSERT_NEWSVRV; 9867 9868 new_SV(sv); 9869 9870 SV_CHECK_THINKFIRST_COW_DROP(rv); 9871 9872 if (SvTYPE(rv) >= SVt_PVMG) { 9873 const U32 refcnt = SvREFCNT(rv); 9874 SvREFCNT(rv) = 0; 9875 sv_clear(rv); 9876 SvFLAGS(rv) = 0; 9877 SvREFCNT(rv) = refcnt; 9878 9879 sv_upgrade(rv, SVt_IV); 9880 } else if (SvROK(rv)) { 9881 SvREFCNT_dec(SvRV(rv)); 9882 } else { 9883 prepare_SV_for_RV(rv); 9884 } 9885 9886 SvOK_off(rv); 9887 SvRV_set(rv, sv); 9888 SvROK_on(rv); 9889 9890 if (classname) { 9891 HV* const stash = gv_stashpv(classname, GV_ADD); 9892 (void)sv_bless(rv, stash); 9893 } 9894 return sv; 9895 } 9896 9897 SV * 9898 Perl_newSVavdefelem(pTHX_ AV *av, SSize_t ix, bool extendible) 9899 { 9900 SV * const lv = newSV_type(SVt_PVLV); 9901 PERL_ARGS_ASSERT_NEWSVAVDEFELEM; 9902 LvTYPE(lv) = 'y'; 9903 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0); 9904 LvTARG(lv) = SvREFCNT_inc_simple_NN(av); 9905 LvSTARGOFF(lv) = ix; 9906 LvTARGLEN(lv) = extendible ? 1 : (STRLEN)UV_MAX; 9907 return lv; 9908 } 9909 9910 /* 9911 =for apidoc sv_setref_pv 9912 9913 Copies a pointer into a new SV, optionally blessing the SV. The C<rv> 9914 argument will be upgraded to an RV. That RV will be modified to point to 9915 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed 9916 into the SV. The C<classname> argument indicates the package for the 9917 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV 9918 will have a reference count of 1, and the RV will be returned. 9919 9920 Do not use with other Perl types such as HV, AV, SV, CV, because those 9921 objects will become corrupted by the pointer copy process. 9922 9923 Note that C<sv_setref_pvn> copies the string while this copies the pointer. 9924 9925 =cut 9926 */ 9927 9928 SV* 9929 Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv) 9930 { 9931 dVAR; 9932 9933 PERL_ARGS_ASSERT_SV_SETREF_PV; 9934 9935 if (!pv) { 9936 sv_setsv(rv, &PL_sv_undef); 9937 SvSETMAGIC(rv); 9938 } 9939 else 9940 sv_setiv(newSVrv(rv,classname), PTR2IV(pv)); 9941 return rv; 9942 } 9943 9944 /* 9945 =for apidoc sv_setref_iv 9946 9947 Copies an integer into a new SV, optionally blessing the SV. The C<rv> 9948 argument will be upgraded to an RV. That RV will be modified to point to 9949 the new SV. The C<classname> argument indicates the package for the 9950 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV 9951 will have a reference count of 1, and the RV will be returned. 9952 9953 =cut 9954 */ 9955 9956 SV* 9957 Perl_sv_setref_iv(pTHX_ SV *const rv, const char *const classname, const IV iv) 9958 { 9959 PERL_ARGS_ASSERT_SV_SETREF_IV; 9960 9961 sv_setiv(newSVrv(rv,classname), iv); 9962 return rv; 9963 } 9964 9965 /* 9966 =for apidoc sv_setref_uv 9967 9968 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv> 9969 argument will be upgraded to an RV. That RV will be modified to point to 9970 the new SV. The C<classname> argument indicates the package for the 9971 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV 9972 will have a reference count of 1, and the RV will be returned. 9973 9974 =cut 9975 */ 9976 9977 SV* 9978 Perl_sv_setref_uv(pTHX_ SV *const rv, const char *const classname, const UV uv) 9979 { 9980 PERL_ARGS_ASSERT_SV_SETREF_UV; 9981 9982 sv_setuv(newSVrv(rv,classname), uv); 9983 return rv; 9984 } 9985 9986 /* 9987 =for apidoc sv_setref_nv 9988 9989 Copies a double into a new SV, optionally blessing the SV. The C<rv> 9990 argument will be upgraded to an RV. That RV will be modified to point to 9991 the new SV. The C<classname> argument indicates the package for the 9992 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV 9993 will have a reference count of 1, and the RV will be returned. 9994 9995 =cut 9996 */ 9997 9998 SV* 9999 Perl_sv_setref_nv(pTHX_ SV *const rv, const char *const classname, const NV nv) 10000 { 10001 PERL_ARGS_ASSERT_SV_SETREF_NV; 10002 10003 sv_setnv(newSVrv(rv,classname), nv); 10004 return rv; 10005 } 10006 10007 /* 10008 =for apidoc sv_setref_pvn 10009 10010 Copies a string into a new SV, optionally blessing the SV. The length of the 10011 string must be specified with C<n>. The C<rv> argument will be upgraded to 10012 an RV. That RV will be modified to point to the new SV. The C<classname> 10013 argument indicates the package for the blessing. Set C<classname> to 10014 C<NULL> to avoid the blessing. The new SV will have a reference count 10015 of 1, and the RV will be returned. 10016 10017 Note that C<sv_setref_pv> copies the pointer while this copies the string. 10018 10019 =cut 10020 */ 10021 10022 SV* 10023 Perl_sv_setref_pvn(pTHX_ SV *const rv, const char *const classname, 10024 const char *const pv, const STRLEN n) 10025 { 10026 PERL_ARGS_ASSERT_SV_SETREF_PVN; 10027 10028 sv_setpvn(newSVrv(rv,classname), pv, n); 10029 return rv; 10030 } 10031 10032 /* 10033 =for apidoc sv_bless 10034 10035 Blesses an SV into a specified package. The SV must be an RV. The package 10036 must be designated by its stash (see C<gv_stashpv()>). The reference count 10037 of the SV is unaffected. 10038 10039 =cut 10040 */ 10041 10042 SV* 10043 Perl_sv_bless(pTHX_ SV *const sv, HV *const stash) 10044 { 10045 dVAR; 10046 SV *tmpRef; 10047 HV *oldstash = NULL; 10048 10049 PERL_ARGS_ASSERT_SV_BLESS; 10050 10051 SvGETMAGIC(sv); 10052 if (!SvROK(sv)) 10053 Perl_croak(aTHX_ "Can't bless non-reference value"); 10054 tmpRef = SvRV(sv); 10055 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) { 10056 if (SvREADONLY(tmpRef)) 10057 Perl_croak_no_modify(); 10058 if (SvOBJECT(tmpRef)) { 10059 oldstash = SvSTASH(tmpRef); 10060 } 10061 } 10062 SvOBJECT_on(tmpRef); 10063 SvUPGRADE(tmpRef, SVt_PVMG); 10064 SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash))); 10065 SvREFCNT_dec(oldstash); 10066 10067 if(SvSMAGICAL(tmpRef)) 10068 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar)) 10069 mg_set(tmpRef); 10070 10071 10072 10073 return sv; 10074 } 10075 10076 /* Downgrades a PVGV to a PVMG. If it's actually a PVLV, we leave the type 10077 * as it is after unglobbing it. 10078 */ 10079 10080 PERL_STATIC_INLINE void 10081 S_sv_unglob(pTHX_ SV *const sv, U32 flags) 10082 { 10083 dVAR; 10084 void *xpvmg; 10085 HV *stash; 10086 SV * const temp = flags & SV_COW_DROP_PV ? NULL : sv_newmortal(); 10087 10088 PERL_ARGS_ASSERT_SV_UNGLOB; 10089 10090 assert(SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV); 10091 SvFAKE_off(sv); 10092 if (!(flags & SV_COW_DROP_PV)) 10093 gv_efullname3(temp, MUTABLE_GV(sv), "*"); 10094 10095 SvREFCNT_inc_simple_void_NN(sv_2mortal(sv)); 10096 if (GvGP(sv)) { 10097 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv))) 10098 && HvNAME_get(stash)) 10099 mro_method_changed_in(stash); 10100 gp_free(MUTABLE_GV(sv)); 10101 } 10102 if (GvSTASH(sv)) { 10103 sv_del_backref(MUTABLE_SV(GvSTASH(sv)), sv); 10104 GvSTASH(sv) = NULL; 10105 } 10106 GvMULTI_off(sv); 10107 if (GvNAME_HEK(sv)) { 10108 unshare_hek(GvNAME_HEK(sv)); 10109 } 10110 isGV_with_GP_off(sv); 10111 10112 if(SvTYPE(sv) == SVt_PVGV) { 10113 /* need to keep SvANY(sv) in the right arena */ 10114 xpvmg = new_XPVMG(); 10115 StructCopy(SvANY(sv), xpvmg, XPVMG); 10116 del_XPVGV(SvANY(sv)); 10117 SvANY(sv) = xpvmg; 10118 10119 SvFLAGS(sv) &= ~SVTYPEMASK; 10120 SvFLAGS(sv) |= SVt_PVMG; 10121 } 10122 10123 /* Intentionally not calling any local SET magic, as this isn't so much a 10124 set operation as merely an internal storage change. */ 10125 if (flags & SV_COW_DROP_PV) SvOK_off(sv); 10126 else sv_setsv_flags(sv, temp, 0); 10127 10128 if ((const GV *)sv == PL_last_in_gv) 10129 PL_last_in_gv = NULL; 10130 else if ((const GV *)sv == PL_statgv) 10131 PL_statgv = NULL; 10132 } 10133 10134 /* 10135 =for apidoc sv_unref_flags 10136 10137 Unsets the RV status of the SV, and decrements the reference count of 10138 whatever was being referenced by the RV. This can almost be thought of 10139 as a reversal of C<newSVrv>. The C<cflags> argument can contain 10140 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented 10141 (otherwise the decrementing is conditional on the reference count being 10142 different from one or the reference being a readonly SV). 10143 See C<SvROK_off>. 10144 10145 =cut 10146 */ 10147 10148 void 10149 Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags) 10150 { 10151 SV* const target = SvRV(ref); 10152 10153 PERL_ARGS_ASSERT_SV_UNREF_FLAGS; 10154 10155 if (SvWEAKREF(ref)) { 10156 sv_del_backref(target, ref); 10157 SvWEAKREF_off(ref); 10158 SvRV_set(ref, NULL); 10159 return; 10160 } 10161 SvRV_set(ref, NULL); 10162 SvROK_off(ref); 10163 /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was 10164 assigned to as BEGIN {$a = \"Foo"} will fail. */ 10165 if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF)) 10166 SvREFCNT_dec_NN(target); 10167 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */ 10168 sv_2mortal(target); /* Schedule for freeing later */ 10169 } 10170 10171 /* 10172 =for apidoc sv_untaint 10173 10174 Untaint an SV. Use C<SvTAINTED_off> instead. 10175 10176 =cut 10177 */ 10178 10179 void 10180 Perl_sv_untaint(pTHX_ SV *const sv) 10181 { 10182 PERL_ARGS_ASSERT_SV_UNTAINT; 10183 10184 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { 10185 MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint); 10186 if (mg) 10187 mg->mg_len &= ~1; 10188 } 10189 } 10190 10191 /* 10192 =for apidoc sv_tainted 10193 10194 Test an SV for taintedness. Use C<SvTAINTED> instead. 10195 10196 =cut 10197 */ 10198 10199 bool 10200 Perl_sv_tainted(pTHX_ SV *const sv) 10201 { 10202 PERL_ARGS_ASSERT_SV_TAINTED; 10203 10204 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { 10205 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint); 10206 if (mg && (mg->mg_len & 1) ) 10207 return TRUE; 10208 } 10209 return FALSE; 10210 } 10211 10212 /* 10213 =for apidoc sv_setpviv 10214 10215 Copies an integer into the given SV, also updating its string value. 10216 Does not handle 'set' magic. See C<sv_setpviv_mg>. 10217 10218 =cut 10219 */ 10220 10221 void 10222 Perl_sv_setpviv(pTHX_ SV *const sv, const IV iv) 10223 { 10224 char buf[TYPE_CHARS(UV)]; 10225 char *ebuf; 10226 char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf); 10227 10228 PERL_ARGS_ASSERT_SV_SETPVIV; 10229 10230 sv_setpvn(sv, ptr, ebuf - ptr); 10231 } 10232 10233 /* 10234 =for apidoc sv_setpviv_mg 10235 10236 Like C<sv_setpviv>, but also handles 'set' magic. 10237 10238 =cut 10239 */ 10240 10241 void 10242 Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv) 10243 { 10244 PERL_ARGS_ASSERT_SV_SETPVIV_MG; 10245 10246 sv_setpviv(sv, iv); 10247 SvSETMAGIC(sv); 10248 } 10249 10250 #if defined(PERL_IMPLICIT_CONTEXT) 10251 10252 /* pTHX_ magic can't cope with varargs, so this is a no-context 10253 * version of the main function, (which may itself be aliased to us). 10254 * Don't access this version directly. 10255 */ 10256 10257 void 10258 Perl_sv_setpvf_nocontext(SV *const sv, const char *const pat, ...) 10259 { 10260 dTHX; 10261 va_list args; 10262 10263 PERL_ARGS_ASSERT_SV_SETPVF_NOCONTEXT; 10264 10265 va_start(args, pat); 10266 sv_vsetpvf(sv, pat, &args); 10267 va_end(args); 10268 } 10269 10270 /* pTHX_ magic can't cope with varargs, so this is a no-context 10271 * version of the main function, (which may itself be aliased to us). 10272 * Don't access this version directly. 10273 */ 10274 10275 void 10276 Perl_sv_setpvf_mg_nocontext(SV *const sv, const char *const pat, ...) 10277 { 10278 dTHX; 10279 va_list args; 10280 10281 PERL_ARGS_ASSERT_SV_SETPVF_MG_NOCONTEXT; 10282 10283 va_start(args, pat); 10284 sv_vsetpvf_mg(sv, pat, &args); 10285 va_end(args); 10286 } 10287 #endif 10288 10289 /* 10290 =for apidoc sv_setpvf 10291 10292 Works like C<sv_catpvf> but copies the text into the SV instead of 10293 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>. 10294 10295 =cut 10296 */ 10297 10298 void 10299 Perl_sv_setpvf(pTHX_ SV *const sv, const char *const pat, ...) 10300 { 10301 va_list args; 10302 10303 PERL_ARGS_ASSERT_SV_SETPVF; 10304 10305 va_start(args, pat); 10306 sv_vsetpvf(sv, pat, &args); 10307 va_end(args); 10308 } 10309 10310 /* 10311 =for apidoc sv_vsetpvf 10312 10313 Works like C<sv_vcatpvf> but copies the text into the SV instead of 10314 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>. 10315 10316 Usually used via its frontend C<sv_setpvf>. 10317 10318 =cut 10319 */ 10320 10321 void 10322 Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args) 10323 { 10324 PERL_ARGS_ASSERT_SV_VSETPVF; 10325 10326 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); 10327 } 10328 10329 /* 10330 =for apidoc sv_setpvf_mg 10331 10332 Like C<sv_setpvf>, but also handles 'set' magic. 10333 10334 =cut 10335 */ 10336 10337 void 10338 Perl_sv_setpvf_mg(pTHX_ SV *const sv, const char *const pat, ...) 10339 { 10340 va_list args; 10341 10342 PERL_ARGS_ASSERT_SV_SETPVF_MG; 10343 10344 va_start(args, pat); 10345 sv_vsetpvf_mg(sv, pat, &args); 10346 va_end(args); 10347 } 10348 10349 /* 10350 =for apidoc sv_vsetpvf_mg 10351 10352 Like C<sv_vsetpvf>, but also handles 'set' magic. 10353 10354 Usually used via its frontend C<sv_setpvf_mg>. 10355 10356 =cut 10357 */ 10358 10359 void 10360 Perl_sv_vsetpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args) 10361 { 10362 PERL_ARGS_ASSERT_SV_VSETPVF_MG; 10363 10364 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); 10365 SvSETMAGIC(sv); 10366 } 10367 10368 #if defined(PERL_IMPLICIT_CONTEXT) 10369 10370 /* pTHX_ magic can't cope with varargs, so this is a no-context 10371 * version of the main function, (which may itself be aliased to us). 10372 * Don't access this version directly. 10373 */ 10374 10375 void 10376 Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...) 10377 { 10378 dTHX; 10379 va_list args; 10380 10381 PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT; 10382 10383 va_start(args, pat); 10384 sv_vcatpvfn_flags(sv, pat, strlen(pat), &args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC); 10385 va_end(args); 10386 } 10387 10388 /* pTHX_ magic can't cope with varargs, so this is a no-context 10389 * version of the main function, (which may itself be aliased to us). 10390 * Don't access this version directly. 10391 */ 10392 10393 void 10394 Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...) 10395 { 10396 dTHX; 10397 va_list args; 10398 10399 PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT; 10400 10401 va_start(args, pat); 10402 sv_vcatpvfn_flags(sv, pat, strlen(pat), &args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC); 10403 SvSETMAGIC(sv); 10404 va_end(args); 10405 } 10406 #endif 10407 10408 /* 10409 =for apidoc sv_catpvf 10410 10411 Processes its arguments like C<sprintf> and appends the formatted 10412 output to an SV. If the appended data contains "wide" characters 10413 (including, but not limited to, SVs with a UTF-8 PV formatted with %s, 10414 and characters >255 formatted with %c), the original SV might get 10415 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See 10416 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be 10417 valid UTF-8; if the original SV was bytes, the pattern should be too. 10418 10419 =cut */ 10420 10421 void 10422 Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...) 10423 { 10424 va_list args; 10425 10426 PERL_ARGS_ASSERT_SV_CATPVF; 10427 10428 va_start(args, pat); 10429 sv_vcatpvfn_flags(sv, pat, strlen(pat), &args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC); 10430 va_end(args); 10431 } 10432 10433 /* 10434 =for apidoc sv_vcatpvf 10435 10436 Processes its arguments like C<vsprintf> and appends the formatted output 10437 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>. 10438 10439 Usually used via its frontend C<sv_catpvf>. 10440 10441 =cut 10442 */ 10443 10444 void 10445 Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args) 10446 { 10447 PERL_ARGS_ASSERT_SV_VCATPVF; 10448 10449 sv_vcatpvfn_flags(sv, pat, strlen(pat), args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC); 10450 } 10451 10452 /* 10453 =for apidoc sv_catpvf_mg 10454 10455 Like C<sv_catpvf>, but also handles 'set' magic. 10456 10457 =cut 10458 */ 10459 10460 void 10461 Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...) 10462 { 10463 va_list args; 10464 10465 PERL_ARGS_ASSERT_SV_CATPVF_MG; 10466 10467 va_start(args, pat); 10468 sv_vcatpvfn_flags(sv, pat, strlen(pat), &args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC); 10469 SvSETMAGIC(sv); 10470 va_end(args); 10471 } 10472 10473 /* 10474 =for apidoc sv_vcatpvf_mg 10475 10476 Like C<sv_vcatpvf>, but also handles 'set' magic. 10477 10478 Usually used via its frontend C<sv_catpvf_mg>. 10479 10480 =cut 10481 */ 10482 10483 void 10484 Perl_sv_vcatpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args) 10485 { 10486 PERL_ARGS_ASSERT_SV_VCATPVF_MG; 10487 10488 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); 10489 SvSETMAGIC(sv); 10490 } 10491 10492 /* 10493 =for apidoc sv_vsetpvfn 10494 10495 Works like C<sv_vcatpvfn> but copies the text into the SV instead of 10496 appending it. 10497 10498 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>. 10499 10500 =cut 10501 */ 10502 10503 void 10504 Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, 10505 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted) 10506 { 10507 PERL_ARGS_ASSERT_SV_VSETPVFN; 10508 10509 sv_setpvs(sv, ""); 10510 sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, 0); 10511 } 10512 10513 10514 /* 10515 * Warn of missing argument to sprintf, and then return a defined value 10516 * to avoid inappropriate "use of uninit" warnings [perl #71000]. 10517 */ 10518 #define WARN_MISSING WARN_UNINITIALIZED /* Not sure we want a new category */ 10519 STATIC SV* 10520 S_vcatpvfn_missing_argument(pTHX) { 10521 if (ckWARN(WARN_MISSING)) { 10522 Perl_warner(aTHX_ packWARN(WARN_MISSING), "Missing argument in %s", 10523 PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()"); 10524 } 10525 return &PL_sv_no; 10526 } 10527 10528 10529 STATIC I32 10530 S_expect_number(pTHX_ char **const pattern) 10531 { 10532 dVAR; 10533 I32 var = 0; 10534 10535 PERL_ARGS_ASSERT_EXPECT_NUMBER; 10536 10537 switch (**pattern) { 10538 case '1': case '2': case '3': 10539 case '4': case '5': case '6': 10540 case '7': case '8': case '9': 10541 var = *(*pattern)++ - '0'; 10542 while (isDIGIT(**pattern)) { 10543 const I32 tmp = var * 10 + (*(*pattern)++ - '0'); 10544 if (tmp < var) 10545 Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn")); 10546 var = tmp; 10547 } 10548 } 10549 return var; 10550 } 10551 10552 STATIC char * 10553 S_F0convert(NV nv, char *const endbuf, STRLEN *const len) 10554 { 10555 const int neg = nv < 0; 10556 UV uv; 10557 10558 PERL_ARGS_ASSERT_F0CONVERT; 10559 10560 if (neg) 10561 nv = -nv; 10562 if (nv < UV_MAX) { 10563 char *p = endbuf; 10564 nv += 0.5; 10565 uv = (UV)nv; 10566 if (uv & 1 && uv == nv) 10567 uv--; /* Round to even */ 10568 do { 10569 const unsigned dig = uv % 10; 10570 *--p = '0' + dig; 10571 } while (uv /= 10); 10572 if (neg) 10573 *--p = '-'; 10574 *len = endbuf - p; 10575 return p; 10576 } 10577 return NULL; 10578 } 10579 10580 10581 /* 10582 =for apidoc sv_vcatpvfn 10583 10584 =for apidoc sv_vcatpvfn_flags 10585 10586 Processes its arguments like C<vsprintf> and appends the formatted output 10587 to an SV. Uses an array of SVs if the C style variable argument list is 10588 missing (NULL). When running with taint checks enabled, indicates via 10589 C<maybe_tainted> if results are untrustworthy (often due to the use of 10590 locales). 10591 10592 If called as C<sv_vcatpvfn> or flags include C<SV_GMAGIC>, calls get magic. 10593 10594 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>. 10595 10596 =cut 10597 */ 10598 10599 #define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\ 10600 vecstr = (U8*)SvPV_const(vecsv,veclen);\ 10601 vec_utf8 = DO_UTF8(vecsv); 10602 10603 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */ 10604 10605 void 10606 Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, 10607 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted) 10608 { 10609 PERL_ARGS_ASSERT_SV_VCATPVFN; 10610 10611 sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, SV_GMAGIC|SV_SMAGIC); 10612 } 10613 10614 void 10615 Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, 10616 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted, 10617 const U32 flags) 10618 { 10619 dVAR; 10620 char *p; 10621 char *q; 10622 const char *patend; 10623 STRLEN origlen; 10624 I32 svix = 0; 10625 static const char nullstr[] = "(null)"; 10626 SV *argsv = NULL; 10627 bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */ 10628 const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */ 10629 SV *nsv = NULL; 10630 /* Times 4: a decimal digit takes more than 3 binary digits. 10631 * NV_DIG: mantissa takes than many decimal digits. 10632 * Plus 32: Playing safe. */ 10633 char ebuf[IV_DIG * 4 + NV_DIG + 32]; 10634 /* large enough for "%#.#f" --chip */ 10635 /* what about long double NVs? --jhi */ 10636 10637 DECLARATION_FOR_STORE_LC_NUMERIC_SET_TO_NEEDED; 10638 10639 PERL_ARGS_ASSERT_SV_VCATPVFN_FLAGS; 10640 PERL_UNUSED_ARG(maybe_tainted); 10641 10642 if (flags & SV_GMAGIC) 10643 SvGETMAGIC(sv); 10644 10645 /* no matter what, this is a string now */ 10646 (void)SvPV_force_nomg(sv, origlen); 10647 10648 /* special-case "", "%s", and "%-p" (SVf - see below) */ 10649 if (patlen == 0) 10650 return; 10651 if (patlen == 2 && pat[0] == '%' && pat[1] == 's') { 10652 if (args) { 10653 const char * const s = va_arg(*args, char*); 10654 sv_catpv_nomg(sv, s ? s : nullstr); 10655 } 10656 else if (svix < svmax) { 10657 /* we want get magic on the source but not the target. sv_catsv can't do that, though */ 10658 SvGETMAGIC(*svargs); 10659 sv_catsv_nomg(sv, *svargs); 10660 } 10661 else 10662 S_vcatpvfn_missing_argument(aTHX); 10663 return; 10664 } 10665 if (args && patlen == 3 && pat[0] == '%' && 10666 pat[1] == '-' && pat[2] == 'p') { 10667 argsv = MUTABLE_SV(va_arg(*args, void*)); 10668 sv_catsv_nomg(sv, argsv); 10669 return; 10670 } 10671 10672 #ifndef USE_LONG_DOUBLE 10673 /* special-case "%.<number>[gf]" */ 10674 if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.' 10675 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) { 10676 unsigned digits = 0; 10677 const char *pp; 10678 10679 pp = pat + 2; 10680 while (*pp >= '0' && *pp <= '9') 10681 digits = 10 * digits + (*pp++ - '0'); 10682 if (pp - pat == (int)patlen - 1 && svix < svmax) { 10683 const NV nv = SvNV(*svargs); 10684 if (*pp == 'g') { 10685 /* Add check for digits != 0 because it seems that some 10686 gconverts are buggy in this case, and we don't yet have 10687 a Configure test for this. */ 10688 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) { 10689 /* 0, point, slack */ 10690 STORE_LC_NUMERIC_SET_TO_NEEDED(); 10691 PERL_UNUSED_RESULT(Gconvert(nv, (int)digits, 0, ebuf)); 10692 sv_catpv_nomg(sv, ebuf); 10693 if (*ebuf) /* May return an empty string for digits==0 */ 10694 return; 10695 } 10696 } else if (!digits) { 10697 STRLEN l; 10698 10699 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) { 10700 sv_catpvn_nomg(sv, p, l); 10701 return; 10702 } 10703 } 10704 } 10705 } 10706 #endif /* !USE_LONG_DOUBLE */ 10707 10708 if (!args && svix < svmax && DO_UTF8(*svargs)) 10709 has_utf8 = TRUE; 10710 10711 patend = (char*)pat + patlen; 10712 for (p = (char*)pat; p < patend; p = q) { 10713 bool alt = FALSE; 10714 bool left = FALSE; 10715 bool vectorize = FALSE; 10716 bool vectorarg = FALSE; 10717 bool vec_utf8 = FALSE; 10718 char fill = ' '; 10719 char plus = 0; 10720 char intsize = 0; 10721 STRLEN width = 0; 10722 STRLEN zeros = 0; 10723 bool has_precis = FALSE; 10724 STRLEN precis = 0; 10725 const I32 osvix = svix; 10726 bool is_utf8 = FALSE; /* is this item utf8? */ 10727 #ifdef HAS_LDBL_SPRINTF_BUG 10728 /* This is to try to fix a bug with irix/nonstop-ux/powerux and 10729 with sfio - Allen <allens@cpan.org> */ 10730 bool fix_ldbl_sprintf_bug = FALSE; 10731 #endif 10732 10733 char esignbuf[4]; 10734 U8 utf8buf[UTF8_MAXBYTES+1]; 10735 STRLEN esignlen = 0; 10736 10737 const char *eptr = NULL; 10738 const char *fmtstart; 10739 STRLEN elen = 0; 10740 SV *vecsv = NULL; 10741 const U8 *vecstr = NULL; 10742 STRLEN veclen = 0; 10743 char c = 0; 10744 int i; 10745 unsigned base = 0; 10746 IV iv = 0; 10747 UV uv = 0; 10748 /* we need a long double target in case HAS_LONG_DOUBLE but 10749 not USE_LONG_DOUBLE 10750 */ 10751 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE 10752 long double nv; 10753 #else 10754 NV nv; 10755 #endif 10756 STRLEN have; 10757 STRLEN need; 10758 STRLEN gap; 10759 const char *dotstr = "."; 10760 STRLEN dotstrlen = 1; 10761 I32 efix = 0; /* explicit format parameter index */ 10762 I32 ewix = 0; /* explicit width index */ 10763 I32 epix = 0; /* explicit precision index */ 10764 I32 evix = 0; /* explicit vector index */ 10765 bool asterisk = FALSE; 10766 10767 /* echo everything up to the next format specification */ 10768 for (q = p; q < patend && *q != '%'; ++q) ; 10769 if (q > p) { 10770 if (has_utf8 && !pat_utf8) 10771 sv_catpvn_nomg_utf8_upgrade(sv, p, q - p, nsv); 10772 else 10773 sv_catpvn_nomg(sv, p, q - p); 10774 p = q; 10775 } 10776 if (q++ >= patend) 10777 break; 10778 10779 fmtstart = q; 10780 10781 /* 10782 We allow format specification elements in this order: 10783 \d+\$ explicit format parameter index 10784 [-+ 0#]+ flags 10785 v|\*(\d+\$)?v vector with optional (optionally specified) arg 10786 0 flag (as above): repeated to allow "v02" 10787 \d+|\*(\d+\$)? width using optional (optionally specified) arg 10788 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg 10789 [hlqLV] size 10790 [%bcdefginopsuxDFOUX] format (mandatory) 10791 */ 10792 10793 if (args) { 10794 /* 10795 As of perl5.9.3, printf format checking is on by default. 10796 Internally, perl uses %p formats to provide an escape to 10797 some extended formatting. This block deals with those 10798 extensions: if it does not match, (char*)q is reset and 10799 the normal format processing code is used. 10800 10801 Currently defined extensions are: 10802 %p include pointer address (standard) 10803 %-p (SVf) include an SV (previously %_) 10804 %-<num>p include an SV with precision <num> 10805 %2p include a HEK 10806 %3p include a HEK with precision of 256 10807 %4p char* preceded by utf8 flag and length 10808 %<num>p (where num is 1 or > 4) reserved for future 10809 extensions 10810 10811 Robin Barker 2005-07-14 (but modified since) 10812 10813 %1p (VDf) removed. RMB 2007-10-19 10814 */ 10815 char* r = q; 10816 bool sv = FALSE; 10817 STRLEN n = 0; 10818 if (*q == '-') 10819 sv = *q++; 10820 else if (strnEQ(q, UTF8f, sizeof(UTF8f)-1)) { /* UTF8f */ 10821 /* The argument has already gone through cBOOL, so the cast 10822 is safe. */ 10823 is_utf8 = (bool)va_arg(*args, int); 10824 elen = va_arg(*args, UV); 10825 eptr = va_arg(*args, char *); 10826 q += sizeof(UTF8f)-1; 10827 goto string; 10828 } 10829 n = expect_number(&q); 10830 if (*q++ == 'p') { 10831 if (sv) { /* SVf */ 10832 if (n) { 10833 precis = n; 10834 has_precis = TRUE; 10835 } 10836 argsv = MUTABLE_SV(va_arg(*args, void*)); 10837 eptr = SvPV_const(argsv, elen); 10838 if (DO_UTF8(argsv)) 10839 is_utf8 = TRUE; 10840 goto string; 10841 } 10842 else if (n==2 || n==3) { /* HEKf */ 10843 HEK * const hek = va_arg(*args, HEK *); 10844 eptr = HEK_KEY(hek); 10845 elen = HEK_LEN(hek); 10846 if (HEK_UTF8(hek)) is_utf8 = TRUE; 10847 if (n==3) precis = 256, has_precis = TRUE; 10848 goto string; 10849 } 10850 else if (n) { 10851 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), 10852 "internal %%<num>p might conflict with future printf extensions"); 10853 } 10854 } 10855 q = r; 10856 } 10857 10858 if ( (width = expect_number(&q)) ) { 10859 if (*q == '$') { 10860 ++q; 10861 efix = width; 10862 } else { 10863 goto gotwidth; 10864 } 10865 } 10866 10867 /* FLAGS */ 10868 10869 while (*q) { 10870 switch (*q) { 10871 case ' ': 10872 case '+': 10873 if (plus == '+' && *q == ' ') /* '+' over ' ' */ 10874 q++; 10875 else 10876 plus = *q++; 10877 continue; 10878 10879 case '-': 10880 left = TRUE; 10881 q++; 10882 continue; 10883 10884 case '0': 10885 fill = *q++; 10886 continue; 10887 10888 case '#': 10889 alt = TRUE; 10890 q++; 10891 continue; 10892 10893 default: 10894 break; 10895 } 10896 break; 10897 } 10898 10899 tryasterisk: 10900 if (*q == '*') { 10901 q++; 10902 if ( (ewix = expect_number(&q)) ) 10903 if (*q++ != '$') 10904 goto unknown; 10905 asterisk = TRUE; 10906 } 10907 if (*q == 'v') { 10908 q++; 10909 if (vectorize) 10910 goto unknown; 10911 if ((vectorarg = asterisk)) { 10912 evix = ewix; 10913 ewix = 0; 10914 asterisk = FALSE; 10915 } 10916 vectorize = TRUE; 10917 goto tryasterisk; 10918 } 10919 10920 if (!asterisk) 10921 { 10922 if( *q == '0' ) 10923 fill = *q++; 10924 width = expect_number(&q); 10925 } 10926 10927 if (vectorize && vectorarg) { 10928 /* vectorizing, but not with the default "." */ 10929 if (args) 10930 vecsv = va_arg(*args, SV*); 10931 else if (evix) { 10932 vecsv = (evix > 0 && evix <= svmax) 10933 ? svargs[evix-1] : S_vcatpvfn_missing_argument(aTHX); 10934 } else { 10935 vecsv = svix < svmax 10936 ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX); 10937 } 10938 dotstr = SvPV_const(vecsv, dotstrlen); 10939 /* Keep the DO_UTF8 test *after* the SvPV call, else things go 10940 bad with tied or overloaded values that return UTF8. */ 10941 if (DO_UTF8(vecsv)) 10942 is_utf8 = TRUE; 10943 else if (has_utf8) { 10944 vecsv = sv_mortalcopy(vecsv); 10945 sv_utf8_upgrade(vecsv); 10946 dotstr = SvPV_const(vecsv, dotstrlen); 10947 is_utf8 = TRUE; 10948 } 10949 } 10950 10951 if (asterisk) { 10952 if (args) 10953 i = va_arg(*args, int); 10954 else 10955 i = (ewix ? ewix <= svmax : svix < svmax) ? 10956 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0; 10957 left |= (i < 0); 10958 width = (i < 0) ? -i : i; 10959 } 10960 gotwidth: 10961 10962 /* PRECISION */ 10963 10964 if (*q == '.') { 10965 q++; 10966 if (*q == '*') { 10967 q++; 10968 if ( ((epix = expect_number(&q))) && (*q++ != '$') ) 10969 goto unknown; 10970 /* XXX: todo, support specified precision parameter */ 10971 if (epix) 10972 goto unknown; 10973 if (args) 10974 i = va_arg(*args, int); 10975 else 10976 i = (ewix ? ewix <= svmax : svix < svmax) 10977 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0; 10978 precis = i; 10979 has_precis = !(i < 0); 10980 } 10981 else { 10982 precis = 0; 10983 while (isDIGIT(*q)) 10984 precis = precis * 10 + (*q++ - '0'); 10985 has_precis = TRUE; 10986 } 10987 } 10988 10989 if (vectorize) { 10990 if (args) { 10991 VECTORIZE_ARGS 10992 } 10993 else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) { 10994 vecsv = svargs[efix ? efix-1 : svix++]; 10995 vecstr = (U8*)SvPV_const(vecsv,veclen); 10996 vec_utf8 = DO_UTF8(vecsv); 10997 10998 /* if this is a version object, we need to convert 10999 * back into v-string notation and then let the 11000 * vectorize happen normally 11001 */ 11002 if (sv_isobject(vecsv) && sv_derived_from(vecsv, "version")) { 11003 if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) { 11004 Perl_ck_warner_d(aTHX_ packWARN(WARN_PRINTF), 11005 "vector argument not supported with alpha versions"); 11006 goto vdblank; 11007 } 11008 vecsv = sv_newmortal(); 11009 scan_vstring((char *)vecstr, (char *)vecstr + veclen, 11010 vecsv); 11011 vecstr = (U8*)SvPV_const(vecsv, veclen); 11012 vec_utf8 = DO_UTF8(vecsv); 11013 } 11014 } 11015 else { 11016 vdblank: 11017 vecstr = (U8*)""; 11018 veclen = 0; 11019 } 11020 } 11021 11022 /* SIZE */ 11023 11024 switch (*q) { 11025 #ifdef WIN32 11026 case 'I': /* Ix, I32x, and I64x */ 11027 # ifdef USE_64_BIT_INT 11028 if (q[1] == '6' && q[2] == '4') { 11029 q += 3; 11030 intsize = 'q'; 11031 break; 11032 } 11033 # endif 11034 if (q[1] == '3' && q[2] == '2') { 11035 q += 3; 11036 break; 11037 } 11038 # ifdef USE_64_BIT_INT 11039 intsize = 'q'; 11040 # endif 11041 q++; 11042 break; 11043 #endif 11044 #if IVSIZE >= 8 || defined(HAS_LONG_DOUBLE) 11045 case 'L': /* Ld */ 11046 /*FALLTHROUGH*/ 11047 #if IVSIZE >= 8 11048 case 'q': /* qd */ 11049 #endif 11050 intsize = 'q'; 11051 q++; 11052 break; 11053 #endif 11054 case 'l': 11055 ++q; 11056 #if IVSIZE >= 8 || defined(HAS_LONG_DOUBLE) 11057 if (*q == 'l') { /* lld, llf */ 11058 intsize = 'q'; 11059 ++q; 11060 } 11061 else 11062 #endif 11063 intsize = 'l'; 11064 break; 11065 case 'h': 11066 if (*++q == 'h') { /* hhd, hhu */ 11067 intsize = 'c'; 11068 ++q; 11069 } 11070 else 11071 intsize = 'h'; 11072 break; 11073 case 'V': 11074 case 'z': 11075 case 't': 11076 #ifdef HAS_C99 11077 case 'j': 11078 #endif 11079 intsize = *q++; 11080 break; 11081 } 11082 11083 /* CONVERSION */ 11084 11085 if (*q == '%') { 11086 eptr = q++; 11087 elen = 1; 11088 if (vectorize) { 11089 c = '%'; 11090 goto unknown; 11091 } 11092 goto string; 11093 } 11094 11095 if (!vectorize && !args) { 11096 if (efix) { 11097 const I32 i = efix-1; 11098 argsv = (i >= 0 && i < svmax) 11099 ? svargs[i] : S_vcatpvfn_missing_argument(aTHX); 11100 } else { 11101 argsv = (svix >= 0 && svix < svmax) 11102 ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX); 11103 } 11104 } 11105 11106 switch (c = *q++) { 11107 11108 /* STRINGS */ 11109 11110 case 'c': 11111 if (vectorize) 11112 goto unknown; 11113 uv = (args) ? va_arg(*args, int) : SvIV(argsv); 11114 if ((uv > 255 || 11115 (!UVCHR_IS_INVARIANT(uv) && SvUTF8(sv))) 11116 && !IN_BYTES) { 11117 eptr = (char*)utf8buf; 11118 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf; 11119 is_utf8 = TRUE; 11120 } 11121 else { 11122 c = (char)uv; 11123 eptr = &c; 11124 elen = 1; 11125 } 11126 goto string; 11127 11128 case 's': 11129 if (vectorize) 11130 goto unknown; 11131 if (args) { 11132 eptr = va_arg(*args, char*); 11133 if (eptr) 11134 elen = strlen(eptr); 11135 else { 11136 eptr = (char *)nullstr; 11137 elen = sizeof nullstr - 1; 11138 } 11139 } 11140 else { 11141 eptr = SvPV_const(argsv, elen); 11142 if (DO_UTF8(argsv)) { 11143 STRLEN old_precis = precis; 11144 if (has_precis && precis < elen) { 11145 STRLEN ulen = sv_or_pv_len_utf8(argsv, eptr, elen); 11146 STRLEN p = precis > ulen ? ulen : precis; 11147 precis = sv_or_pv_pos_u2b(argsv, eptr, p, 0); 11148 /* sticks at end */ 11149 } 11150 if (width) { /* fudge width (can't fudge elen) */ 11151 if (has_precis && precis < elen) 11152 width += precis - old_precis; 11153 else 11154 width += 11155 elen - sv_or_pv_len_utf8(argsv,eptr,elen); 11156 } 11157 is_utf8 = TRUE; 11158 } 11159 } 11160 11161 string: 11162 if (has_precis && precis < elen) 11163 elen = precis; 11164 break; 11165 11166 /* INTEGERS */ 11167 11168 case 'p': 11169 if (alt || vectorize) 11170 goto unknown; 11171 uv = PTR2UV(args ? va_arg(*args, void*) : argsv); 11172 base = 16; 11173 goto integer; 11174 11175 case 'D': 11176 #ifdef IV_IS_QUAD 11177 intsize = 'q'; 11178 #else 11179 intsize = 'l'; 11180 #endif 11181 /*FALLTHROUGH*/ 11182 case 'd': 11183 case 'i': 11184 if (vectorize) { 11185 STRLEN ulen; 11186 if (!veclen) 11187 continue; 11188 if (vec_utf8) 11189 uv = utf8n_to_uvchr(vecstr, veclen, &ulen, 11190 UTF8_ALLOW_ANYUV); 11191 else { 11192 uv = *vecstr; 11193 ulen = 1; 11194 } 11195 vecstr += ulen; 11196 veclen -= ulen; 11197 if (plus) 11198 esignbuf[esignlen++] = plus; 11199 } 11200 else if (args) { 11201 switch (intsize) { 11202 case 'c': iv = (char)va_arg(*args, int); break; 11203 case 'h': iv = (short)va_arg(*args, int); break; 11204 case 'l': iv = va_arg(*args, long); break; 11205 case 'V': iv = va_arg(*args, IV); break; 11206 case 'z': iv = va_arg(*args, SSize_t); break; 11207 case 't': iv = va_arg(*args, ptrdiff_t); break; 11208 default: iv = va_arg(*args, int); break; 11209 #ifdef HAS_C99 11210 case 'j': iv = va_arg(*args, intmax_t); break; 11211 #endif 11212 case 'q': 11213 #if IVSIZE >= 8 11214 iv = va_arg(*args, Quad_t); break; 11215 #else 11216 goto unknown; 11217 #endif 11218 } 11219 } 11220 else { 11221 IV tiv = SvIV(argsv); /* work around GCC bug #13488 */ 11222 switch (intsize) { 11223 case 'c': iv = (char)tiv; break; 11224 case 'h': iv = (short)tiv; break; 11225 case 'l': iv = (long)tiv; break; 11226 case 'V': 11227 default: iv = tiv; break; 11228 case 'q': 11229 #if IVSIZE >= 8 11230 iv = (Quad_t)tiv; break; 11231 #else 11232 goto unknown; 11233 #endif 11234 } 11235 } 11236 if ( !vectorize ) /* we already set uv above */ 11237 { 11238 if (iv >= 0) { 11239 uv = iv; 11240 if (plus) 11241 esignbuf[esignlen++] = plus; 11242 } 11243 else { 11244 uv = -iv; 11245 esignbuf[esignlen++] = '-'; 11246 } 11247 } 11248 base = 10; 11249 goto integer; 11250 11251 case 'U': 11252 #ifdef IV_IS_QUAD 11253 intsize = 'q'; 11254 #else 11255 intsize = 'l'; 11256 #endif 11257 /*FALLTHROUGH*/ 11258 case 'u': 11259 base = 10; 11260 goto uns_integer; 11261 11262 case 'B': 11263 case 'b': 11264 base = 2; 11265 goto uns_integer; 11266 11267 case 'O': 11268 #ifdef IV_IS_QUAD 11269 intsize = 'q'; 11270 #else 11271 intsize = 'l'; 11272 #endif 11273 /*FALLTHROUGH*/ 11274 case 'o': 11275 base = 8; 11276 goto uns_integer; 11277 11278 case 'X': 11279 case 'x': 11280 base = 16; 11281 11282 uns_integer: 11283 if (vectorize) { 11284 STRLEN ulen; 11285 vector: 11286 if (!veclen) 11287 continue; 11288 if (vec_utf8) 11289 uv = utf8n_to_uvchr(vecstr, veclen, &ulen, 11290 UTF8_ALLOW_ANYUV); 11291 else { 11292 uv = *vecstr; 11293 ulen = 1; 11294 } 11295 vecstr += ulen; 11296 veclen -= ulen; 11297 } 11298 else if (args) { 11299 switch (intsize) { 11300 case 'c': uv = (unsigned char)va_arg(*args, unsigned); break; 11301 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break; 11302 case 'l': uv = va_arg(*args, unsigned long); break; 11303 case 'V': uv = va_arg(*args, UV); break; 11304 case 'z': uv = va_arg(*args, Size_t); break; 11305 case 't': uv = va_arg(*args, ptrdiff_t); break; /* will sign extend, but there is no uptrdiff_t, so oh well */ 11306 #ifdef HAS_C99 11307 case 'j': uv = va_arg(*args, uintmax_t); break; 11308 #endif 11309 default: uv = va_arg(*args, unsigned); break; 11310 case 'q': 11311 #if IVSIZE >= 8 11312 uv = va_arg(*args, Uquad_t); break; 11313 #else 11314 goto unknown; 11315 #endif 11316 } 11317 } 11318 else { 11319 UV tuv = SvUV(argsv); /* work around GCC bug #13488 */ 11320 switch (intsize) { 11321 case 'c': uv = (unsigned char)tuv; break; 11322 case 'h': uv = (unsigned short)tuv; break; 11323 case 'l': uv = (unsigned long)tuv; break; 11324 case 'V': 11325 default: uv = tuv; break; 11326 case 'q': 11327 #if IVSIZE >= 8 11328 uv = (Uquad_t)tuv; break; 11329 #else 11330 goto unknown; 11331 #endif 11332 } 11333 } 11334 11335 integer: 11336 { 11337 char *ptr = ebuf + sizeof ebuf; 11338 bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */ 11339 zeros = 0; 11340 11341 switch (base) { 11342 unsigned dig; 11343 case 16: 11344 p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit); 11345 do { 11346 dig = uv & 15; 11347 *--ptr = p[dig]; 11348 } while (uv >>= 4); 11349 if (tempalt) { 11350 esignbuf[esignlen++] = '0'; 11351 esignbuf[esignlen++] = c; /* 'x' or 'X' */ 11352 } 11353 break; 11354 case 8: 11355 do { 11356 dig = uv & 7; 11357 *--ptr = '0' + dig; 11358 } while (uv >>= 3); 11359 if (alt && *ptr != '0') 11360 *--ptr = '0'; 11361 break; 11362 case 2: 11363 do { 11364 dig = uv & 1; 11365 *--ptr = '0' + dig; 11366 } while (uv >>= 1); 11367 if (tempalt) { 11368 esignbuf[esignlen++] = '0'; 11369 esignbuf[esignlen++] = c; 11370 } 11371 break; 11372 default: /* it had better be ten or less */ 11373 do { 11374 dig = uv % base; 11375 *--ptr = '0' + dig; 11376 } while (uv /= base); 11377 break; 11378 } 11379 elen = (ebuf + sizeof ebuf) - ptr; 11380 eptr = ptr; 11381 if (has_precis) { 11382 if (precis > elen) 11383 zeros = precis - elen; 11384 else if (precis == 0 && elen == 1 && *eptr == '0' 11385 && !(base == 8 && alt)) /* "%#.0o" prints "0" */ 11386 elen = 0; 11387 11388 /* a precision nullifies the 0 flag. */ 11389 if (fill == '0') 11390 fill = ' '; 11391 } 11392 } 11393 break; 11394 11395 /* FLOATING POINT */ 11396 11397 case 'F': 11398 c = 'f'; /* maybe %F isn't supported here */ 11399 /*FALLTHROUGH*/ 11400 case 'e': case 'E': 11401 case 'f': 11402 case 'g': case 'G': 11403 if (vectorize) 11404 goto unknown; 11405 11406 /* This is evil, but floating point is even more evil */ 11407 11408 /* for SV-style calling, we can only get NV 11409 for C-style calling, we assume %f is double; 11410 for simplicity we allow any of %Lf, %llf, %qf for long double 11411 */ 11412 switch (intsize) { 11413 case 'V': 11414 #if defined(USE_LONG_DOUBLE) 11415 intsize = 'q'; 11416 #endif 11417 break; 11418 /* [perl #20339] - we should accept and ignore %lf rather than die */ 11419 case 'l': 11420 /*FALLTHROUGH*/ 11421 default: 11422 #if defined(USE_LONG_DOUBLE) 11423 intsize = args ? 0 : 'q'; 11424 #endif 11425 break; 11426 case 'q': 11427 #if defined(HAS_LONG_DOUBLE) 11428 break; 11429 #else 11430 /*FALLTHROUGH*/ 11431 #endif 11432 case 'c': 11433 case 'h': 11434 case 'z': 11435 case 't': 11436 case 'j': 11437 goto unknown; 11438 } 11439 11440 /* now we need (long double) if intsize == 'q', else (double) */ 11441 nv = (args) ? 11442 #if LONG_DOUBLESIZE > DOUBLESIZE 11443 intsize == 'q' ? 11444 va_arg(*args, long double) : 11445 va_arg(*args, double) 11446 #else 11447 va_arg(*args, double) 11448 #endif 11449 : SvNV(argsv); 11450 11451 need = 0; 11452 /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything 11453 else. frexp() has some unspecified behaviour for those three */ 11454 if (c != 'e' && c != 'E' && (nv * 0) == 0) { 11455 i = PERL_INT_MIN; 11456 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this 11457 will cast our (long double) to (double) */ 11458 (void)Perl_frexp(nv, &i); 11459 if (i == PERL_INT_MIN) 11460 Perl_die(aTHX_ "panic: frexp"); 11461 if (i > 0) 11462 need = BIT_DIGITS(i); 11463 } 11464 need += has_precis ? precis : 6; /* known default */ 11465 11466 if (need < width) 11467 need = width; 11468 11469 #ifdef HAS_LDBL_SPRINTF_BUG 11470 /* This is to try to fix a bug with irix/nonstop-ux/powerux and 11471 with sfio - Allen <allens@cpan.org> */ 11472 11473 # ifdef DBL_MAX 11474 # define MY_DBL_MAX DBL_MAX 11475 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */ 11476 # if DOUBLESIZE >= 8 11477 # define MY_DBL_MAX 1.7976931348623157E+308L 11478 # else 11479 # define MY_DBL_MAX 3.40282347E+38L 11480 # endif 11481 # endif 11482 11483 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */ 11484 # define MY_DBL_MAX_BUG 1L 11485 # else 11486 # define MY_DBL_MAX_BUG MY_DBL_MAX 11487 # endif 11488 11489 # ifdef DBL_MIN 11490 # define MY_DBL_MIN DBL_MIN 11491 # else /* XXX guessing! -Allen */ 11492 # if DOUBLESIZE >= 8 11493 # define MY_DBL_MIN 2.2250738585072014E-308L 11494 # else 11495 # define MY_DBL_MIN 1.17549435E-38L 11496 # endif 11497 # endif 11498 11499 if ((intsize == 'q') && (c == 'f') && 11500 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) && 11501 (need < DBL_DIG)) { 11502 /* it's going to be short enough that 11503 * long double precision is not needed */ 11504 11505 if ((nv <= 0L) && (nv >= -0L)) 11506 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */ 11507 else { 11508 /* would use Perl_fp_class as a double-check but not 11509 * functional on IRIX - see perl.h comments */ 11510 11511 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) { 11512 /* It's within the range that a double can represent */ 11513 #if defined(DBL_MAX) && !defined(DBL_MIN) 11514 if ((nv >= ((long double)1/DBL_MAX)) || 11515 (nv <= (-(long double)1/DBL_MAX))) 11516 #endif 11517 fix_ldbl_sprintf_bug = TRUE; 11518 } 11519 } 11520 if (fix_ldbl_sprintf_bug == TRUE) { 11521 double temp; 11522 11523 intsize = 0; 11524 temp = (double)nv; 11525 nv = (NV)temp; 11526 } 11527 } 11528 11529 # undef MY_DBL_MAX 11530 # undef MY_DBL_MAX_BUG 11531 # undef MY_DBL_MIN 11532 11533 #endif /* HAS_LDBL_SPRINTF_BUG */ 11534 11535 need += 20; /* fudge factor */ 11536 if (PL_efloatsize < need) { 11537 Safefree(PL_efloatbuf); 11538 PL_efloatsize = need + 20; /* more fudge */ 11539 Newx(PL_efloatbuf, PL_efloatsize, char); 11540 PL_efloatbuf[0] = '\0'; 11541 } 11542 11543 if ( !(width || left || plus || alt) && fill != '0' 11544 && has_precis && intsize != 'q' ) { /* Shortcuts */ 11545 /* See earlier comment about buggy Gconvert when digits, 11546 aka precis is 0 */ 11547 if ( c == 'g' && precis) { 11548 STORE_LC_NUMERIC_SET_TO_NEEDED(); 11549 PERL_UNUSED_RESULT(Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf)); 11550 /* May return an empty string for digits==0 */ 11551 if (*PL_efloatbuf) { 11552 elen = strlen(PL_efloatbuf); 11553 goto float_converted; 11554 } 11555 } else if ( c == 'f' && !precis) { 11556 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen))) 11557 break; 11558 } 11559 } 11560 { 11561 char *ptr = ebuf + sizeof ebuf; 11562 *--ptr = '\0'; 11563 *--ptr = c; 11564 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */ 11565 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl) 11566 if (intsize == 'q') { 11567 /* Copy the one or more characters in a long double 11568 * format before the 'base' ([efgEFG]) character to 11569 * the format string. */ 11570 static char const prifldbl[] = PERL_PRIfldbl; 11571 char const *p = prifldbl + sizeof(prifldbl) - 3; 11572 while (p >= prifldbl) { *--ptr = *p--; } 11573 } 11574 #endif 11575 if (has_precis) { 11576 base = precis; 11577 do { *--ptr = '0' + (base % 10); } while (base /= 10); 11578 *--ptr = '.'; 11579 } 11580 if (width) { 11581 base = width; 11582 do { *--ptr = '0' + (base % 10); } while (base /= 10); 11583 } 11584 if (fill == '0') 11585 *--ptr = fill; 11586 if (left) 11587 *--ptr = '-'; 11588 if (plus) 11589 *--ptr = plus; 11590 if (alt) 11591 *--ptr = '#'; 11592 *--ptr = '%'; 11593 11594 /* No taint. Otherwise we are in the strange situation 11595 * where printf() taints but print($float) doesn't. 11596 * --jhi */ 11597 11598 STORE_LC_NUMERIC_SET_TO_NEEDED(); 11599 11600 /* hopefully the above makes ptr a very constrained format 11601 * that is safe to use, even though it's not literal */ 11602 GCC_DIAG_IGNORE(-Wformat-nonliteral); 11603 #if defined(HAS_LONG_DOUBLE) 11604 elen = ((intsize == 'q') 11605 ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv) 11606 : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv)); 11607 #else 11608 elen = my_sprintf(PL_efloatbuf, ptr, nv); 11609 #endif 11610 GCC_DIAG_RESTORE; 11611 } 11612 float_converted: 11613 eptr = PL_efloatbuf; 11614 11615 #ifdef USE_LOCALE_NUMERIC 11616 /* If the decimal point character in the string is UTF-8, make the 11617 * output utf8 */ 11618 if (PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv) 11619 && instr(eptr, SvPVX_const(PL_numeric_radix_sv))) 11620 { 11621 is_utf8 = TRUE; 11622 } 11623 #endif 11624 11625 break; 11626 11627 /* SPECIAL */ 11628 11629 case 'n': 11630 if (vectorize) 11631 goto unknown; 11632 i = SvCUR(sv) - origlen; 11633 if (args) { 11634 switch (intsize) { 11635 case 'c': *(va_arg(*args, char*)) = i; break; 11636 case 'h': *(va_arg(*args, short*)) = i; break; 11637 default: *(va_arg(*args, int*)) = i; break; 11638 case 'l': *(va_arg(*args, long*)) = i; break; 11639 case 'V': *(va_arg(*args, IV*)) = i; break; 11640 case 'z': *(va_arg(*args, SSize_t*)) = i; break; 11641 case 't': *(va_arg(*args, ptrdiff_t*)) = i; break; 11642 #ifdef HAS_C99 11643 case 'j': *(va_arg(*args, intmax_t*)) = i; break; 11644 #endif 11645 case 'q': 11646 #if IVSIZE >= 8 11647 *(va_arg(*args, Quad_t*)) = i; break; 11648 #else 11649 goto unknown; 11650 #endif 11651 } 11652 } 11653 else 11654 sv_setuv_mg(argsv, has_utf8 ? (UV)sv_len_utf8(sv) : (UV)i); 11655 continue; /* not "break" */ 11656 11657 /* UNKNOWN */ 11658 11659 default: 11660 unknown: 11661 if (!args 11662 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF) 11663 && ckWARN(WARN_PRINTF)) 11664 { 11665 SV * const msg = sv_newmortal(); 11666 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ", 11667 (PL_op->op_type == OP_PRTF) ? "" : "s"); 11668 if (fmtstart < patend) { 11669 const char * const fmtend = q < patend ? q : patend; 11670 const char * f; 11671 sv_catpvs(msg, "\"%"); 11672 for (f = fmtstart; f < fmtend; f++) { 11673 if (isPRINT(*f)) { 11674 sv_catpvn_nomg(msg, f, 1); 11675 } else { 11676 Perl_sv_catpvf(aTHX_ msg, 11677 "\\%03"UVof, (UV)*f & 0xFF); 11678 } 11679 } 11680 sv_catpvs(msg, "\""); 11681 } else { 11682 sv_catpvs(msg, "end of string"); 11683 } 11684 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */ 11685 } 11686 11687 /* output mangled stuff ... */ 11688 if (c == '\0') 11689 --q; 11690 eptr = p; 11691 elen = q - p; 11692 11693 /* ... right here, because formatting flags should not apply */ 11694 SvGROW(sv, SvCUR(sv) + elen + 1); 11695 p = SvEND(sv); 11696 Copy(eptr, p, elen, char); 11697 p += elen; 11698 *p = '\0'; 11699 SvCUR_set(sv, p - SvPVX_const(sv)); 11700 svix = osvix; 11701 continue; /* not "break" */ 11702 } 11703 11704 if (is_utf8 != has_utf8) { 11705 if (is_utf8) { 11706 if (SvCUR(sv)) 11707 sv_utf8_upgrade(sv); 11708 } 11709 else { 11710 const STRLEN old_elen = elen; 11711 SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP); 11712 sv_utf8_upgrade(nsv); 11713 eptr = SvPVX_const(nsv); 11714 elen = SvCUR(nsv); 11715 11716 if (width) { /* fudge width (can't fudge elen) */ 11717 width += elen - old_elen; 11718 } 11719 is_utf8 = TRUE; 11720 } 11721 } 11722 11723 have = esignlen + zeros + elen; 11724 if (have < zeros) 11725 croak_memory_wrap(); 11726 11727 need = (have > width ? have : width); 11728 gap = need - have; 11729 11730 if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1)) 11731 croak_memory_wrap(); 11732 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1); 11733 p = SvEND(sv); 11734 if (esignlen && fill == '0') { 11735 int i; 11736 for (i = 0; i < (int)esignlen; i++) 11737 *p++ = esignbuf[i]; 11738 } 11739 if (gap && !left) { 11740 memset(p, fill, gap); 11741 p += gap; 11742 } 11743 if (esignlen && fill != '0') { 11744 int i; 11745 for (i = 0; i < (int)esignlen; i++) 11746 *p++ = esignbuf[i]; 11747 } 11748 if (zeros) { 11749 int i; 11750 for (i = zeros; i; i--) 11751 *p++ = '0'; 11752 } 11753 if (elen) { 11754 Copy(eptr, p, elen, char); 11755 p += elen; 11756 } 11757 if (gap && left) { 11758 memset(p, ' ', gap); 11759 p += gap; 11760 } 11761 if (vectorize) { 11762 if (veclen) { 11763 Copy(dotstr, p, dotstrlen, char); 11764 p += dotstrlen; 11765 } 11766 else 11767 vectorize = FALSE; /* done iterating over vecstr */ 11768 } 11769 if (is_utf8) 11770 has_utf8 = TRUE; 11771 if (has_utf8) 11772 SvUTF8_on(sv); 11773 *p = '\0'; 11774 SvCUR_set(sv, p - SvPVX_const(sv)); 11775 if (vectorize) { 11776 esignlen = 0; 11777 goto vector; 11778 } 11779 } 11780 SvTAINT(sv); 11781 11782 RESTORE_LC_NUMERIC(); /* Done outside loop, so don't have to save/restore 11783 each iteration. */ 11784 } 11785 11786 /* ========================================================================= 11787 11788 =head1 Cloning an interpreter 11789 11790 All the macros and functions in this section are for the private use of 11791 the main function, perl_clone(). 11792 11793 The foo_dup() functions make an exact copy of an existing foo thingy. 11794 During the course of a cloning, a hash table is used to map old addresses 11795 to new addresses. The table is created and manipulated with the 11796 ptr_table_* functions. 11797 11798 =cut 11799 11800 * =========================================================================*/ 11801 11802 11803 #if defined(USE_ITHREADS) 11804 11805 /* XXX Remove this so it doesn't have to go thru the macro and return for nothing */ 11806 #ifndef GpREFCNT_inc 11807 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL) 11808 #endif 11809 11810 11811 /* Certain cases in Perl_ss_dup have been merged, by relying on the fact 11812 that currently av_dup, gv_dup and hv_dup are the same as sv_dup. 11813 If this changes, please unmerge ss_dup. 11814 Likewise, sv_dup_inc_multiple() relies on this fact. */ 11815 #define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup_inc(s,t)) 11816 #define av_dup(s,t) MUTABLE_AV(sv_dup((const SV *)s,t)) 11817 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t)) 11818 #define hv_dup(s,t) MUTABLE_HV(sv_dup((const SV *)s,t)) 11819 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t)) 11820 #define cv_dup(s,t) MUTABLE_CV(sv_dup((const SV *)s,t)) 11821 #define cv_dup_inc(s,t) MUTABLE_CV(sv_dup_inc((const SV *)s,t)) 11822 #define io_dup(s,t) MUTABLE_IO(sv_dup((const SV *)s,t)) 11823 #define io_dup_inc(s,t) MUTABLE_IO(sv_dup_inc((const SV *)s,t)) 11824 #define gv_dup(s,t) MUTABLE_GV(sv_dup((const SV *)s,t)) 11825 #define gv_dup_inc(s,t) MUTABLE_GV(sv_dup_inc((const SV *)s,t)) 11826 #define SAVEPV(p) ((p) ? savepv(p) : NULL) 11827 #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL) 11828 11829 /* clone a parser */ 11830 11831 yy_parser * 11832 Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param) 11833 { 11834 yy_parser *parser; 11835 11836 PERL_ARGS_ASSERT_PARSER_DUP; 11837 11838 if (!proto) 11839 return NULL; 11840 11841 /* look for it in the table first */ 11842 parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto); 11843 if (parser) 11844 return parser; 11845 11846 /* create anew and remember what it is */ 11847 Newxz(parser, 1, yy_parser); 11848 ptr_table_store(PL_ptr_table, proto, parser); 11849 11850 /* XXX these not yet duped */ 11851 parser->old_parser = NULL; 11852 parser->stack = NULL; 11853 parser->ps = NULL; 11854 parser->stack_size = 0; 11855 /* XXX parser->stack->state = 0; */ 11856 11857 /* XXX eventually, just Copy() most of the parser struct ? */ 11858 11859 parser->lex_brackets = proto->lex_brackets; 11860 parser->lex_casemods = proto->lex_casemods; 11861 parser->lex_brackstack = savepvn(proto->lex_brackstack, 11862 (proto->lex_brackets < 120 ? 120 : proto->lex_brackets)); 11863 parser->lex_casestack = savepvn(proto->lex_casestack, 11864 (proto->lex_casemods < 12 ? 12 : proto->lex_casemods)); 11865 parser->lex_defer = proto->lex_defer; 11866 parser->lex_dojoin = proto->lex_dojoin; 11867 parser->lex_expect = proto->lex_expect; 11868 parser->lex_formbrack = proto->lex_formbrack; 11869 parser->lex_inpat = proto->lex_inpat; 11870 parser->lex_inwhat = proto->lex_inwhat; 11871 parser->lex_op = proto->lex_op; 11872 parser->lex_repl = sv_dup_inc(proto->lex_repl, param); 11873 parser->lex_starts = proto->lex_starts; 11874 parser->lex_stuff = sv_dup_inc(proto->lex_stuff, param); 11875 parser->multi_close = proto->multi_close; 11876 parser->multi_open = proto->multi_open; 11877 parser->multi_start = proto->multi_start; 11878 parser->multi_end = proto->multi_end; 11879 parser->preambled = proto->preambled; 11880 parser->sublex_info = proto->sublex_info; /* XXX not quite right */ 11881 parser->linestr = sv_dup_inc(proto->linestr, param); 11882 parser->expect = proto->expect; 11883 parser->copline = proto->copline; 11884 parser->last_lop_op = proto->last_lop_op; 11885 parser->lex_state = proto->lex_state; 11886 parser->rsfp = fp_dup(proto->rsfp, '<', param); 11887 /* rsfp_filters entries have fake IoDIRP() */ 11888 parser->rsfp_filters= av_dup_inc(proto->rsfp_filters, param); 11889 parser->in_my = proto->in_my; 11890 parser->in_my_stash = hv_dup(proto->in_my_stash, param); 11891 parser->error_count = proto->error_count; 11892 11893 11894 parser->linestr = sv_dup_inc(proto->linestr, param); 11895 11896 { 11897 char * const ols = SvPVX(proto->linestr); 11898 char * const ls = SvPVX(parser->linestr); 11899 11900 parser->bufptr = ls + (proto->bufptr >= ols ? 11901 proto->bufptr - ols : 0); 11902 parser->oldbufptr = ls + (proto->oldbufptr >= ols ? 11903 proto->oldbufptr - ols : 0); 11904 parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ? 11905 proto->oldoldbufptr - ols : 0); 11906 parser->linestart = ls + (proto->linestart >= ols ? 11907 proto->linestart - ols : 0); 11908 parser->last_uni = ls + (proto->last_uni >= ols ? 11909 proto->last_uni - ols : 0); 11910 parser->last_lop = ls + (proto->last_lop >= ols ? 11911 proto->last_lop - ols : 0); 11912 11913 parser->bufend = ls + SvCUR(parser->linestr); 11914 } 11915 11916 Copy(proto->tokenbuf, parser->tokenbuf, 256, char); 11917 11918 11919 #ifdef PERL_MAD 11920 parser->endwhite = proto->endwhite; 11921 parser->faketokens = proto->faketokens; 11922 parser->lasttoke = proto->lasttoke; 11923 parser->nextwhite = proto->nextwhite; 11924 parser->realtokenstart = proto->realtokenstart; 11925 parser->skipwhite = proto->skipwhite; 11926 parser->thisclose = proto->thisclose; 11927 parser->thismad = proto->thismad; 11928 parser->thisopen = proto->thisopen; 11929 parser->thisstuff = proto->thisstuff; 11930 parser->thistoken = proto->thistoken; 11931 parser->thiswhite = proto->thiswhite; 11932 11933 Copy(proto->nexttoke, parser->nexttoke, 5, NEXTTOKE); 11934 parser->curforce = proto->curforce; 11935 #else 11936 Copy(proto->nextval, parser->nextval, 5, YYSTYPE); 11937 Copy(proto->nexttype, parser->nexttype, 5, I32); 11938 parser->nexttoke = proto->nexttoke; 11939 #endif 11940 11941 /* XXX should clone saved_curcop here, but we aren't passed 11942 * proto_perl; so do it in perl_clone_using instead */ 11943 11944 return parser; 11945 } 11946 11947 11948 /* duplicate a file handle */ 11949 11950 PerlIO * 11951 Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param) 11952 { 11953 PerlIO *ret; 11954 11955 PERL_ARGS_ASSERT_FP_DUP; 11956 PERL_UNUSED_ARG(type); 11957 11958 if (!fp) 11959 return (PerlIO*)NULL; 11960 11961 /* look for it in the table first */ 11962 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp); 11963 if (ret) 11964 return ret; 11965 11966 /* create anew and remember what it is */ 11967 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE); 11968 ptr_table_store(PL_ptr_table, fp, ret); 11969 return ret; 11970 } 11971 11972 /* duplicate a directory handle */ 11973 11974 DIR * 11975 Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param) 11976 { 11977 DIR *ret; 11978 11979 #if defined(HAS_FCHDIR) && defined(HAS_TELLDIR) && defined(HAS_SEEKDIR) 11980 DIR *pwd; 11981 const Direntry_t *dirent; 11982 char smallbuf[256]; 11983 char *name = NULL; 11984 STRLEN len = 0; 11985 long pos; 11986 #endif 11987 11988 PERL_UNUSED_CONTEXT; 11989 PERL_ARGS_ASSERT_DIRP_DUP; 11990 11991 if (!dp) 11992 return (DIR*)NULL; 11993 11994 /* look for it in the table first */ 11995 ret = (DIR*)ptr_table_fetch(PL_ptr_table, dp); 11996 if (ret) 11997 return ret; 11998 11999 #if defined(HAS_FCHDIR) && defined(HAS_TELLDIR) && defined(HAS_SEEKDIR) 12000 12001 PERL_UNUSED_ARG(param); 12002 12003 /* create anew */ 12004 12005 /* open the current directory (so we can switch back) */ 12006 if (!(pwd = PerlDir_open("."))) return (DIR *)NULL; 12007 12008 /* chdir to our dir handle and open the present working directory */ 12009 if (fchdir(my_dirfd(dp)) < 0 || !(ret = PerlDir_open("."))) { 12010 PerlDir_close(pwd); 12011 return (DIR *)NULL; 12012 } 12013 /* Now we should have two dir handles pointing to the same dir. */ 12014 12015 /* Be nice to the calling code and chdir back to where we were. */ 12016 /* XXX If this fails, then what? */ 12017 PERL_UNUSED_RESULT(fchdir(my_dirfd(pwd))); 12018 12019 /* We have no need of the pwd handle any more. */ 12020 PerlDir_close(pwd); 12021 12022 #ifdef DIRNAMLEN 12023 # define d_namlen(d) (d)->d_namlen 12024 #else 12025 # define d_namlen(d) strlen((d)->d_name) 12026 #endif 12027 /* Iterate once through dp, to get the file name at the current posi- 12028 tion. Then step back. */ 12029 pos = PerlDir_tell(dp); 12030 if ((dirent = PerlDir_read(dp))) { 12031 len = d_namlen(dirent); 12032 if (len <= sizeof smallbuf) name = smallbuf; 12033 else Newx(name, len, char); 12034 Move(dirent->d_name, name, len, char); 12035 } 12036 PerlDir_seek(dp, pos); 12037 12038 /* Iterate through the new dir handle, till we find a file with the 12039 right name. */ 12040 if (!dirent) /* just before the end */ 12041 for(;;) { 12042 pos = PerlDir_tell(ret); 12043 if (PerlDir_read(ret)) continue; /* not there yet */ 12044 PerlDir_seek(ret, pos); /* step back */ 12045 break; 12046 } 12047 else { 12048 const long pos0 = PerlDir_tell(ret); 12049 for(;;) { 12050 pos = PerlDir_tell(ret); 12051 if ((dirent = PerlDir_read(ret))) { 12052 if (len == d_namlen(dirent) 12053 && memEQ(name, dirent->d_name, len)) { 12054 /* found it */ 12055 PerlDir_seek(ret, pos); /* step back */ 12056 break; 12057 } 12058 /* else we are not there yet; keep iterating */ 12059 } 12060 else { /* This is not meant to happen. The best we can do is 12061 reset the iterator to the beginning. */ 12062 PerlDir_seek(ret, pos0); 12063 break; 12064 } 12065 } 12066 } 12067 #undef d_namlen 12068 12069 if (name && name != smallbuf) 12070 Safefree(name); 12071 #endif 12072 12073 #ifdef WIN32 12074 ret = win32_dirp_dup(dp, param); 12075 #endif 12076 12077 /* pop it in the pointer table */ 12078 if (ret) 12079 ptr_table_store(PL_ptr_table, dp, ret); 12080 12081 return ret; 12082 } 12083 12084 /* duplicate a typeglob */ 12085 12086 GP * 12087 Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param) 12088 { 12089 GP *ret; 12090 12091 PERL_ARGS_ASSERT_GP_DUP; 12092 12093 if (!gp) 12094 return (GP*)NULL; 12095 /* look for it in the table first */ 12096 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp); 12097 if (ret) 12098 return ret; 12099 12100 /* create anew and remember what it is */ 12101 Newxz(ret, 1, GP); 12102 ptr_table_store(PL_ptr_table, gp, ret); 12103 12104 /* clone */ 12105 /* ret->gp_refcnt must be 0 before any other dups are called. We're relying 12106 on Newxz() to do this for us. */ 12107 ret->gp_sv = sv_dup_inc(gp->gp_sv, param); 12108 ret->gp_io = io_dup_inc(gp->gp_io, param); 12109 ret->gp_form = cv_dup_inc(gp->gp_form, param); 12110 ret->gp_av = av_dup_inc(gp->gp_av, param); 12111 ret->gp_hv = hv_dup_inc(gp->gp_hv, param); 12112 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */ 12113 ret->gp_cv = cv_dup_inc(gp->gp_cv, param); 12114 ret->gp_cvgen = gp->gp_cvgen; 12115 ret->gp_line = gp->gp_line; 12116 ret->gp_file_hek = hek_dup(gp->gp_file_hek, param); 12117 return ret; 12118 } 12119 12120 /* duplicate a chain of magic */ 12121 12122 MAGIC * 12123 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param) 12124 { 12125 MAGIC *mgret = NULL; 12126 MAGIC **mgprev_p = &mgret; 12127 12128 PERL_ARGS_ASSERT_MG_DUP; 12129 12130 for (; mg; mg = mg->mg_moremagic) { 12131 MAGIC *nmg; 12132 12133 if ((param->flags & CLONEf_JOIN_IN) 12134 && mg->mg_type == PERL_MAGIC_backref) 12135 /* when joining, we let the individual SVs add themselves to 12136 * backref as needed. */ 12137 continue; 12138 12139 Newx(nmg, 1, MAGIC); 12140 *mgprev_p = nmg; 12141 mgprev_p = &(nmg->mg_moremagic); 12142 12143 /* There was a comment "XXX copy dynamic vtable?" but as we don't have 12144 dynamic vtables, I'm not sure why Sarathy wrote it. The comment dates 12145 from the original commit adding Perl_mg_dup() - revision 4538. 12146 Similarly there is the annotation "XXX random ptr?" next to the 12147 assignment to nmg->mg_ptr. */ 12148 *nmg = *mg; 12149 12150 /* FIXME for plugins 12151 if (nmg->mg_type == PERL_MAGIC_qr) { 12152 nmg->mg_obj = MUTABLE_SV(CALLREGDUPE((REGEXP*)nmg->mg_obj, param)); 12153 } 12154 else 12155 */ 12156 nmg->mg_obj = (nmg->mg_flags & MGf_REFCOUNTED) 12157 ? nmg->mg_type == PERL_MAGIC_backref 12158 /* The backref AV has its reference 12159 * count deliberately bumped by 1 */ 12160 ? SvREFCNT_inc(av_dup_inc((const AV *) 12161 nmg->mg_obj, param)) 12162 : sv_dup_inc(nmg->mg_obj, param) 12163 : sv_dup(nmg->mg_obj, param); 12164 12165 if (nmg->mg_ptr && nmg->mg_type != PERL_MAGIC_regex_global) { 12166 if (nmg->mg_len > 0) { 12167 nmg->mg_ptr = SAVEPVN(nmg->mg_ptr, nmg->mg_len); 12168 if (nmg->mg_type == PERL_MAGIC_overload_table && 12169 AMT_AMAGIC((AMT*)nmg->mg_ptr)) 12170 { 12171 AMT * const namtp = (AMT*)nmg->mg_ptr; 12172 sv_dup_inc_multiple((SV**)(namtp->table), 12173 (SV**)(namtp->table), NofAMmeth, param); 12174 } 12175 } 12176 else if (nmg->mg_len == HEf_SVKEY) 12177 nmg->mg_ptr = (char*)sv_dup_inc((const SV *)nmg->mg_ptr, param); 12178 } 12179 if ((nmg->mg_flags & MGf_DUP) && nmg->mg_virtual && nmg->mg_virtual->svt_dup) { 12180 nmg->mg_virtual->svt_dup(aTHX_ nmg, param); 12181 } 12182 } 12183 return mgret; 12184 } 12185 12186 #endif /* USE_ITHREADS */ 12187 12188 struct ptr_tbl_arena { 12189 struct ptr_tbl_arena *next; 12190 struct ptr_tbl_ent array[1023/3]; /* as ptr_tbl_ent has 3 pointers. */ 12191 }; 12192 12193 /* create a new pointer-mapping table */ 12194 12195 PTR_TBL_t * 12196 Perl_ptr_table_new(pTHX) 12197 { 12198 PTR_TBL_t *tbl; 12199 PERL_UNUSED_CONTEXT; 12200 12201 Newx(tbl, 1, PTR_TBL_t); 12202 tbl->tbl_max = 511; 12203 tbl->tbl_items = 0; 12204 tbl->tbl_arena = NULL; 12205 tbl->tbl_arena_next = NULL; 12206 tbl->tbl_arena_end = NULL; 12207 Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*); 12208 return tbl; 12209 } 12210 12211 #define PTR_TABLE_HASH(ptr) \ 12212 ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17))) 12213 12214 /* map an existing pointer using a table */ 12215 12216 STATIC PTR_TBL_ENT_t * 12217 S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv) 12218 { 12219 PTR_TBL_ENT_t *tblent; 12220 const UV hash = PTR_TABLE_HASH(sv); 12221 12222 PERL_ARGS_ASSERT_PTR_TABLE_FIND; 12223 12224 tblent = tbl->tbl_ary[hash & tbl->tbl_max]; 12225 for (; tblent; tblent = tblent->next) { 12226 if (tblent->oldval == sv) 12227 return tblent; 12228 } 12229 return NULL; 12230 } 12231 12232 void * 12233 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv) 12234 { 12235 PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv); 12236 12237 PERL_ARGS_ASSERT_PTR_TABLE_FETCH; 12238 PERL_UNUSED_CONTEXT; 12239 12240 return tblent ? tblent->newval : NULL; 12241 } 12242 12243 /* add a new entry to a pointer-mapping table 'tbl'. In hash terms, 'oldsv' is 12244 * the key; 'newsv' is the value. The names "old" and "new" are specific to 12245 * the core's typical use of ptr_tables in thread cloning. */ 12246 12247 void 12248 Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv) 12249 { 12250 PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv); 12251 12252 PERL_ARGS_ASSERT_PTR_TABLE_STORE; 12253 PERL_UNUSED_CONTEXT; 12254 12255 if (tblent) { 12256 tblent->newval = newsv; 12257 } else { 12258 const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max; 12259 12260 if (tbl->tbl_arena_next == tbl->tbl_arena_end) { 12261 struct ptr_tbl_arena *new_arena; 12262 12263 Newx(new_arena, 1, struct ptr_tbl_arena); 12264 new_arena->next = tbl->tbl_arena; 12265 tbl->tbl_arena = new_arena; 12266 tbl->tbl_arena_next = new_arena->array; 12267 tbl->tbl_arena_end = C_ARRAY_END(new_arena->array); 12268 } 12269 12270 tblent = tbl->tbl_arena_next++; 12271 12272 tblent->oldval = oldsv; 12273 tblent->newval = newsv; 12274 tblent->next = tbl->tbl_ary[entry]; 12275 tbl->tbl_ary[entry] = tblent; 12276 tbl->tbl_items++; 12277 if (tblent->next && tbl->tbl_items > tbl->tbl_max) 12278 ptr_table_split(tbl); 12279 } 12280 } 12281 12282 /* double the hash bucket size of an existing ptr table */ 12283 12284 void 12285 Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl) 12286 { 12287 PTR_TBL_ENT_t **ary = tbl->tbl_ary; 12288 const UV oldsize = tbl->tbl_max + 1; 12289 UV newsize = oldsize * 2; 12290 UV i; 12291 12292 PERL_ARGS_ASSERT_PTR_TABLE_SPLIT; 12293 PERL_UNUSED_CONTEXT; 12294 12295 Renew(ary, newsize, PTR_TBL_ENT_t*); 12296 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*); 12297 tbl->tbl_max = --newsize; 12298 tbl->tbl_ary = ary; 12299 for (i=0; i < oldsize; i++, ary++) { 12300 PTR_TBL_ENT_t **entp = ary; 12301 PTR_TBL_ENT_t *ent = *ary; 12302 PTR_TBL_ENT_t **curentp; 12303 if (!ent) 12304 continue; 12305 curentp = ary + oldsize; 12306 do { 12307 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) { 12308 *entp = ent->next; 12309 ent->next = *curentp; 12310 *curentp = ent; 12311 } 12312 else 12313 entp = &ent->next; 12314 ent = *entp; 12315 } while (ent); 12316 } 12317 } 12318 12319 /* remove all the entries from a ptr table */ 12320 /* Deprecated - will be removed post 5.14 */ 12321 12322 void 12323 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl) 12324 { 12325 if (tbl && tbl->tbl_items) { 12326 struct ptr_tbl_arena *arena = tbl->tbl_arena; 12327 12328 Zero(tbl->tbl_ary, tbl->tbl_max + 1, struct ptr_tbl_ent **); 12329 12330 while (arena) { 12331 struct ptr_tbl_arena *next = arena->next; 12332 12333 Safefree(arena); 12334 arena = next; 12335 }; 12336 12337 tbl->tbl_items = 0; 12338 tbl->tbl_arena = NULL; 12339 tbl->tbl_arena_next = NULL; 12340 tbl->tbl_arena_end = NULL; 12341 } 12342 } 12343 12344 /* clear and free a ptr table */ 12345 12346 void 12347 Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl) 12348 { 12349 struct ptr_tbl_arena *arena; 12350 12351 if (!tbl) { 12352 return; 12353 } 12354 12355 arena = tbl->tbl_arena; 12356 12357 while (arena) { 12358 struct ptr_tbl_arena *next = arena->next; 12359 12360 Safefree(arena); 12361 arena = next; 12362 } 12363 12364 Safefree(tbl->tbl_ary); 12365 Safefree(tbl); 12366 } 12367 12368 #if defined(USE_ITHREADS) 12369 12370 void 12371 Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const param) 12372 { 12373 PERL_ARGS_ASSERT_RVPV_DUP; 12374 12375 assert(!isREGEXP(sstr)); 12376 if (SvROK(sstr)) { 12377 if (SvWEAKREF(sstr)) { 12378 SvRV_set(dstr, sv_dup(SvRV_const(sstr), param)); 12379 if (param->flags & CLONEf_JOIN_IN) { 12380 /* if joining, we add any back references individually rather 12381 * than copying the whole backref array */ 12382 Perl_sv_add_backref(aTHX_ SvRV(dstr), dstr); 12383 } 12384 } 12385 else 12386 SvRV_set(dstr, sv_dup_inc(SvRV_const(sstr), param)); 12387 } 12388 else if (SvPVX_const(sstr)) { 12389 /* Has something there */ 12390 if (SvLEN(sstr)) { 12391 /* Normal PV - clone whole allocated space */ 12392 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1)); 12393 /* sstr may not be that normal, but actually copy on write. 12394 But we are a true, independent SV, so: */ 12395 SvIsCOW_off(dstr); 12396 } 12397 else { 12398 /* Special case - not normally malloced for some reason */ 12399 if (isGV_with_GP(sstr)) { 12400 /* Don't need to do anything here. */ 12401 } 12402 else if ((SvIsCOW(sstr))) { 12403 /* A "shared" PV - clone it as "shared" PV */ 12404 SvPV_set(dstr, 12405 HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)), 12406 param))); 12407 } 12408 else { 12409 /* Some other special case - random pointer */ 12410 SvPV_set(dstr, (char *) SvPVX_const(sstr)); 12411 } 12412 } 12413 } 12414 else { 12415 /* Copy the NULL */ 12416 SvPV_set(dstr, NULL); 12417 } 12418 } 12419 12420 /* duplicate a list of SVs. source and dest may point to the same memory. */ 12421 static SV ** 12422 S_sv_dup_inc_multiple(pTHX_ SV *const *source, SV **dest, 12423 SSize_t items, CLONE_PARAMS *const param) 12424 { 12425 PERL_ARGS_ASSERT_SV_DUP_INC_MULTIPLE; 12426 12427 while (items-- > 0) { 12428 *dest++ = sv_dup_inc(*source++, param); 12429 } 12430 12431 return dest; 12432 } 12433 12434 /* duplicate an SV of any type (including AV, HV etc) */ 12435 12436 static SV * 12437 S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) 12438 { 12439 dVAR; 12440 SV *dstr; 12441 12442 PERL_ARGS_ASSERT_SV_DUP_COMMON; 12443 12444 if (SvTYPE(sstr) == (svtype)SVTYPEMASK) { 12445 #ifdef DEBUG_LEAKING_SCALARS_ABORT 12446 abort(); 12447 #endif 12448 return NULL; 12449 } 12450 /* look for it in the table first */ 12451 dstr = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, sstr)); 12452 if (dstr) 12453 return dstr; 12454 12455 if(param->flags & CLONEf_JOIN_IN) { 12456 /** We are joining here so we don't want do clone 12457 something that is bad **/ 12458 if (SvTYPE(sstr) == SVt_PVHV) { 12459 const HEK * const hvname = HvNAME_HEK(sstr); 12460 if (hvname) { 12461 /** don't clone stashes if they already exist **/ 12462 dstr = MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 12463 HEK_UTF8(hvname) ? SVf_UTF8 : 0)); 12464 ptr_table_store(PL_ptr_table, sstr, dstr); 12465 return dstr; 12466 } 12467 } 12468 else if (SvTYPE(sstr) == SVt_PVGV && !SvFAKE(sstr)) { 12469 HV *stash = GvSTASH(sstr); 12470 const HEK * hvname; 12471 if (stash && (hvname = HvNAME_HEK(stash))) { 12472 /** don't clone GVs if they already exist **/ 12473 SV **svp; 12474 stash = gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 12475 HEK_UTF8(hvname) ? SVf_UTF8 : 0); 12476 svp = hv_fetch( 12477 stash, GvNAME(sstr), 12478 GvNAMEUTF8(sstr) 12479 ? -GvNAMELEN(sstr) 12480 : GvNAMELEN(sstr), 12481 0 12482 ); 12483 if (svp && *svp && SvTYPE(*svp) == SVt_PVGV) { 12484 ptr_table_store(PL_ptr_table, sstr, *svp); 12485 return *svp; 12486 } 12487 } 12488 } 12489 } 12490 12491 /* create anew and remember what it is */ 12492 new_SV(dstr); 12493 12494 #ifdef DEBUG_LEAKING_SCALARS 12495 dstr->sv_debug_optype = sstr->sv_debug_optype; 12496 dstr->sv_debug_line = sstr->sv_debug_line; 12497 dstr->sv_debug_inpad = sstr->sv_debug_inpad; 12498 dstr->sv_debug_parent = (SV*)sstr; 12499 FREE_SV_DEBUG_FILE(dstr); 12500 dstr->sv_debug_file = savesharedpv(sstr->sv_debug_file); 12501 #endif 12502 12503 ptr_table_store(PL_ptr_table, sstr, dstr); 12504 12505 /* clone */ 12506 SvFLAGS(dstr) = SvFLAGS(sstr); 12507 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */ 12508 SvREFCNT(dstr) = 0; /* must be before any other dups! */ 12509 12510 #ifdef DEBUGGING 12511 if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx) 12512 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n", 12513 (void*)PL_watch_pvx, SvPVX_const(sstr)); 12514 #endif 12515 12516 /* don't clone objects whose class has asked us not to */ 12517 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) { 12518 SvFLAGS(dstr) = 0; 12519 return dstr; 12520 } 12521 12522 switch (SvTYPE(sstr)) { 12523 case SVt_NULL: 12524 SvANY(dstr) = NULL; 12525 break; 12526 case SVt_IV: 12527 SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv)); 12528 if(SvROK(sstr)) { 12529 Perl_rvpv_dup(aTHX_ dstr, sstr, param); 12530 } else { 12531 SvIV_set(dstr, SvIVX(sstr)); 12532 } 12533 break; 12534 case SVt_NV: 12535 SvANY(dstr) = new_XNV(); 12536 SvNV_set(dstr, SvNVX(sstr)); 12537 break; 12538 default: 12539 { 12540 /* These are all the types that need complex bodies allocating. */ 12541 void *new_body; 12542 const svtype sv_type = SvTYPE(sstr); 12543 const struct body_details *const sv_type_details 12544 = bodies_by_type + sv_type; 12545 12546 switch (sv_type) { 12547 default: 12548 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr)); 12549 break; 12550 12551 case SVt_PVGV: 12552 case SVt_PVIO: 12553 case SVt_PVFM: 12554 case SVt_PVHV: 12555 case SVt_PVAV: 12556 case SVt_PVCV: 12557 case SVt_PVLV: 12558 case SVt_REGEXP: 12559 case SVt_PVMG: 12560 case SVt_PVNV: 12561 case SVt_PVIV: 12562 case SVt_INVLIST: 12563 case SVt_PV: 12564 assert(sv_type_details->body_size); 12565 if (sv_type_details->arena) { 12566 new_body_inline(new_body, sv_type); 12567 new_body 12568 = (void*)((char*)new_body - sv_type_details->offset); 12569 } else { 12570 new_body = new_NOARENA(sv_type_details); 12571 } 12572 } 12573 assert(new_body); 12574 SvANY(dstr) = new_body; 12575 12576 #ifndef PURIFY 12577 Copy(((char*)SvANY(sstr)) + sv_type_details->offset, 12578 ((char*)SvANY(dstr)) + sv_type_details->offset, 12579 sv_type_details->copy, char); 12580 #else 12581 Copy(((char*)SvANY(sstr)), 12582 ((char*)SvANY(dstr)), 12583 sv_type_details->body_size + sv_type_details->offset, char); 12584 #endif 12585 12586 if (sv_type != SVt_PVAV && sv_type != SVt_PVHV 12587 && !isGV_with_GP(dstr) 12588 && !isREGEXP(dstr) 12589 && !(sv_type == SVt_PVIO && !(IoFLAGS(dstr) & IOf_FAKE_DIRP))) 12590 Perl_rvpv_dup(aTHX_ dstr, sstr, param); 12591 12592 /* The Copy above means that all the source (unduplicated) pointers 12593 are now in the destination. We can check the flags and the 12594 pointers in either, but it's possible that there's less cache 12595 missing by always going for the destination. 12596 FIXME - instrument and check that assumption */ 12597 if (sv_type >= SVt_PVMG) { 12598 if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) { 12599 SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param)); 12600 } else if (sv_type == SVt_PVAV && AvPAD_NAMELIST(dstr)) { 12601 NOOP; 12602 } else if (SvMAGIC(dstr)) 12603 SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param)); 12604 if (SvOBJECT(dstr) && SvSTASH(dstr)) 12605 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param)); 12606 else SvSTASH_set(dstr, 0); /* don't copy DESTROY cache */ 12607 } 12608 12609 /* The cast silences a GCC warning about unhandled types. */ 12610 switch ((int)sv_type) { 12611 case SVt_PV: 12612 break; 12613 case SVt_PVIV: 12614 break; 12615 case SVt_PVNV: 12616 break; 12617 case SVt_PVMG: 12618 break; 12619 case SVt_REGEXP: 12620 duprex: 12621 /* FIXME for plugins */ 12622 dstr->sv_u.svu_rx = ((REGEXP *)dstr)->sv_any; 12623 re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param); 12624 break; 12625 case SVt_PVLV: 12626 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */ 12627 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */ 12628 LvTARG(dstr) = dstr; 12629 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */ 12630 LvTARG(dstr) = MUTABLE_SV(he_dup((HE*)LvTARG(dstr), 0, param)); 12631 else 12632 LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param); 12633 if (isREGEXP(sstr)) goto duprex; 12634 case SVt_PVGV: 12635 /* non-GP case already handled above */ 12636 if(isGV_with_GP(sstr)) { 12637 GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param); 12638 /* Don't call sv_add_backref here as it's going to be 12639 created as part of the magic cloning of the symbol 12640 table--unless this is during a join and the stash 12641 is not actually being cloned. */ 12642 /* Danger Will Robinson - GvGP(dstr) isn't initialised 12643 at the point of this comment. */ 12644 GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param); 12645 if (param->flags & CLONEf_JOIN_IN) 12646 Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr); 12647 GvGP_set(dstr, gp_dup(GvGP(sstr), param)); 12648 (void)GpREFCNT_inc(GvGP(dstr)); 12649 } 12650 break; 12651 case SVt_PVIO: 12652 /* PL_parser->rsfp_filters entries have fake IoDIRP() */ 12653 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) { 12654 /* I have no idea why fake dirp (rsfps) 12655 should be treated differently but otherwise 12656 we end up with leaks -- sky*/ 12657 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param); 12658 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param); 12659 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param); 12660 } else { 12661 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param); 12662 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param); 12663 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param); 12664 if (IoDIRP(dstr)) { 12665 IoDIRP(dstr) = dirp_dup(IoDIRP(dstr), param); 12666 } else { 12667 NOOP; 12668 /* IoDIRP(dstr) is already a copy of IoDIRP(sstr) */ 12669 } 12670 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(dstr), param); 12671 } 12672 if (IoOFP(dstr) == IoIFP(sstr)) 12673 IoOFP(dstr) = IoIFP(dstr); 12674 else 12675 IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param); 12676 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr)); 12677 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr)); 12678 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr)); 12679 break; 12680 case SVt_PVAV: 12681 /* avoid cloning an empty array */ 12682 if (AvARRAY((const AV *)sstr) && AvFILLp((const AV *)sstr) >= 0) { 12683 SV **dst_ary, **src_ary; 12684 SSize_t items = AvFILLp((const AV *)sstr) + 1; 12685 12686 src_ary = AvARRAY((const AV *)sstr); 12687 Newxz(dst_ary, AvMAX((const AV *)sstr)+1, SV*); 12688 ptr_table_store(PL_ptr_table, src_ary, dst_ary); 12689 AvARRAY(MUTABLE_AV(dstr)) = dst_ary; 12690 AvALLOC((const AV *)dstr) = dst_ary; 12691 if (AvREAL((const AV *)sstr)) { 12692 dst_ary = sv_dup_inc_multiple(src_ary, dst_ary, items, 12693 param); 12694 } 12695 else { 12696 while (items-- > 0) 12697 *dst_ary++ = sv_dup(*src_ary++, param); 12698 } 12699 items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr); 12700 while (items-- > 0) { 12701 *dst_ary++ = NULL; 12702 } 12703 } 12704 else { 12705 AvARRAY(MUTABLE_AV(dstr)) = NULL; 12706 AvALLOC((const AV *)dstr) = (SV**)NULL; 12707 AvMAX( (const AV *)dstr) = -1; 12708 AvFILLp((const AV *)dstr) = -1; 12709 } 12710 break; 12711 case SVt_PVHV: 12712 if (HvARRAY((const HV *)sstr)) { 12713 STRLEN i = 0; 12714 const bool sharekeys = !!HvSHAREKEYS(sstr); 12715 XPVHV * const dxhv = (XPVHV*)SvANY(dstr); 12716 XPVHV * const sxhv = (XPVHV*)SvANY(sstr); 12717 char *darray; 12718 Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1) 12719 + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0), 12720 char); 12721 HvARRAY(dstr) = (HE**)darray; 12722 while (i <= sxhv->xhv_max) { 12723 const HE * const source = HvARRAY(sstr)[i]; 12724 HvARRAY(dstr)[i] = source 12725 ? he_dup(source, sharekeys, param) : 0; 12726 ++i; 12727 } 12728 if (SvOOK(sstr)) { 12729 const struct xpvhv_aux * const saux = HvAUX(sstr); 12730 struct xpvhv_aux * const daux = HvAUX(dstr); 12731 /* This flag isn't copied. */ 12732 SvOOK_on(dstr); 12733 12734 if (saux->xhv_name_count) { 12735 HEK ** const sname = saux->xhv_name_u.xhvnameu_names; 12736 const I32 count 12737 = saux->xhv_name_count < 0 12738 ? -saux->xhv_name_count 12739 : saux->xhv_name_count; 12740 HEK **shekp = sname + count; 12741 HEK **dhekp; 12742 Newx(daux->xhv_name_u.xhvnameu_names, count, HEK *); 12743 dhekp = daux->xhv_name_u.xhvnameu_names + count; 12744 while (shekp-- > sname) { 12745 dhekp--; 12746 *dhekp = hek_dup(*shekp, param); 12747 } 12748 } 12749 else { 12750 daux->xhv_name_u.xhvnameu_name 12751 = hek_dup(saux->xhv_name_u.xhvnameu_name, 12752 param); 12753 } 12754 daux->xhv_name_count = saux->xhv_name_count; 12755 12756 daux->xhv_fill_lazy = saux->xhv_fill_lazy; 12757 daux->xhv_aux_flags = saux->xhv_aux_flags; 12758 #ifdef PERL_HASH_RANDOMIZE_KEYS 12759 daux->xhv_rand = saux->xhv_rand; 12760 daux->xhv_last_rand = saux->xhv_last_rand; 12761 #endif 12762 daux->xhv_riter = saux->xhv_riter; 12763 daux->xhv_eiter = saux->xhv_eiter 12764 ? he_dup(saux->xhv_eiter, 12765 cBOOL(HvSHAREKEYS(sstr)), param) : 0; 12766 /* backref array needs refcnt=2; see sv_add_backref */ 12767 daux->xhv_backreferences = 12768 (param->flags & CLONEf_JOIN_IN) 12769 /* when joining, we let the individual GVs and 12770 * CVs add themselves to backref as 12771 * needed. This avoids pulling in stuff 12772 * that isn't required, and simplifies the 12773 * case where stashes aren't cloned back 12774 * if they already exist in the parent 12775 * thread */ 12776 ? NULL 12777 : saux->xhv_backreferences 12778 ? (SvTYPE(saux->xhv_backreferences) == SVt_PVAV) 12779 ? MUTABLE_AV(SvREFCNT_inc( 12780 sv_dup_inc((const SV *) 12781 saux->xhv_backreferences, param))) 12782 : MUTABLE_AV(sv_dup((const SV *) 12783 saux->xhv_backreferences, param)) 12784 : 0; 12785 12786 daux->xhv_mro_meta = saux->xhv_mro_meta 12787 ? mro_meta_dup(saux->xhv_mro_meta, param) 12788 : 0; 12789 12790 /* Record stashes for possible cloning in Perl_clone(). */ 12791 if (HvNAME(sstr)) 12792 av_push(param->stashes, dstr); 12793 } 12794 } 12795 else 12796 HvARRAY(MUTABLE_HV(dstr)) = NULL; 12797 break; 12798 case SVt_PVCV: 12799 if (!(param->flags & CLONEf_COPY_STACKS)) { 12800 CvDEPTH(dstr) = 0; 12801 } 12802 /*FALLTHROUGH*/ 12803 case SVt_PVFM: 12804 /* NOTE: not refcounted */ 12805 SvANY(MUTABLE_CV(dstr))->xcv_stash = 12806 hv_dup(CvSTASH(dstr), param); 12807 if ((param->flags & CLONEf_JOIN_IN) && CvSTASH(dstr)) 12808 Perl_sv_add_backref(aTHX_ MUTABLE_SV(CvSTASH(dstr)), dstr); 12809 if (!CvISXSUB(dstr)) { 12810 OP_REFCNT_LOCK; 12811 CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr)); 12812 OP_REFCNT_UNLOCK; 12813 CvSLABBED_off(dstr); 12814 } else if (CvCONST(dstr)) { 12815 CvXSUBANY(dstr).any_ptr = 12816 sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param); 12817 } 12818 assert(!CvSLABBED(dstr)); 12819 if (CvDYNFILE(dstr)) CvFILE(dstr) = SAVEPV(CvFILE(dstr)); 12820 if (CvNAMED(dstr)) 12821 SvANY((CV *)dstr)->xcv_gv_u.xcv_hek = 12822 share_hek_hek(CvNAME_HEK((CV *)sstr)); 12823 /* don't dup if copying back - CvGV isn't refcounted, so the 12824 * duped GV may never be freed. A bit of a hack! DAPM */ 12825 else 12826 SvANY(MUTABLE_CV(dstr))->xcv_gv_u.xcv_gv = 12827 CvCVGV_RC(dstr) 12828 ? gv_dup_inc(CvGV(sstr), param) 12829 : (param->flags & CLONEf_JOIN_IN) 12830 ? NULL 12831 : gv_dup(CvGV(sstr), param); 12832 12833 CvPADLIST(dstr) = padlist_dup(CvPADLIST(sstr), param); 12834 CvOUTSIDE(dstr) = 12835 CvWEAKOUTSIDE(sstr) 12836 ? cv_dup( CvOUTSIDE(dstr), param) 12837 : cv_dup_inc(CvOUTSIDE(dstr), param); 12838 break; 12839 } 12840 } 12841 } 12842 12843 return dstr; 12844 } 12845 12846 SV * 12847 Perl_sv_dup_inc(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) 12848 { 12849 PERL_ARGS_ASSERT_SV_DUP_INC; 12850 return sstr ? SvREFCNT_inc(sv_dup_common(sstr, param)) : NULL; 12851 } 12852 12853 SV * 12854 Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) 12855 { 12856 SV *dstr = sstr ? sv_dup_common(sstr, param) : NULL; 12857 PERL_ARGS_ASSERT_SV_DUP; 12858 12859 /* Track every SV that (at least initially) had a reference count of 0. 12860 We need to do this by holding an actual reference to it in this array. 12861 If we attempt to cheat, turn AvREAL_off(), and store only pointers 12862 (akin to the stashes hash, and the perl stack), we come unstuck if 12863 a weak reference (or other SV legitimately SvREFCNT() == 0 for this 12864 thread) is manipulated in a CLONE method, because CLONE runs before the 12865 unreferenced array is walked to find SVs still with SvREFCNT() == 0 12866 (and fix things up by giving each a reference via the temps stack). 12867 Instead, during CLONE, if the 0-referenced SV has SvREFCNT_inc() and 12868 then SvREFCNT_dec(), it will be cleaned up (and added to the free list) 12869 before the walk of unreferenced happens and a reference to that is SV 12870 added to the temps stack. At which point we have the same SV considered 12871 to be in use, and free to be re-used. Not good. 12872 */ 12873 if (dstr && !(param->flags & CLONEf_COPY_STACKS) && !SvREFCNT(dstr)) { 12874 assert(param->unreferenced); 12875 av_push(param->unreferenced, SvREFCNT_inc(dstr)); 12876 } 12877 12878 return dstr; 12879 } 12880 12881 /* duplicate a context */ 12882 12883 PERL_CONTEXT * 12884 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) 12885 { 12886 PERL_CONTEXT *ncxs; 12887 12888 PERL_ARGS_ASSERT_CX_DUP; 12889 12890 if (!cxs) 12891 return (PERL_CONTEXT*)NULL; 12892 12893 /* look for it in the table first */ 12894 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs); 12895 if (ncxs) 12896 return ncxs; 12897 12898 /* create anew and remember what it is */ 12899 Newx(ncxs, max + 1, PERL_CONTEXT); 12900 ptr_table_store(PL_ptr_table, cxs, ncxs); 12901 Copy(cxs, ncxs, max + 1, PERL_CONTEXT); 12902 12903 while (ix >= 0) { 12904 PERL_CONTEXT * const ncx = &ncxs[ix]; 12905 if (CxTYPE(ncx) == CXt_SUBST) { 12906 Perl_croak(aTHX_ "Cloning substitution context is unimplemented"); 12907 } 12908 else { 12909 ncx->blk_oldcop = (COP*)any_dup(ncx->blk_oldcop, param->proto_perl); 12910 switch (CxTYPE(ncx)) { 12911 case CXt_SUB: 12912 ncx->blk_sub.cv = (ncx->blk_sub.olddepth == 0 12913 ? cv_dup_inc(ncx->blk_sub.cv, param) 12914 : cv_dup(ncx->blk_sub.cv,param)); 12915 ncx->blk_sub.argarray = (CxHASARGS(ncx) 12916 ? av_dup_inc(ncx->blk_sub.argarray, 12917 param) 12918 : NULL); 12919 ncx->blk_sub.savearray = (CxHASARGS(ncx) 12920 ? av_dup_inc(ncx->blk_sub.savearray, 12921 param) 12922 : NULL); 12923 ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table, 12924 ncx->blk_sub.oldcomppad); 12925 break; 12926 case CXt_EVAL: 12927 ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv, 12928 param); 12929 ncx->blk_eval.cur_text = sv_dup(ncx->blk_eval.cur_text, param); 12930 ncx->blk_eval.cv = cv_dup(ncx->blk_eval.cv, param); 12931 break; 12932 case CXt_LOOP_LAZYSV: 12933 ncx->blk_loop.state_u.lazysv.end 12934 = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param); 12935 /* We are taking advantage of av_dup_inc and sv_dup_inc 12936 actually being the same function, and order equivalence of 12937 the two unions. 12938 We can assert the later [but only at run time :-(] */ 12939 assert ((void *) &ncx->blk_loop.state_u.ary.ary == 12940 (void *) &ncx->blk_loop.state_u.lazysv.cur); 12941 case CXt_LOOP_FOR: 12942 ncx->blk_loop.state_u.ary.ary 12943 = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param); 12944 case CXt_LOOP_LAZYIV: 12945 case CXt_LOOP_PLAIN: 12946 if (CxPADLOOP(ncx)) { 12947 ncx->blk_loop.itervar_u.oldcomppad 12948 = (PAD*)ptr_table_fetch(PL_ptr_table, 12949 ncx->blk_loop.itervar_u.oldcomppad); 12950 } else { 12951 ncx->blk_loop.itervar_u.gv 12952 = gv_dup((const GV *)ncx->blk_loop.itervar_u.gv, 12953 param); 12954 } 12955 break; 12956 case CXt_FORMAT: 12957 ncx->blk_format.cv = cv_dup(ncx->blk_format.cv, param); 12958 ncx->blk_format.gv = gv_dup(ncx->blk_format.gv, param); 12959 ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv, 12960 param); 12961 break; 12962 case CXt_BLOCK: 12963 case CXt_NULL: 12964 case CXt_WHEN: 12965 case CXt_GIVEN: 12966 break; 12967 } 12968 } 12969 --ix; 12970 } 12971 return ncxs; 12972 } 12973 12974 /* duplicate a stack info structure */ 12975 12976 PERL_SI * 12977 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param) 12978 { 12979 PERL_SI *nsi; 12980 12981 PERL_ARGS_ASSERT_SI_DUP; 12982 12983 if (!si) 12984 return (PERL_SI*)NULL; 12985 12986 /* look for it in the table first */ 12987 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si); 12988 if (nsi) 12989 return nsi; 12990 12991 /* create anew and remember what it is */ 12992 Newxz(nsi, 1, PERL_SI); 12993 ptr_table_store(PL_ptr_table, si, nsi); 12994 12995 nsi->si_stack = av_dup_inc(si->si_stack, param); 12996 nsi->si_cxix = si->si_cxix; 12997 nsi->si_cxmax = si->si_cxmax; 12998 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param); 12999 nsi->si_type = si->si_type; 13000 nsi->si_prev = si_dup(si->si_prev, param); 13001 nsi->si_next = si_dup(si->si_next, param); 13002 nsi->si_markoff = si->si_markoff; 13003 13004 return nsi; 13005 } 13006 13007 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32) 13008 #define TOPINT(ss,ix) ((ss)[ix].any_i32) 13009 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long) 13010 #define TOPLONG(ss,ix) ((ss)[ix].any_long) 13011 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv) 13012 #define TOPIV(ss,ix) ((ss)[ix].any_iv) 13013 #define POPUV(ss,ix) ((ss)[--(ix)].any_uv) 13014 #define TOPUV(ss,ix) ((ss)[ix].any_uv) 13015 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool) 13016 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool) 13017 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr) 13018 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr) 13019 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr) 13020 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr) 13021 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr) 13022 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr) 13023 13024 /* XXXXX todo */ 13025 #define pv_dup_inc(p) SAVEPV(p) 13026 #define pv_dup(p) SAVEPV(p) 13027 #define svp_dup_inc(p,pp) any_dup(p,pp) 13028 13029 /* map any object to the new equivent - either something in the 13030 * ptr table, or something in the interpreter structure 13031 */ 13032 13033 void * 13034 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl) 13035 { 13036 void *ret; 13037 13038 PERL_ARGS_ASSERT_ANY_DUP; 13039 13040 if (!v) 13041 return (void*)NULL; 13042 13043 /* look for it in the table first */ 13044 ret = ptr_table_fetch(PL_ptr_table, v); 13045 if (ret) 13046 return ret; 13047 13048 /* see if it is part of the interpreter structure */ 13049 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1)) 13050 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl)); 13051 else { 13052 ret = v; 13053 } 13054 13055 return ret; 13056 } 13057 13058 /* duplicate the save stack */ 13059 13060 ANY * 13061 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) 13062 { 13063 dVAR; 13064 ANY * const ss = proto_perl->Isavestack; 13065 const I32 max = proto_perl->Isavestack_max; 13066 I32 ix = proto_perl->Isavestack_ix; 13067 ANY *nss; 13068 const SV *sv; 13069 const GV *gv; 13070 const AV *av; 13071 const HV *hv; 13072 void* ptr; 13073 int intval; 13074 long longval; 13075 GP *gp; 13076 IV iv; 13077 I32 i; 13078 char *c = NULL; 13079 void (*dptr) (void*); 13080 void (*dxptr) (pTHX_ void*); 13081 13082 PERL_ARGS_ASSERT_SS_DUP; 13083 13084 Newxz(nss, max, ANY); 13085 13086 while (ix > 0) { 13087 const UV uv = POPUV(ss,ix); 13088 const U8 type = (U8)uv & SAVE_MASK; 13089 13090 TOPUV(nss,ix) = uv; 13091 switch (type) { 13092 case SAVEt_CLEARSV: 13093 case SAVEt_CLEARPADRANGE: 13094 break; 13095 case SAVEt_HELEM: /* hash element */ 13096 case SAVEt_SV: /* scalar reference */ 13097 sv = (const SV *)POPPTR(ss,ix); 13098 TOPPTR(nss,ix) = SvREFCNT_inc(sv_dup_inc(sv, param)); 13099 /* fall through */ 13100 case SAVEt_ITEM: /* normal string */ 13101 case SAVEt_GVSV: /* scalar slot in GV */ 13102 sv = (const SV *)POPPTR(ss,ix); 13103 TOPPTR(nss,ix) = sv_dup_inc(sv, param); 13104 if (type == SAVEt_SV) 13105 break; 13106 /* fall through */ 13107 case SAVEt_FREESV: 13108 case SAVEt_MORTALIZESV: 13109 case SAVEt_READONLY_OFF: 13110 sv = (const SV *)POPPTR(ss,ix); 13111 TOPPTR(nss,ix) = sv_dup_inc(sv, param); 13112 break; 13113 case SAVEt_SHARED_PVREF: /* char* in shared space */ 13114 c = (char*)POPPTR(ss,ix); 13115 TOPPTR(nss,ix) = savesharedpv(c); 13116 ptr = POPPTR(ss,ix); 13117 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); 13118 break; 13119 case SAVEt_GENERIC_SVREF: /* generic sv */ 13120 case SAVEt_SVREF: /* scalar reference */ 13121 sv = (const SV *)POPPTR(ss,ix); 13122 TOPPTR(nss,ix) = sv_dup_inc(sv, param); 13123 if (type == SAVEt_SVREF) 13124 SvREFCNT_inc_simple_void((SV *)TOPPTR(nss,ix)); 13125 ptr = POPPTR(ss,ix); 13126 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */ 13127 break; 13128 case SAVEt_GVSLOT: /* any slot in GV */ 13129 sv = (const SV *)POPPTR(ss,ix); 13130 TOPPTR(nss,ix) = sv_dup_inc(sv, param); 13131 ptr = POPPTR(ss,ix); 13132 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */ 13133 sv = (const SV *)POPPTR(ss,ix); 13134 TOPPTR(nss,ix) = sv_dup_inc(sv, param); 13135 break; 13136 case SAVEt_HV: /* hash reference */ 13137 case SAVEt_AV: /* array reference */ 13138 sv = (const SV *) POPPTR(ss,ix); 13139 TOPPTR(nss,ix) = sv_dup_inc(sv, param); 13140 /* fall through */ 13141 case SAVEt_COMPPAD: 13142 case SAVEt_NSTAB: 13143 sv = (const SV *) POPPTR(ss,ix); 13144 TOPPTR(nss,ix) = sv_dup(sv, param); 13145 break; 13146 case SAVEt_INT: /* int reference */ 13147 ptr = POPPTR(ss,ix); 13148 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); 13149 intval = (int)POPINT(ss,ix); 13150 TOPINT(nss,ix) = intval; 13151 break; 13152 case SAVEt_LONG: /* long reference */ 13153 ptr = POPPTR(ss,ix); 13154 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); 13155 longval = (long)POPLONG(ss,ix); 13156 TOPLONG(nss,ix) = longval; 13157 break; 13158 case SAVEt_I32: /* I32 reference */ 13159 ptr = POPPTR(ss,ix); 13160 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); 13161 i = POPINT(ss,ix); 13162 TOPINT(nss,ix) = i; 13163 break; 13164 case SAVEt_IV: /* IV reference */ 13165 case SAVEt_STRLEN: /* STRLEN/size_t ref */ 13166 ptr = POPPTR(ss,ix); 13167 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); 13168 iv = POPIV(ss,ix); 13169 TOPIV(nss,ix) = iv; 13170 break; 13171 case SAVEt_HPTR: /* HV* reference */ 13172 case SAVEt_APTR: /* AV* reference */ 13173 case SAVEt_SPTR: /* SV* reference */ 13174 ptr = POPPTR(ss,ix); 13175 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); 13176 sv = (const SV *)POPPTR(ss,ix); 13177 TOPPTR(nss,ix) = sv_dup(sv, param); 13178 break; 13179 case SAVEt_VPTR: /* random* reference */ 13180 ptr = POPPTR(ss,ix); 13181 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); 13182 /* Fall through */ 13183 case SAVEt_INT_SMALL: 13184 case SAVEt_I32_SMALL: 13185 case SAVEt_I16: /* I16 reference */ 13186 case SAVEt_I8: /* I8 reference */ 13187 case SAVEt_BOOL: 13188 ptr = POPPTR(ss,ix); 13189 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); 13190 break; 13191 case SAVEt_GENERIC_PVREF: /* generic char* */ 13192 case SAVEt_PPTR: /* char* reference */ 13193 ptr = POPPTR(ss,ix); 13194 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); 13195 c = (char*)POPPTR(ss,ix); 13196 TOPPTR(nss,ix) = pv_dup(c); 13197 break; 13198 case SAVEt_GP: /* scalar reference */ 13199 gp = (GP*)POPPTR(ss,ix); 13200 TOPPTR(nss,ix) = gp = gp_dup(gp, param); 13201 (void)GpREFCNT_inc(gp); 13202 gv = (const GV *)POPPTR(ss,ix); 13203 TOPPTR(nss,ix) = gv_dup_inc(gv, param); 13204 break; 13205 case SAVEt_FREEOP: 13206 ptr = POPPTR(ss,ix); 13207 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) { 13208 /* these are assumed to be refcounted properly */ 13209 OP *o; 13210 switch (((OP*)ptr)->op_type) { 13211 case OP_LEAVESUB: 13212 case OP_LEAVESUBLV: 13213 case OP_LEAVEEVAL: 13214 case OP_LEAVE: 13215 case OP_SCOPE: 13216 case OP_LEAVEWRITE: 13217 TOPPTR(nss,ix) = ptr; 13218 o = (OP*)ptr; 13219 OP_REFCNT_LOCK; 13220 (void) OpREFCNT_inc(o); 13221 OP_REFCNT_UNLOCK; 13222 break; 13223 default: 13224 TOPPTR(nss,ix) = NULL; 13225 break; 13226 } 13227 } 13228 else 13229 TOPPTR(nss,ix) = NULL; 13230 break; 13231 case SAVEt_FREECOPHH: 13232 ptr = POPPTR(ss,ix); 13233 TOPPTR(nss,ix) = cophh_copy((COPHH *)ptr); 13234 break; 13235 case SAVEt_ADELETE: 13236 av = (const AV *)POPPTR(ss,ix); 13237 TOPPTR(nss,ix) = av_dup_inc(av, param); 13238 i = POPINT(ss,ix); 13239 TOPINT(nss,ix) = i; 13240 break; 13241 case SAVEt_DELETE: 13242 hv = (const HV *)POPPTR(ss,ix); 13243 TOPPTR(nss,ix) = hv_dup_inc(hv, param); 13244 i = POPINT(ss,ix); 13245 TOPINT(nss,ix) = i; 13246 /* Fall through */ 13247 case SAVEt_FREEPV: 13248 c = (char*)POPPTR(ss,ix); 13249 TOPPTR(nss,ix) = pv_dup_inc(c); 13250 break; 13251 case SAVEt_STACK_POS: /* Position on Perl stack */ 13252 i = POPINT(ss,ix); 13253 TOPINT(nss,ix) = i; 13254 break; 13255 case SAVEt_DESTRUCTOR: 13256 ptr = POPPTR(ss,ix); 13257 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */ 13258 dptr = POPDPTR(ss,ix); 13259 TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*), 13260 any_dup(FPTR2DPTR(void *, dptr), 13261 proto_perl)); 13262 break; 13263 case SAVEt_DESTRUCTOR_X: 13264 ptr = POPPTR(ss,ix); 13265 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */ 13266 dxptr = POPDXPTR(ss,ix); 13267 TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*), 13268 any_dup(FPTR2DPTR(void *, dxptr), 13269 proto_perl)); 13270 break; 13271 case SAVEt_REGCONTEXT: 13272 case SAVEt_ALLOC: 13273 ix -= uv >> SAVE_TIGHT_SHIFT; 13274 break; 13275 case SAVEt_AELEM: /* array element */ 13276 sv = (const SV *)POPPTR(ss,ix); 13277 TOPPTR(nss,ix) = SvREFCNT_inc(sv_dup_inc(sv, param)); 13278 i = POPINT(ss,ix); 13279 TOPINT(nss,ix) = i; 13280 av = (const AV *)POPPTR(ss,ix); 13281 TOPPTR(nss,ix) = av_dup_inc(av, param); 13282 break; 13283 case SAVEt_OP: 13284 ptr = POPPTR(ss,ix); 13285 TOPPTR(nss,ix) = ptr; 13286 break; 13287 case SAVEt_HINTS: 13288 ptr = POPPTR(ss,ix); 13289 ptr = cophh_copy((COPHH*)ptr); 13290 TOPPTR(nss,ix) = ptr; 13291 i = POPINT(ss,ix); 13292 TOPINT(nss,ix) = i; 13293 if (i & HINT_LOCALIZE_HH) { 13294 hv = (const HV *)POPPTR(ss,ix); 13295 TOPPTR(nss,ix) = hv_dup_inc(hv, param); 13296 } 13297 break; 13298 case SAVEt_PADSV_AND_MORTALIZE: 13299 longval = (long)POPLONG(ss,ix); 13300 TOPLONG(nss,ix) = longval; 13301 ptr = POPPTR(ss,ix); 13302 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); 13303 sv = (const SV *)POPPTR(ss,ix); 13304 TOPPTR(nss,ix) = sv_dup_inc(sv, param); 13305 break; 13306 case SAVEt_SET_SVFLAGS: 13307 i = POPINT(ss,ix); 13308 TOPINT(nss,ix) = i; 13309 i = POPINT(ss,ix); 13310 TOPINT(nss,ix) = i; 13311 sv = (const SV *)POPPTR(ss,ix); 13312 TOPPTR(nss,ix) = sv_dup(sv, param); 13313 break; 13314 case SAVEt_COMPILE_WARNINGS: 13315 ptr = POPPTR(ss,ix); 13316 TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr); 13317 break; 13318 case SAVEt_PARSER: 13319 ptr = POPPTR(ss,ix); 13320 TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param); 13321 break; 13322 default: 13323 Perl_croak(aTHX_ 13324 "panic: ss_dup inconsistency (%"IVdf")", (IV) type); 13325 } 13326 } 13327 13328 return nss; 13329 } 13330 13331 13332 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE 13333 * flag to the result. This is done for each stash before cloning starts, 13334 * so we know which stashes want their objects cloned */ 13335 13336 static void 13337 do_mark_cloneable_stash(pTHX_ SV *const sv) 13338 { 13339 const HEK * const hvname = HvNAME_HEK((const HV *)sv); 13340 if (hvname) { 13341 GV* const cloner = gv_fetchmethod_autoload(MUTABLE_HV(sv), "CLONE_SKIP", 0); 13342 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */ 13343 if (cloner && GvCV(cloner)) { 13344 dSP; 13345 UV status; 13346 13347 ENTER; 13348 SAVETMPS; 13349 PUSHMARK(SP); 13350 mXPUSHs(newSVhek(hvname)); 13351 PUTBACK; 13352 call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR); 13353 SPAGAIN; 13354 status = POPu; 13355 PUTBACK; 13356 FREETMPS; 13357 LEAVE; 13358 if (status) 13359 SvFLAGS(sv) &= ~SVphv_CLONEABLE; 13360 } 13361 } 13362 } 13363 13364 13365 13366 /* 13367 =for apidoc perl_clone 13368 13369 Create and return a new interpreter by cloning the current one. 13370 13371 perl_clone takes these flags as parameters: 13372 13373 CLONEf_COPY_STACKS - is used to, well, copy the stacks also, 13374 without it we only clone the data and zero the stacks, 13375 with it we copy the stacks and the new perl interpreter is 13376 ready to run at the exact same point as the previous one. 13377 The pseudo-fork code uses COPY_STACKS while the 13378 threads->create doesn't. 13379 13380 CLONEf_KEEP_PTR_TABLE - 13381 perl_clone keeps a ptr_table with the pointer of the old 13382 variable as a key and the new variable as a value, 13383 this allows it to check if something has been cloned and not 13384 clone it again but rather just use the value and increase the 13385 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill 13386 the ptr_table using the function 13387 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>, 13388 reason to keep it around is if you want to dup some of your own 13389 variable who are outside the graph perl scans, example of this 13390 code is in threads.xs create. 13391 13392 CLONEf_CLONE_HOST - 13393 This is a win32 thing, it is ignored on unix, it tells perls 13394 win32host code (which is c++) to clone itself, this is needed on 13395 win32 if you want to run two threads at the same time, 13396 if you just want to do some stuff in a separate perl interpreter 13397 and then throw it away and return to the original one, 13398 you don't need to do anything. 13399 13400 =cut 13401 */ 13402 13403 /* XXX the above needs expanding by someone who actually understands it ! */ 13404 EXTERN_C PerlInterpreter * 13405 perl_clone_host(PerlInterpreter* proto_perl, UV flags); 13406 13407 PerlInterpreter * 13408 perl_clone(PerlInterpreter *proto_perl, UV flags) 13409 { 13410 dVAR; 13411 #ifdef PERL_IMPLICIT_SYS 13412 13413 PERL_ARGS_ASSERT_PERL_CLONE; 13414 13415 /* perlhost.h so we need to call into it 13416 to clone the host, CPerlHost should have a c interface, sky */ 13417 13418 if (flags & CLONEf_CLONE_HOST) { 13419 return perl_clone_host(proto_perl,flags); 13420 } 13421 return perl_clone_using(proto_perl, flags, 13422 proto_perl->IMem, 13423 proto_perl->IMemShared, 13424 proto_perl->IMemParse, 13425 proto_perl->IEnv, 13426 proto_perl->IStdIO, 13427 proto_perl->ILIO, 13428 proto_perl->IDir, 13429 proto_perl->ISock, 13430 proto_perl->IProc); 13431 } 13432 13433 PerlInterpreter * 13434 perl_clone_using(PerlInterpreter *proto_perl, UV flags, 13435 struct IPerlMem* ipM, struct IPerlMem* ipMS, 13436 struct IPerlMem* ipMP, struct IPerlEnv* ipE, 13437 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO, 13438 struct IPerlDir* ipD, struct IPerlSock* ipS, 13439 struct IPerlProc* ipP) 13440 { 13441 /* XXX many of the string copies here can be optimized if they're 13442 * constants; they need to be allocated as common memory and just 13443 * their pointers copied. */ 13444 13445 IV i; 13446 CLONE_PARAMS clone_params; 13447 CLONE_PARAMS* const param = &clone_params; 13448 13449 PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); 13450 13451 PERL_ARGS_ASSERT_PERL_CLONE_USING; 13452 #else /* !PERL_IMPLICIT_SYS */ 13453 IV i; 13454 CLONE_PARAMS clone_params; 13455 CLONE_PARAMS* param = &clone_params; 13456 PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); 13457 13458 PERL_ARGS_ASSERT_PERL_CLONE; 13459 #endif /* PERL_IMPLICIT_SYS */ 13460 13461 /* for each stash, determine whether its objects should be cloned */ 13462 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK); 13463 PERL_SET_THX(my_perl); 13464 13465 #ifdef DEBUGGING 13466 PoisonNew(my_perl, 1, PerlInterpreter); 13467 PL_op = NULL; 13468 PL_curcop = NULL; 13469 PL_defstash = NULL; /* may be used by perl malloc() */ 13470 PL_markstack = 0; 13471 PL_scopestack = 0; 13472 PL_scopestack_name = 0; 13473 PL_savestack = 0; 13474 PL_savestack_ix = 0; 13475 PL_savestack_max = -1; 13476 PL_sig_pending = 0; 13477 PL_parser = NULL; 13478 Zero(&PL_debug_pad, 1, struct perl_debug_pad); 13479 # ifdef DEBUG_LEAKING_SCALARS 13480 PL_sv_serial = (((UV)my_perl >> 2) & 0xfff) * 1000000; 13481 # endif 13482 #else /* !DEBUGGING */ 13483 Zero(my_perl, 1, PerlInterpreter); 13484 #endif /* DEBUGGING */ 13485 13486 #ifdef PERL_IMPLICIT_SYS 13487 /* host pointers */ 13488 PL_Mem = ipM; 13489 PL_MemShared = ipMS; 13490 PL_MemParse = ipMP; 13491 PL_Env = ipE; 13492 PL_StdIO = ipStd; 13493 PL_LIO = ipLIO; 13494 PL_Dir = ipD; 13495 PL_Sock = ipS; 13496 PL_Proc = ipP; 13497 #endif /* PERL_IMPLICIT_SYS */ 13498 13499 13500 param->flags = flags; 13501 /* Nothing in the core code uses this, but we make it available to 13502 extensions (using mg_dup). */ 13503 param->proto_perl = proto_perl; 13504 /* Likely nothing will use this, but it is initialised to be consistent 13505 with Perl_clone_params_new(). */ 13506 param->new_perl = my_perl; 13507 param->unreferenced = NULL; 13508 13509 13510 INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl); 13511 13512 PL_body_arenas = NULL; 13513 Zero(&PL_body_roots, 1, PL_body_roots); 13514 13515 PL_sv_count = 0; 13516 PL_sv_root = NULL; 13517 PL_sv_arenaroot = NULL; 13518 13519 PL_debug = proto_perl->Idebug; 13520 13521 /* dbargs array probably holds garbage */ 13522 PL_dbargs = NULL; 13523 13524 PL_compiling = proto_perl->Icompiling; 13525 13526 /* pseudo environmental stuff */ 13527 PL_origargc = proto_perl->Iorigargc; 13528 PL_origargv = proto_perl->Iorigargv; 13529 13530 #ifndef NO_TAINT_SUPPORT 13531 /* Set tainting stuff before PerlIO_debug can possibly get called */ 13532 PL_tainting = proto_perl->Itainting; 13533 PL_taint_warn = proto_perl->Itaint_warn; 13534 #else 13535 PL_tainting = FALSE; 13536 PL_taint_warn = FALSE; 13537 #endif 13538 13539 PL_minus_c = proto_perl->Iminus_c; 13540 13541 PL_localpatches = proto_perl->Ilocalpatches; 13542 PL_splitstr = proto_perl->Isplitstr; 13543 PL_minus_n = proto_perl->Iminus_n; 13544 PL_minus_p = proto_perl->Iminus_p; 13545 PL_minus_l = proto_perl->Iminus_l; 13546 PL_minus_a = proto_perl->Iminus_a; 13547 PL_minus_E = proto_perl->Iminus_E; 13548 PL_minus_F = proto_perl->Iminus_F; 13549 PL_doswitches = proto_perl->Idoswitches; 13550 PL_dowarn = proto_perl->Idowarn; 13551 #ifdef PERL_SAWAMPERSAND 13552 PL_sawampersand = proto_perl->Isawampersand; 13553 #endif 13554 PL_unsafe = proto_perl->Iunsafe; 13555 PL_perldb = proto_perl->Iperldb; 13556 PL_perl_destruct_level = proto_perl->Iperl_destruct_level; 13557 PL_exit_flags = proto_perl->Iexit_flags; 13558 13559 /* XXX time(&PL_basetime) when asked for? */ 13560 PL_basetime = proto_perl->Ibasetime; 13561 13562 PL_maxsysfd = proto_perl->Imaxsysfd; 13563 PL_statusvalue = proto_perl->Istatusvalue; 13564 #ifdef VMS 13565 PL_statusvalue_vms = proto_perl->Istatusvalue_vms; 13566 #else 13567 PL_statusvalue_posix = proto_perl->Istatusvalue_posix; 13568 #endif 13569 13570 /* RE engine related */ 13571 PL_regmatch_slab = NULL; 13572 PL_reg_curpm = NULL; 13573 13574 PL_sub_generation = proto_perl->Isub_generation; 13575 13576 /* funky return mechanisms */ 13577 PL_forkprocess = proto_perl->Iforkprocess; 13578 13579 /* internal state */ 13580 PL_maxo = proto_perl->Imaxo; 13581 13582 PL_main_start = proto_perl->Imain_start; 13583 PL_eval_root = proto_perl->Ieval_root; 13584 PL_eval_start = proto_perl->Ieval_start; 13585 13586 PL_filemode = proto_perl->Ifilemode; 13587 PL_lastfd = proto_perl->Ilastfd; 13588 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */ 13589 PL_Argv = NULL; 13590 PL_Cmd = NULL; 13591 PL_gensym = proto_perl->Igensym; 13592 13593 PL_laststatval = proto_perl->Ilaststatval; 13594 PL_laststype = proto_perl->Ilaststype; 13595 PL_mess_sv = NULL; 13596 13597 PL_profiledata = NULL; 13598 13599 PL_generation = proto_perl->Igeneration; 13600 13601 PL_in_clean_objs = proto_perl->Iin_clean_objs; 13602 PL_in_clean_all = proto_perl->Iin_clean_all; 13603 13604 PL_delaymagic_uid = proto_perl->Idelaymagic_uid; 13605 PL_delaymagic_euid = proto_perl->Idelaymagic_euid; 13606 PL_delaymagic_gid = proto_perl->Idelaymagic_gid; 13607 PL_delaymagic_egid = proto_perl->Idelaymagic_egid; 13608 PL_nomemok = proto_perl->Inomemok; 13609 PL_an = proto_perl->Ian; 13610 PL_evalseq = proto_perl->Ievalseq; 13611 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */ 13612 PL_origalen = proto_perl->Iorigalen; 13613 13614 PL_sighandlerp = proto_perl->Isighandlerp; 13615 13616 PL_runops = proto_perl->Irunops; 13617 13618 PL_subline = proto_perl->Isubline; 13619 13620 #ifdef FCRYPT 13621 PL_cryptseen = proto_perl->Icryptseen; 13622 #endif 13623 13624 #ifdef USE_LOCALE_COLLATE 13625 PL_collation_ix = proto_perl->Icollation_ix; 13626 PL_collation_standard = proto_perl->Icollation_standard; 13627 PL_collxfrm_base = proto_perl->Icollxfrm_base; 13628 PL_collxfrm_mult = proto_perl->Icollxfrm_mult; 13629 #endif /* USE_LOCALE_COLLATE */ 13630 13631 #ifdef USE_LOCALE_NUMERIC 13632 PL_numeric_standard = proto_perl->Inumeric_standard; 13633 PL_numeric_local = proto_perl->Inumeric_local; 13634 #endif /* !USE_LOCALE_NUMERIC */ 13635 13636 /* Did the locale setup indicate UTF-8? */ 13637 PL_utf8locale = proto_perl->Iutf8locale; 13638 PL_in_utf8_CTYPE_locale = proto_perl->Iin_utf8_CTYPE_locale; 13639 /* Unicode features (see perlrun/-C) */ 13640 PL_unicode = proto_perl->Iunicode; 13641 13642 /* Pre-5.8 signals control */ 13643 PL_signals = proto_perl->Isignals; 13644 13645 /* times() ticks per second */ 13646 PL_clocktick = proto_perl->Iclocktick; 13647 13648 /* Recursion stopper for PerlIO_find_layer */ 13649 PL_in_load_module = proto_perl->Iin_load_module; 13650 13651 /* sort() routine */ 13652 PL_sort_RealCmp = proto_perl->Isort_RealCmp; 13653 13654 /* Not really needed/useful since the reenrant_retint is "volatile", 13655 * but do it for consistency's sake. */ 13656 PL_reentrant_retint = proto_perl->Ireentrant_retint; 13657 13658 /* Hooks to shared SVs and locks. */ 13659 PL_sharehook = proto_perl->Isharehook; 13660 PL_lockhook = proto_perl->Ilockhook; 13661 PL_unlockhook = proto_perl->Iunlockhook; 13662 PL_threadhook = proto_perl->Ithreadhook; 13663 PL_destroyhook = proto_perl->Idestroyhook; 13664 PL_signalhook = proto_perl->Isignalhook; 13665 13666 PL_globhook = proto_perl->Iglobhook; 13667 13668 /* swatch cache */ 13669 PL_last_swash_hv = NULL; /* reinits on demand */ 13670 PL_last_swash_klen = 0; 13671 PL_last_swash_key[0]= '\0'; 13672 PL_last_swash_tmps = (U8*)NULL; 13673 PL_last_swash_slen = 0; 13674 13675 PL_srand_called = proto_perl->Isrand_called; 13676 Copy(&(proto_perl->Irandom_state), &PL_random_state, 1, PL_RANDOM_STATE_TYPE); 13677 13678 if (flags & CLONEf_COPY_STACKS) { 13679 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */ 13680 PL_tmps_ix = proto_perl->Itmps_ix; 13681 PL_tmps_max = proto_perl->Itmps_max; 13682 PL_tmps_floor = proto_perl->Itmps_floor; 13683 13684 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix] 13685 * NOTE: unlike the others! */ 13686 PL_scopestack_ix = proto_perl->Iscopestack_ix; 13687 PL_scopestack_max = proto_perl->Iscopestack_max; 13688 13689 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix] 13690 * NOTE: unlike the others! */ 13691 PL_savestack_ix = proto_perl->Isavestack_ix; 13692 PL_savestack_max = proto_perl->Isavestack_max; 13693 } 13694 13695 PL_start_env = proto_perl->Istart_env; /* XXXXXX */ 13696 PL_top_env = &PL_start_env; 13697 13698 PL_op = proto_perl->Iop; 13699 13700 PL_Sv = NULL; 13701 PL_Xpv = (XPV*)NULL; 13702 my_perl->Ina = proto_perl->Ina; 13703 13704 PL_statbuf = proto_perl->Istatbuf; 13705 PL_statcache = proto_perl->Istatcache; 13706 13707 #ifndef NO_TAINT_SUPPORT 13708 PL_tainted = proto_perl->Itainted; 13709 #else 13710 PL_tainted = FALSE; 13711 #endif 13712 PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */ 13713 13714 PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */ 13715 13716 PL_restartjmpenv = proto_perl->Irestartjmpenv; 13717 PL_restartop = proto_perl->Irestartop; 13718 PL_in_eval = proto_perl->Iin_eval; 13719 PL_delaymagic = proto_perl->Idelaymagic; 13720 PL_phase = proto_perl->Iphase; 13721 PL_localizing = proto_perl->Ilocalizing; 13722 13723 PL_hv_fetch_ent_mh = NULL; 13724 PL_modcount = proto_perl->Imodcount; 13725 PL_lastgotoprobe = NULL; 13726 PL_dumpindent = proto_perl->Idumpindent; 13727 13728 PL_efloatbuf = NULL; /* reinits on demand */ 13729 PL_efloatsize = 0; /* reinits on demand */ 13730 13731 /* regex stuff */ 13732 13733 PL_colorset = 0; /* reinits PL_colors[] */ 13734 /*PL_colors[6] = {0,0,0,0,0,0};*/ 13735 13736 /* Pluggable optimizer */ 13737 PL_peepp = proto_perl->Ipeepp; 13738 PL_rpeepp = proto_perl->Irpeepp; 13739 /* op_free() hook */ 13740 PL_opfreehook = proto_perl->Iopfreehook; 13741 13742 #ifdef USE_REENTRANT_API 13743 /* XXX: things like -Dm will segfault here in perlio, but doing 13744 * PERL_SET_CONTEXT(proto_perl); 13745 * breaks too many other things 13746 */ 13747 Perl_reentrant_init(aTHX); 13748 #endif 13749 13750 /* create SV map for pointer relocation */ 13751 PL_ptr_table = ptr_table_new(); 13752 13753 /* initialize these special pointers as early as possible */ 13754 init_constants(); 13755 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef); 13756 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no); 13757 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes); 13758 13759 /* create (a non-shared!) shared string table */ 13760 PL_strtab = newHV(); 13761 HvSHAREKEYS_off(PL_strtab); 13762 hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab)); 13763 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab); 13764 13765 Zero(PL_sv_consts, SV_CONSTS_COUNT, SV*); 13766 13767 /* This PV will be free'd special way so must set it same way op.c does */ 13768 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file); 13769 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file); 13770 13771 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling); 13772 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings); 13773 CopHINTHASH_set(&PL_compiling, cophh_copy(CopHINTHASH_get(&PL_compiling))); 13774 PL_curcop = (COP*)any_dup(proto_perl->Icurcop, proto_perl); 13775 13776 param->stashes = newAV(); /* Setup array of objects to call clone on */ 13777 /* This makes no difference to the implementation, as it always pushes 13778 and shifts pointers to other SVs without changing their reference 13779 count, with the array becoming empty before it is freed. However, it 13780 makes it conceptually clear what is going on, and will avoid some 13781 work inside av.c, filling slots between AvFILL() and AvMAX() with 13782 &PL_sv_undef, and SvREFCNT_dec()ing those. */ 13783 AvREAL_off(param->stashes); 13784 13785 if (!(flags & CLONEf_COPY_STACKS)) { 13786 param->unreferenced = newAV(); 13787 } 13788 13789 #ifdef PERLIO_LAYERS 13790 /* Clone PerlIO tables as soon as we can handle general xx_dup() */ 13791 PerlIO_clone(aTHX_ proto_perl, param); 13792 #endif 13793 13794 PL_envgv = gv_dup_inc(proto_perl->Ienvgv, param); 13795 PL_incgv = gv_dup_inc(proto_perl->Iincgv, param); 13796 PL_hintgv = gv_dup_inc(proto_perl->Ihintgv, param); 13797 PL_origfilename = SAVEPV(proto_perl->Iorigfilename); 13798 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param); 13799 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param); 13800 13801 /* switches */ 13802 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param); 13803 PL_apiversion = sv_dup_inc(proto_perl->Iapiversion, param); 13804 PL_inplace = SAVEPV(proto_perl->Iinplace); 13805 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param); 13806 13807 /* magical thingies */ 13808 13809 PL_encoding = sv_dup(proto_perl->Iencoding, param); 13810 13811 sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */ 13812 sv_setpvs(PERL_DEBUG_PAD(1), ""); /* ext/re needs these */ 13813 sv_setpvs(PERL_DEBUG_PAD(2), ""); /* even without DEBUGGING. */ 13814 13815 13816 /* Clone the regex array */ 13817 /* ORANGE FIXME for plugins, probably in the SV dup code. 13818 newSViv(PTR2IV(CALLREGDUPE( 13819 INT2PTR(REGEXP *, SvIVX(regex)), param)))) 13820 */ 13821 PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param); 13822 PL_regex_pad = AvARRAY(PL_regex_padav); 13823 13824 PL_stashpadmax = proto_perl->Istashpadmax; 13825 PL_stashpadix = proto_perl->Istashpadix ; 13826 Newx(PL_stashpad, PL_stashpadmax, HV *); 13827 { 13828 PADOFFSET o = 0; 13829 for (; o < PL_stashpadmax; ++o) 13830 PL_stashpad[o] = hv_dup(proto_perl->Istashpad[o], param); 13831 } 13832 13833 /* shortcuts to various I/O objects */ 13834 PL_ofsgv = gv_dup_inc(proto_perl->Iofsgv, param); 13835 PL_stdingv = gv_dup(proto_perl->Istdingv, param); 13836 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param); 13837 PL_defgv = gv_dup(proto_perl->Idefgv, param); 13838 PL_argvgv = gv_dup_inc(proto_perl->Iargvgv, param); 13839 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param); 13840 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param); 13841 13842 /* shortcuts to regexp stuff */ 13843 PL_replgv = gv_dup_inc(proto_perl->Ireplgv, param); 13844 13845 /* shortcuts to misc objects */ 13846 PL_errgv = gv_dup(proto_perl->Ierrgv, param); 13847 13848 /* shortcuts to debugging objects */ 13849 PL_DBgv = gv_dup_inc(proto_perl->IDBgv, param); 13850 PL_DBline = gv_dup_inc(proto_perl->IDBline, param); 13851 PL_DBsub = gv_dup_inc(proto_perl->IDBsub, param); 13852 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param); 13853 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param); 13854 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param); 13855 13856 /* symbol tables */ 13857 PL_defstash = hv_dup_inc(proto_perl->Idefstash, param); 13858 PL_curstash = hv_dup_inc(proto_perl->Icurstash, param); 13859 PL_debstash = hv_dup(proto_perl->Idebstash, param); 13860 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param); 13861 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param); 13862 13863 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param); 13864 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param); 13865 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param); 13866 PL_unitcheckav = av_dup_inc(proto_perl->Iunitcheckav, param); 13867 PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param); 13868 PL_endav = av_dup_inc(proto_perl->Iendav, param); 13869 PL_checkav = av_dup_inc(proto_perl->Icheckav, param); 13870 PL_initav = av_dup_inc(proto_perl->Iinitav, param); 13871 13872 PL_isarev = hv_dup_inc(proto_perl->Iisarev, param); 13873 13874 /* subprocess state */ 13875 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param); 13876 13877 if (proto_perl->Iop_mask) 13878 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo); 13879 else 13880 PL_op_mask = NULL; 13881 /* PL_asserting = proto_perl->Iasserting; */ 13882 13883 /* current interpreter roots */ 13884 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param); 13885 OP_REFCNT_LOCK; 13886 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root); 13887 OP_REFCNT_UNLOCK; 13888 13889 /* runtime control stuff */ 13890 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl); 13891 13892 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param); 13893 13894 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param); 13895 13896 /* interpreter atexit processing */ 13897 PL_exitlistlen = proto_perl->Iexitlistlen; 13898 if (PL_exitlistlen) { 13899 Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry); 13900 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry); 13901 } 13902 else 13903 PL_exitlist = (PerlExitListEntry*)NULL; 13904 13905 PL_my_cxt_size = proto_perl->Imy_cxt_size; 13906 if (PL_my_cxt_size) { 13907 Newx(PL_my_cxt_list, PL_my_cxt_size, void *); 13908 Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *); 13909 #ifdef PERL_GLOBAL_STRUCT_PRIVATE 13910 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *); 13911 Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *); 13912 #endif 13913 } 13914 else { 13915 PL_my_cxt_list = (void**)NULL; 13916 #ifdef PERL_GLOBAL_STRUCT_PRIVATE 13917 PL_my_cxt_keys = (const char**)NULL; 13918 #endif 13919 } 13920 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param); 13921 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param); 13922 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param); 13923 PL_custom_ops = hv_dup_inc(proto_perl->Icustom_ops, param); 13924 13925 PL_compcv = cv_dup(proto_perl->Icompcv, param); 13926 13927 PAD_CLONE_VARS(proto_perl, param); 13928 13929 #ifdef HAVE_INTERP_INTERN 13930 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern); 13931 #endif 13932 13933 PL_DBcv = cv_dup(proto_perl->IDBcv, param); 13934 13935 #ifdef PERL_USES_PL_PIDSTATUS 13936 PL_pidstatus = newHV(); /* XXX flag for cloning? */ 13937 #endif 13938 PL_osname = SAVEPV(proto_perl->Iosname); 13939 PL_parser = parser_dup(proto_perl->Iparser, param); 13940 13941 /* XXX this only works if the saved cop has already been cloned */ 13942 if (proto_perl->Iparser) { 13943 PL_parser->saved_curcop = (COP*)any_dup( 13944 proto_perl->Iparser->saved_curcop, 13945 proto_perl); 13946 } 13947 13948 PL_subname = sv_dup_inc(proto_perl->Isubname, param); 13949 13950 #ifdef USE_LOCALE_COLLATE 13951 PL_collation_name = SAVEPV(proto_perl->Icollation_name); 13952 #endif /* USE_LOCALE_COLLATE */ 13953 13954 #ifdef USE_LOCALE_NUMERIC 13955 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name); 13956 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param); 13957 #endif /* !USE_LOCALE_NUMERIC */ 13958 13959 /* Unicode inversion lists */ 13960 PL_Latin1 = sv_dup_inc(proto_perl->ILatin1, param); 13961 PL_UpperLatin1 = sv_dup_inc(proto_perl->IUpperLatin1, param); 13962 PL_AboveLatin1 = sv_dup_inc(proto_perl->IAboveLatin1, param); 13963 13964 PL_NonL1NonFinalFold = sv_dup_inc(proto_perl->INonL1NonFinalFold, param); 13965 PL_HasMultiCharFold = sv_dup_inc(proto_perl->IHasMultiCharFold, param); 13966 13967 /* utf8 character class swashes */ 13968 for (i = 0; i < POSIX_SWASH_COUNT; i++) { 13969 PL_utf8_swash_ptrs[i] = sv_dup_inc(proto_perl->Iutf8_swash_ptrs[i], param); 13970 } 13971 for (i = 0; i < POSIX_CC_COUNT; i++) { 13972 PL_XPosix_ptrs[i] = sv_dup_inc(proto_perl->IXPosix_ptrs[i], param); 13973 } 13974 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param); 13975 PL_utf8_X_regular_begin = sv_dup_inc(proto_perl->Iutf8_X_regular_begin, param); 13976 PL_utf8_X_extend = sv_dup_inc(proto_perl->Iutf8_X_extend, param); 13977 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param); 13978 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param); 13979 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param); 13980 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param); 13981 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param); 13982 PL_utf8_xidstart = sv_dup_inc(proto_perl->Iutf8_xidstart, param); 13983 PL_utf8_perl_idstart = sv_dup_inc(proto_perl->Iutf8_perl_idstart, param); 13984 PL_utf8_perl_idcont = sv_dup_inc(proto_perl->Iutf8_perl_idcont, param); 13985 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param); 13986 PL_utf8_xidcont = sv_dup_inc(proto_perl->Iutf8_xidcont, param); 13987 PL_utf8_foldable = sv_dup_inc(proto_perl->Iutf8_foldable, param); 13988 PL_utf8_charname_begin = sv_dup_inc(proto_perl->Iutf8_charname_begin, param); 13989 PL_utf8_charname_continue = sv_dup_inc(proto_perl->Iutf8_charname_continue, param); 13990 13991 if (proto_perl->Ipsig_pend) { 13992 Newxz(PL_psig_pend, SIG_SIZE, int); 13993 } 13994 else { 13995 PL_psig_pend = (int*)NULL; 13996 } 13997 13998 if (proto_perl->Ipsig_name) { 13999 Newx(PL_psig_name, 2 * SIG_SIZE, SV*); 14000 sv_dup_inc_multiple(proto_perl->Ipsig_name, PL_psig_name, 2 * SIG_SIZE, 14001 param); 14002 PL_psig_ptr = PL_psig_name + SIG_SIZE; 14003 } 14004 else { 14005 PL_psig_ptr = (SV**)NULL; 14006 PL_psig_name = (SV**)NULL; 14007 } 14008 14009 if (flags & CLONEf_COPY_STACKS) { 14010 Newx(PL_tmps_stack, PL_tmps_max, SV*); 14011 sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack, 14012 PL_tmps_ix+1, param); 14013 14014 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */ 14015 i = proto_perl->Imarkstack_max - proto_perl->Imarkstack; 14016 Newxz(PL_markstack, i, I32); 14017 PL_markstack_max = PL_markstack + (proto_perl->Imarkstack_max 14018 - proto_perl->Imarkstack); 14019 PL_markstack_ptr = PL_markstack + (proto_perl->Imarkstack_ptr 14020 - proto_perl->Imarkstack); 14021 Copy(proto_perl->Imarkstack, PL_markstack, 14022 PL_markstack_ptr - PL_markstack + 1, I32); 14023 14024 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix] 14025 * NOTE: unlike the others! */ 14026 Newxz(PL_scopestack, PL_scopestack_max, I32); 14027 Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32); 14028 14029 #ifdef DEBUGGING 14030 Newxz(PL_scopestack_name, PL_scopestack_max, const char *); 14031 Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *); 14032 #endif 14033 /* reset stack AV to correct length before its duped via 14034 * PL_curstackinfo */ 14035 AvFILLp(proto_perl->Icurstack) = 14036 proto_perl->Istack_sp - proto_perl->Istack_base; 14037 14038 /* NOTE: si_dup() looks at PL_markstack */ 14039 PL_curstackinfo = si_dup(proto_perl->Icurstackinfo, param); 14040 14041 /* PL_curstack = PL_curstackinfo->si_stack; */ 14042 PL_curstack = av_dup(proto_perl->Icurstack, param); 14043 PL_mainstack = av_dup(proto_perl->Imainstack, param); 14044 14045 /* next PUSHs() etc. set *(PL_stack_sp+1) */ 14046 PL_stack_base = AvARRAY(PL_curstack); 14047 PL_stack_sp = PL_stack_base + (proto_perl->Istack_sp 14048 - proto_perl->Istack_base); 14049 PL_stack_max = PL_stack_base + AvMAX(PL_curstack); 14050 14051 /*Newxz(PL_savestack, PL_savestack_max, ANY);*/ 14052 PL_savestack = ss_dup(proto_perl, param); 14053 } 14054 else { 14055 init_stacks(); 14056 ENTER; /* perl_destruct() wants to LEAVE; */ 14057 } 14058 14059 PL_statgv = gv_dup(proto_perl->Istatgv, param); 14060 PL_statname = sv_dup_inc(proto_perl->Istatname, param); 14061 14062 PL_rs = sv_dup_inc(proto_perl->Irs, param); 14063 PL_last_in_gv = gv_dup(proto_perl->Ilast_in_gv, param); 14064 PL_defoutgv = gv_dup_inc(proto_perl->Idefoutgv, param); 14065 PL_toptarget = sv_dup_inc(proto_perl->Itoptarget, param); 14066 PL_bodytarget = sv_dup_inc(proto_perl->Ibodytarget, param); 14067 PL_formtarget = sv_dup(proto_perl->Iformtarget, param); 14068 14069 PL_errors = sv_dup_inc(proto_perl->Ierrors, param); 14070 14071 PL_sortcop = (OP*)any_dup(proto_perl->Isortcop, proto_perl); 14072 PL_firstgv = gv_dup_inc(proto_perl->Ifirstgv, param); 14073 PL_secondgv = gv_dup_inc(proto_perl->Isecondgv, param); 14074 14075 PL_stashcache = newHV(); 14076 14077 PL_watchaddr = (char **) ptr_table_fetch(PL_ptr_table, 14078 proto_perl->Iwatchaddr); 14079 PL_watchok = PL_watchaddr ? * PL_watchaddr : NULL; 14080 if (PL_debug && PL_watchaddr) { 14081 PerlIO_printf(Perl_debug_log, 14082 "WATCHING: %"UVxf" cloned as %"UVxf" with value %"UVxf"\n", 14083 PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr), 14084 PTR2UV(PL_watchok)); 14085 } 14086 14087 PL_registered_mros = hv_dup_inc(proto_perl->Iregistered_mros, param); 14088 PL_blockhooks = av_dup_inc(proto_perl->Iblockhooks, param); 14089 PL_utf8_foldclosures = hv_dup_inc(proto_perl->Iutf8_foldclosures, param); 14090 14091 /* Call the ->CLONE method, if it exists, for each of the stashes 14092 identified by sv_dup() above. 14093 */ 14094 while(av_tindex(param->stashes) != -1) { 14095 HV* const stash = MUTABLE_HV(av_shift(param->stashes)); 14096 GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0); 14097 if (cloner && GvCV(cloner)) { 14098 dSP; 14099 ENTER; 14100 SAVETMPS; 14101 PUSHMARK(SP); 14102 mXPUSHs(newSVhek(HvNAME_HEK(stash))); 14103 PUTBACK; 14104 call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD); 14105 FREETMPS; 14106 LEAVE; 14107 } 14108 } 14109 14110 if (!(flags & CLONEf_KEEP_PTR_TABLE)) { 14111 ptr_table_free(PL_ptr_table); 14112 PL_ptr_table = NULL; 14113 } 14114 14115 if (!(flags & CLONEf_COPY_STACKS)) { 14116 unreferenced_to_tmp_stack(param->unreferenced); 14117 } 14118 14119 SvREFCNT_dec(param->stashes); 14120 14121 /* orphaned? eg threads->new inside BEGIN or use */ 14122 if (PL_compcv && ! SvREFCNT(PL_compcv)) { 14123 SvREFCNT_inc_simple_void(PL_compcv); 14124 SAVEFREESV(PL_compcv); 14125 } 14126 14127 return my_perl; 14128 } 14129 14130 static void 14131 S_unreferenced_to_tmp_stack(pTHX_ AV *const unreferenced) 14132 { 14133 PERL_ARGS_ASSERT_UNREFERENCED_TO_TMP_STACK; 14134 14135 if (AvFILLp(unreferenced) > -1) { 14136 SV **svp = AvARRAY(unreferenced); 14137 SV **const last = svp + AvFILLp(unreferenced); 14138 SSize_t count = 0; 14139 14140 do { 14141 if (SvREFCNT(*svp) == 1) 14142 ++count; 14143 } while (++svp <= last); 14144 14145 EXTEND_MORTAL(count); 14146 svp = AvARRAY(unreferenced); 14147 14148 do { 14149 if (SvREFCNT(*svp) == 1) { 14150 /* Our reference is the only one to this SV. This means that 14151 in this thread, the scalar effectively has a 0 reference. 14152 That doesn't work (cleanup never happens), so donate our 14153 reference to it onto the save stack. */ 14154 PL_tmps_stack[++PL_tmps_ix] = *svp; 14155 } else { 14156 /* As an optimisation, because we are already walking the 14157 entire array, instead of above doing either 14158 SvREFCNT_inc(*svp) or *svp = &PL_sv_undef, we can instead 14159 release our reference to the scalar, so that at the end of 14160 the array owns zero references to the scalars it happens to 14161 point to. We are effectively converting the array from 14162 AvREAL() on to AvREAL() off. This saves the av_clear() 14163 (triggered by the SvREFCNT_dec(unreferenced) below) from 14164 walking the array a second time. */ 14165 SvREFCNT_dec(*svp); 14166 } 14167 14168 } while (++svp <= last); 14169 AvREAL_off(unreferenced); 14170 } 14171 SvREFCNT_dec_NN(unreferenced); 14172 } 14173 14174 void 14175 Perl_clone_params_del(CLONE_PARAMS *param) 14176 { 14177 /* This seemingly funky ordering keeps the build with PERL_GLOBAL_STRUCT 14178 happy: */ 14179 PerlInterpreter *const to = param->new_perl; 14180 dTHXa(to); 14181 PerlInterpreter *const was = PERL_GET_THX; 14182 14183 PERL_ARGS_ASSERT_CLONE_PARAMS_DEL; 14184 14185 if (was != to) { 14186 PERL_SET_THX(to); 14187 } 14188 14189 SvREFCNT_dec(param->stashes); 14190 if (param->unreferenced) 14191 unreferenced_to_tmp_stack(param->unreferenced); 14192 14193 Safefree(param); 14194 14195 if (was != to) { 14196 PERL_SET_THX(was); 14197 } 14198 } 14199 14200 CLONE_PARAMS * 14201 Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to) 14202 { 14203 dVAR; 14204 /* Need to play this game, as newAV() can call safesysmalloc(), and that 14205 does a dTHX; to get the context from thread local storage. 14206 FIXME - under PERL_CORE Newx(), Safefree() and friends should expand to 14207 a version that passes in my_perl. */ 14208 PerlInterpreter *const was = PERL_GET_THX; 14209 CLONE_PARAMS *param; 14210 14211 PERL_ARGS_ASSERT_CLONE_PARAMS_NEW; 14212 14213 if (was != to) { 14214 PERL_SET_THX(to); 14215 } 14216 14217 /* Given that we've set the context, we can do this unshared. */ 14218 Newx(param, 1, CLONE_PARAMS); 14219 14220 param->flags = 0; 14221 param->proto_perl = from; 14222 param->new_perl = to; 14223 param->stashes = (AV *)Perl_newSV_type(to, SVt_PVAV); 14224 AvREAL_off(param->stashes); 14225 param->unreferenced = (AV *)Perl_newSV_type(to, SVt_PVAV); 14226 14227 if (was != to) { 14228 PERL_SET_THX(was); 14229 } 14230 return param; 14231 } 14232 14233 #endif /* USE_ITHREADS */ 14234 14235 void 14236 Perl_init_constants(pTHX) 14237 { 14238 SvREFCNT(&PL_sv_undef) = SvREFCNT_IMMORTAL; 14239 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL; 14240 SvANY(&PL_sv_undef) = NULL; 14241 14242 SvANY(&PL_sv_no) = new_XPVNV(); 14243 SvREFCNT(&PL_sv_no) = SvREFCNT_IMMORTAL; 14244 SvFLAGS(&PL_sv_no) = SVt_PVNV|SVf_READONLY 14245 |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK 14246 |SVp_POK|SVf_POK; 14247 14248 SvANY(&PL_sv_yes) = new_XPVNV(); 14249 SvREFCNT(&PL_sv_yes) = SvREFCNT_IMMORTAL; 14250 SvFLAGS(&PL_sv_yes) = SVt_PVNV|SVf_READONLY 14251 |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK 14252 |SVp_POK|SVf_POK; 14253 14254 SvPV_set(&PL_sv_no, (char*)PL_No); 14255 SvCUR_set(&PL_sv_no, 0); 14256 SvLEN_set(&PL_sv_no, 0); 14257 SvIV_set(&PL_sv_no, 0); 14258 SvNV_set(&PL_sv_no, 0); 14259 14260 SvPV_set(&PL_sv_yes, (char*)PL_Yes); 14261 SvCUR_set(&PL_sv_yes, 1); 14262 SvLEN_set(&PL_sv_yes, 0); 14263 SvIV_set(&PL_sv_yes, 1); 14264 SvNV_set(&PL_sv_yes, 1); 14265 } 14266 14267 /* 14268 =head1 Unicode Support 14269 14270 =for apidoc sv_recode_to_utf8 14271 14272 The encoding is assumed to be an Encode object, on entry the PV 14273 of the sv is assumed to be octets in that encoding, and the sv 14274 will be converted into Unicode (and UTF-8). 14275 14276 If the sv already is UTF-8 (or if it is not POK), or if the encoding 14277 is not a reference, nothing is done to the sv. If the encoding is not 14278 an C<Encode::XS> Encoding object, bad things will happen. 14279 (See F<lib/encoding.pm> and L<Encode>.) 14280 14281 The PV of the sv is returned. 14282 14283 =cut */ 14284 14285 char * 14286 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) 14287 { 14288 dVAR; 14289 14290 PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8; 14291 14292 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) { 14293 SV *uni; 14294 STRLEN len; 14295 const char *s; 14296 dSP; 14297 SV *nsv = sv; 14298 ENTER; 14299 PUSHSTACK; 14300 SAVETMPS; 14301 if (SvPADTMP(nsv)) { 14302 nsv = sv_newmortal(); 14303 SvSetSV_nosteal(nsv, sv); 14304 } 14305 save_re_context(); 14306 PUSHMARK(sp); 14307 EXTEND(SP, 3); 14308 PUSHs(encoding); 14309 PUSHs(nsv); 14310 /* 14311 NI-S 2002/07/09 14312 Passing sv_yes is wrong - it needs to be or'ed set of constants 14313 for Encode::XS, while UTf-8 decode (currently) assumes a true value means 14314 remove converted chars from source. 14315 14316 Both will default the value - let them. 14317 14318 XPUSHs(&PL_sv_yes); 14319 */ 14320 PUTBACK; 14321 call_method("decode", G_SCALAR); 14322 SPAGAIN; 14323 uni = POPs; 14324 PUTBACK; 14325 s = SvPV_const(uni, len); 14326 if (s != SvPVX_const(sv)) { 14327 SvGROW(sv, len + 1); 14328 Move(s, SvPVX(sv), len + 1, char); 14329 SvCUR_set(sv, len); 14330 } 14331 FREETMPS; 14332 POPSTACK; 14333 LEAVE; 14334 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { 14335 /* clear pos and any utf8 cache */ 14336 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global); 14337 if (mg) 14338 mg->mg_len = -1; 14339 if ((mg = mg_find(sv, PERL_MAGIC_utf8))) 14340 magic_setutf8(sv,mg); /* clear UTF8 cache */ 14341 } 14342 SvUTF8_on(sv); 14343 return SvPVX(sv); 14344 } 14345 return SvPOKp(sv) ? SvPVX(sv) : NULL; 14346 } 14347 14348 /* 14349 =for apidoc sv_cat_decode 14350 14351 The encoding is assumed to be an Encode object, the PV of the ssv is 14352 assumed to be octets in that encoding and decoding the input starts 14353 from the position which (PV + *offset) pointed to. The dsv will be 14354 concatenated the decoded UTF-8 string from ssv. Decoding will terminate 14355 when the string tstr appears in decoding output or the input ends on 14356 the PV of the ssv. The value which the offset points will be modified 14357 to the last input position on the ssv. 14358 14359 Returns TRUE if the terminator was found, else returns FALSE. 14360 14361 =cut */ 14362 14363 bool 14364 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding, 14365 SV *ssv, int *offset, char *tstr, int tlen) 14366 { 14367 dVAR; 14368 bool ret = FALSE; 14369 14370 PERL_ARGS_ASSERT_SV_CAT_DECODE; 14371 14372 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) { 14373 SV *offsv; 14374 dSP; 14375 ENTER; 14376 SAVETMPS; 14377 save_re_context(); 14378 PUSHMARK(sp); 14379 EXTEND(SP, 6); 14380 PUSHs(encoding); 14381 PUSHs(dsv); 14382 PUSHs(ssv); 14383 offsv = newSViv(*offset); 14384 mPUSHs(offsv); 14385 mPUSHp(tstr, tlen); 14386 PUTBACK; 14387 call_method("cat_decode", G_SCALAR); 14388 SPAGAIN; 14389 ret = SvTRUE(TOPs); 14390 *offset = SvIV(offsv); 14391 PUTBACK; 14392 FREETMPS; 14393 LEAVE; 14394 } 14395 else 14396 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode"); 14397 return ret; 14398 14399 } 14400 14401 /* --------------------------------------------------------------------- 14402 * 14403 * support functions for report_uninit() 14404 */ 14405 14406 /* the maxiumum size of array or hash where we will scan looking 14407 * for the undefined element that triggered the warning */ 14408 14409 #define FUV_MAX_SEARCH_SIZE 1000 14410 14411 /* Look for an entry in the hash whose value has the same SV as val; 14412 * If so, return a mortal copy of the key. */ 14413 14414 STATIC SV* 14415 S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val) 14416 { 14417 dVAR; 14418 HE **array; 14419 I32 i; 14420 14421 PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT; 14422 14423 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) || 14424 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE)) 14425 return NULL; 14426 14427 array = HvARRAY(hv); 14428 14429 for (i=HvMAX(hv); i>=0; i--) { 14430 HE *entry; 14431 for (entry = array[i]; entry; entry = HeNEXT(entry)) { 14432 if (HeVAL(entry) != val) 14433 continue; 14434 if ( HeVAL(entry) == &PL_sv_undef || 14435 HeVAL(entry) == &PL_sv_placeholder) 14436 continue; 14437 if (!HeKEY(entry)) 14438 return NULL; 14439 if (HeKLEN(entry) == HEf_SVKEY) 14440 return sv_mortalcopy(HeKEY_sv(entry)); 14441 return sv_2mortal(newSVhek(HeKEY_hek(entry))); 14442 } 14443 } 14444 return NULL; 14445 } 14446 14447 /* Look for an entry in the array whose value has the same SV as val; 14448 * If so, return the index, otherwise return -1. */ 14449 14450 STATIC I32 14451 S_find_array_subscript(pTHX_ const AV *const av, const SV *const val) 14452 { 14453 dVAR; 14454 14455 PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT; 14456 14457 if (!av || SvMAGICAL(av) || !AvARRAY(av) || 14458 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE)) 14459 return -1; 14460 14461 if (val != &PL_sv_undef) { 14462 SV ** const svp = AvARRAY(av); 14463 I32 i; 14464 14465 for (i=AvFILLp(av); i>=0; i--) 14466 if (svp[i] == val) 14467 return i; 14468 } 14469 return -1; 14470 } 14471 14472 /* varname(): return the name of a variable, optionally with a subscript. 14473 * If gv is non-zero, use the name of that global, along with gvtype (one 14474 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset 14475 * targ. Depending on the value of the subscript_type flag, return: 14476 */ 14477 14478 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */ 14479 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */ 14480 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */ 14481 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */ 14482 14483 SV* 14484 Perl_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ, 14485 const SV *const keyname, I32 aindex, int subscript_type) 14486 { 14487 14488 SV * const name = sv_newmortal(); 14489 if (gv && isGV(gv)) { 14490 char buffer[2]; 14491 buffer[0] = gvtype; 14492 buffer[1] = 0; 14493 14494 /* as gv_fullname4(), but add literal '^' for $^FOO names */ 14495 14496 gv_fullname4(name, gv, buffer, 0); 14497 14498 if ((unsigned int)SvPVX(name)[1] <= 26) { 14499 buffer[0] = '^'; 14500 buffer[1] = SvPVX(name)[1] + 'A' - 1; 14501 14502 /* Swap the 1 unprintable control character for the 2 byte pretty 14503 version - ie substr($name, 1, 1) = $buffer; */ 14504 sv_insert(name, 1, 1, buffer, 2); 14505 } 14506 } 14507 else { 14508 CV * const cv = gv ? ((CV *)gv) : find_runcv(NULL); 14509 SV *sv; 14510 AV *av; 14511 14512 assert(!cv || SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); 14513 14514 if (!cv || !CvPADLIST(cv)) 14515 return NULL; 14516 av = *PadlistARRAY(CvPADLIST(cv)); 14517 sv = *av_fetch(av, targ, FALSE); 14518 sv_setsv_flags(name, sv, 0); 14519 } 14520 14521 if (subscript_type == FUV_SUBSCRIPT_HASH) { 14522 SV * const sv = newSV(0); 14523 *SvPVX(name) = '$'; 14524 Perl_sv_catpvf(aTHX_ name, "{%s}", 14525 pv_pretty(sv, SvPVX_const(keyname), SvCUR(keyname), 32, NULL, NULL, 14526 PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_UNI_DETECT )); 14527 SvREFCNT_dec_NN(sv); 14528 } 14529 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) { 14530 *SvPVX(name) = '$'; 14531 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex); 14532 } 14533 else if (subscript_type == FUV_SUBSCRIPT_WITHIN) { 14534 /* We know that name has no magic, so can use 0 instead of SV_GMAGIC */ 14535 Perl_sv_insert_flags(aTHX_ name, 0, 0, STR_WITH_LEN("within "), 0); 14536 } 14537 14538 return name; 14539 } 14540 14541 14542 /* 14543 =for apidoc find_uninit_var 14544 14545 Find the name of the undefined variable (if any) that caused the operator 14546 to issue a "Use of uninitialized value" warning. 14547 If match is true, only return a name if its value matches uninit_sv. 14548 So roughly speaking, if a unary operator (such as OP_COS) generates a 14549 warning, then following the direct child of the op may yield an 14550 OP_PADSV or OP_GV that gives the name of the undefined variable. On the 14551 other hand, with OP_ADD there are two branches to follow, so we only print 14552 the variable name if we get an exact match. 14553 14554 The name is returned as a mortal SV. 14555 14556 Assumes that PL_op is the op that originally triggered the error, and that 14557 PL_comppad/PL_curpad points to the currently executing pad. 14558 14559 =cut 14560 */ 14561 14562 STATIC SV * 14563 S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, 14564 bool match) 14565 { 14566 dVAR; 14567 SV *sv; 14568 const GV *gv; 14569 const OP *o, *o2, *kid; 14570 14571 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef || 14572 uninit_sv == &PL_sv_placeholder))) 14573 return NULL; 14574 14575 switch (obase->op_type) { 14576 14577 case OP_RV2AV: 14578 case OP_RV2HV: 14579 case OP_PADAV: 14580 case OP_PADHV: 14581 { 14582 const bool pad = ( obase->op_type == OP_PADAV 14583 || obase->op_type == OP_PADHV 14584 || obase->op_type == OP_PADRANGE 14585 ); 14586 14587 const bool hash = ( obase->op_type == OP_PADHV 14588 || obase->op_type == OP_RV2HV 14589 || (obase->op_type == OP_PADRANGE 14590 && SvTYPE(PAD_SVl(obase->op_targ)) == SVt_PVHV) 14591 ); 14592 I32 index = 0; 14593 SV *keysv = NULL; 14594 int subscript_type = FUV_SUBSCRIPT_WITHIN; 14595 14596 if (pad) { /* @lex, %lex */ 14597 sv = PAD_SVl(obase->op_targ); 14598 gv = NULL; 14599 } 14600 else { 14601 if (cUNOPx(obase)->op_first->op_type == OP_GV) { 14602 /* @global, %global */ 14603 gv = cGVOPx_gv(cUNOPx(obase)->op_first); 14604 if (!gv) 14605 break; 14606 sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv)); 14607 } 14608 else if (obase == PL_op) /* @{expr}, %{expr} */ 14609 return find_uninit_var(cUNOPx(obase)->op_first, 14610 uninit_sv, match); 14611 else /* @{expr}, %{expr} as a sub-expression */ 14612 return NULL; 14613 } 14614 14615 /* attempt to find a match within the aggregate */ 14616 if (hash) { 14617 keysv = find_hash_subscript((const HV*)sv, uninit_sv); 14618 if (keysv) 14619 subscript_type = FUV_SUBSCRIPT_HASH; 14620 } 14621 else { 14622 index = find_array_subscript((const AV *)sv, uninit_sv); 14623 if (index >= 0) 14624 subscript_type = FUV_SUBSCRIPT_ARRAY; 14625 } 14626 14627 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN) 14628 break; 14629 14630 return varname(gv, hash ? '%' : '@', obase->op_targ, 14631 keysv, index, subscript_type); 14632 } 14633 14634 case OP_RV2SV: 14635 if (cUNOPx(obase)->op_first->op_type == OP_GV) { 14636 /* $global */ 14637 gv = cGVOPx_gv(cUNOPx(obase)->op_first); 14638 if (!gv || !GvSTASH(gv)) 14639 break; 14640 if (match && (GvSV(gv) != uninit_sv)) 14641 break; 14642 return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE); 14643 } 14644 /* ${expr} */ 14645 return find_uninit_var(cUNOPx(obase)->op_first, uninit_sv, 1); 14646 14647 case OP_PADSV: 14648 if (match && PAD_SVl(obase->op_targ) != uninit_sv) 14649 break; 14650 return varname(NULL, '$', obase->op_targ, 14651 NULL, 0, FUV_SUBSCRIPT_NONE); 14652 14653 case OP_GVSV: 14654 gv = cGVOPx_gv(obase); 14655 if (!gv || (match && GvSV(gv) != uninit_sv) || !GvSTASH(gv)) 14656 break; 14657 return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE); 14658 14659 case OP_AELEMFAST_LEX: 14660 if (match) { 14661 SV **svp; 14662 AV *av = MUTABLE_AV(PAD_SV(obase->op_targ)); 14663 if (!av || SvRMAGICAL(av)) 14664 break; 14665 svp = av_fetch(av, (I8)obase->op_private, FALSE); 14666 if (!svp || *svp != uninit_sv) 14667 break; 14668 } 14669 return varname(NULL, '$', obase->op_targ, 14670 NULL, (I8)obase->op_private, FUV_SUBSCRIPT_ARRAY); 14671 case OP_AELEMFAST: 14672 { 14673 gv = cGVOPx_gv(obase); 14674 if (!gv) 14675 break; 14676 if (match) { 14677 SV **svp; 14678 AV *const av = GvAV(gv); 14679 if (!av || SvRMAGICAL(av)) 14680 break; 14681 svp = av_fetch(av, (I8)obase->op_private, FALSE); 14682 if (!svp || *svp != uninit_sv) 14683 break; 14684 } 14685 return varname(gv, '$', 0, 14686 NULL, (I8)obase->op_private, FUV_SUBSCRIPT_ARRAY); 14687 } 14688 break; 14689 14690 case OP_EXISTS: 14691 o = cUNOPx(obase)->op_first; 14692 if (!o || o->op_type != OP_NULL || 14693 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM)) 14694 break; 14695 return find_uninit_var(cBINOPo->op_last, uninit_sv, match); 14696 14697 case OP_AELEM: 14698 case OP_HELEM: 14699 { 14700 bool negate = FALSE; 14701 14702 if (PL_op == obase) 14703 /* $a[uninit_expr] or $h{uninit_expr} */ 14704 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match); 14705 14706 gv = NULL; 14707 o = cBINOPx(obase)->op_first; 14708 kid = cBINOPx(obase)->op_last; 14709 14710 /* get the av or hv, and optionally the gv */ 14711 sv = NULL; 14712 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) { 14713 sv = PAD_SV(o->op_targ); 14714 } 14715 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) 14716 && cUNOPo->op_first->op_type == OP_GV) 14717 { 14718 gv = cGVOPx_gv(cUNOPo->op_first); 14719 if (!gv) 14720 break; 14721 sv = o->op_type 14722 == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(GvAV(gv)); 14723 } 14724 if (!sv) 14725 break; 14726 14727 if (kid && kid->op_type == OP_NEGATE) { 14728 negate = TRUE; 14729 kid = cUNOPx(kid)->op_first; 14730 } 14731 14732 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) { 14733 /* index is constant */ 14734 SV* kidsv; 14735 if (negate) { 14736 kidsv = sv_2mortal(newSVpvs("-")); 14737 sv_catsv(kidsv, cSVOPx_sv(kid)); 14738 } 14739 else 14740 kidsv = cSVOPx_sv(kid); 14741 if (match) { 14742 if (SvMAGICAL(sv)) 14743 break; 14744 if (obase->op_type == OP_HELEM) { 14745 HE* he = hv_fetch_ent(MUTABLE_HV(sv), kidsv, 0, 0); 14746 if (!he || HeVAL(he) != uninit_sv) 14747 break; 14748 } 14749 else { 14750 SV * const opsv = cSVOPx_sv(kid); 14751 const IV opsviv = SvIV(opsv); 14752 SV * const * const svp = av_fetch(MUTABLE_AV(sv), 14753 negate ? - opsviv : opsviv, 14754 FALSE); 14755 if (!svp || *svp != uninit_sv) 14756 break; 14757 } 14758 } 14759 if (obase->op_type == OP_HELEM) 14760 return varname(gv, '%', o->op_targ, 14761 kidsv, 0, FUV_SUBSCRIPT_HASH); 14762 else 14763 return varname(gv, '@', o->op_targ, NULL, 14764 negate ? - SvIV(cSVOPx_sv(kid)) : SvIV(cSVOPx_sv(kid)), 14765 FUV_SUBSCRIPT_ARRAY); 14766 } 14767 else { 14768 /* index is an expression; 14769 * attempt to find a match within the aggregate */ 14770 if (obase->op_type == OP_HELEM) { 14771 SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv); 14772 if (keysv) 14773 return varname(gv, '%', o->op_targ, 14774 keysv, 0, FUV_SUBSCRIPT_HASH); 14775 } 14776 else { 14777 const I32 index 14778 = find_array_subscript((const AV *)sv, uninit_sv); 14779 if (index >= 0) 14780 return varname(gv, '@', o->op_targ, 14781 NULL, index, FUV_SUBSCRIPT_ARRAY); 14782 } 14783 if (match) 14784 break; 14785 return varname(gv, 14786 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) 14787 ? '@' : '%', 14788 o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN); 14789 } 14790 break; 14791 } 14792 14793 case OP_AASSIGN: 14794 /* only examine RHS */ 14795 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match); 14796 14797 case OP_OPEN: 14798 o = cUNOPx(obase)->op_first; 14799 if ( o->op_type == OP_PUSHMARK 14800 || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK) 14801 ) 14802 o = o->op_sibling; 14803 14804 if (!o->op_sibling) { 14805 /* one-arg version of open is highly magical */ 14806 14807 if (o->op_type == OP_GV) { /* open FOO; */ 14808 gv = cGVOPx_gv(o); 14809 if (match && GvSV(gv) != uninit_sv) 14810 break; 14811 return varname(gv, '$', 0, 14812 NULL, 0, FUV_SUBSCRIPT_NONE); 14813 } 14814 /* other possibilities not handled are: 14815 * open $x; or open my $x; should return '${*$x}' 14816 * open expr; should return '$'.expr ideally 14817 */ 14818 break; 14819 } 14820 goto do_op; 14821 14822 /* ops where $_ may be an implicit arg */ 14823 case OP_TRANS: 14824 case OP_TRANSR: 14825 case OP_SUBST: 14826 case OP_MATCH: 14827 if ( !(obase->op_flags & OPf_STACKED)) { 14828 if (uninit_sv == ((obase->op_private & OPpTARGET_MY) 14829 ? PAD_SVl(obase->op_targ) 14830 : DEFSV)) 14831 { 14832 sv = sv_newmortal(); 14833 sv_setpvs(sv, "$_"); 14834 return sv; 14835 } 14836 } 14837 goto do_op; 14838 14839 case OP_PRTF: 14840 case OP_PRINT: 14841 case OP_SAY: 14842 match = 1; /* print etc can return undef on defined args */ 14843 /* skip filehandle as it can't produce 'undef' warning */ 14844 o = cUNOPx(obase)->op_first; 14845 if ((obase->op_flags & OPf_STACKED) 14846 && 14847 ( o->op_type == OP_PUSHMARK 14848 || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK))) 14849 o = o->op_sibling->op_sibling; 14850 goto do_op2; 14851 14852 14853 case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */ 14854 case OP_CUSTOM: /* XS or custom code could trigger random warnings */ 14855 14856 /* the following ops are capable of returning PL_sv_undef even for 14857 * defined arg(s) */ 14858 14859 case OP_BACKTICK: 14860 case OP_PIPE_OP: 14861 case OP_FILENO: 14862 case OP_BINMODE: 14863 case OP_TIED: 14864 case OP_GETC: 14865 case OP_SYSREAD: 14866 case OP_SEND: 14867 case OP_IOCTL: 14868 case OP_SOCKET: 14869 case OP_SOCKPAIR: 14870 case OP_BIND: 14871 case OP_CONNECT: 14872 case OP_LISTEN: 14873 case OP_ACCEPT: 14874 case OP_SHUTDOWN: 14875 case OP_SSOCKOPT: 14876 case OP_GETPEERNAME: 14877 case OP_FTRREAD: 14878 case OP_FTRWRITE: 14879 case OP_FTREXEC: 14880 case OP_FTROWNED: 14881 case OP_FTEREAD: 14882 case OP_FTEWRITE: 14883 case OP_FTEEXEC: 14884 case OP_FTEOWNED: 14885 case OP_FTIS: 14886 case OP_FTZERO: 14887 case OP_FTSIZE: 14888 case OP_FTFILE: 14889 case OP_FTDIR: 14890 case OP_FTLINK: 14891 case OP_FTPIPE: 14892 case OP_FTSOCK: 14893 case OP_FTBLK: 14894 case OP_FTCHR: 14895 case OP_FTTTY: 14896 case OP_FTSUID: 14897 case OP_FTSGID: 14898 case OP_FTSVTX: 14899 case OP_FTTEXT: 14900 case OP_FTBINARY: 14901 case OP_FTMTIME: 14902 case OP_FTATIME: 14903 case OP_FTCTIME: 14904 case OP_READLINK: 14905 case OP_OPEN_DIR: 14906 case OP_READDIR: 14907 case OP_TELLDIR: 14908 case OP_SEEKDIR: 14909 case OP_REWINDDIR: 14910 case OP_CLOSEDIR: 14911 case OP_GMTIME: 14912 case OP_ALARM: 14913 case OP_SEMGET: 14914 case OP_GETLOGIN: 14915 case OP_UNDEF: 14916 case OP_SUBSTR: 14917 case OP_AEACH: 14918 case OP_EACH: 14919 case OP_SORT: 14920 case OP_CALLER: 14921 case OP_DOFILE: 14922 case OP_PROTOTYPE: 14923 case OP_NCMP: 14924 case OP_SMARTMATCH: 14925 case OP_UNPACK: 14926 case OP_SYSOPEN: 14927 case OP_SYSSEEK: 14928 match = 1; 14929 goto do_op; 14930 14931 case OP_ENTERSUB: 14932 case OP_GOTO: 14933 /* XXX tmp hack: these two may call an XS sub, and currently 14934 XS subs don't have a SUB entry on the context stack, so CV and 14935 pad determination goes wrong, and BAD things happen. So, just 14936 don't try to determine the value under those circumstances. 14937 Need a better fix at dome point. DAPM 11/2007 */ 14938 break; 14939 14940 case OP_FLIP: 14941 case OP_FLOP: 14942 { 14943 GV * const gv = gv_fetchpvs(".", GV_NOTQUAL, SVt_PV); 14944 if (gv && GvSV(gv) == uninit_sv) 14945 return newSVpvs_flags("$.", SVs_TEMP); 14946 goto do_op; 14947 } 14948 14949 case OP_POS: 14950 /* def-ness of rval pos() is independent of the def-ness of its arg */ 14951 if ( !(obase->op_flags & OPf_MOD)) 14952 break; 14953 14954 case OP_SCHOMP: 14955 case OP_CHOMP: 14956 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs)) 14957 return newSVpvs_flags("${$/}", SVs_TEMP); 14958 /*FALLTHROUGH*/ 14959 14960 default: 14961 do_op: 14962 if (!(obase->op_flags & OPf_KIDS)) 14963 break; 14964 o = cUNOPx(obase)->op_first; 14965 14966 do_op2: 14967 if (!o) 14968 break; 14969 14970 /* This loop checks all the kid ops, skipping any that cannot pos- 14971 * sibly be responsible for the uninitialized value; i.e., defined 14972 * constants and ops that return nothing. If there is only one op 14973 * left that is not skipped, then we *know* it is responsible for 14974 * the uninitialized value. If there is more than one op left, we 14975 * have to look for an exact match in the while() loop below. 14976 * Note that we skip padrange, because the individual pad ops that 14977 * it replaced are still in the tree, so we work on them instead. 14978 */ 14979 o2 = NULL; 14980 for (kid=o; kid; kid = kid->op_sibling) { 14981 if (kid) { 14982 const OPCODE type = kid->op_type; 14983 if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid))) 14984 || (type == OP_NULL && ! (kid->op_flags & OPf_KIDS)) 14985 || (type == OP_PUSHMARK) 14986 || (type == OP_PADRANGE) 14987 ) 14988 continue; 14989 } 14990 if (o2) { /* more than one found */ 14991 o2 = NULL; 14992 break; 14993 } 14994 o2 = kid; 14995 } 14996 if (o2) 14997 return find_uninit_var(o2, uninit_sv, match); 14998 14999 /* scan all args */ 15000 while (o) { 15001 sv = find_uninit_var(o, uninit_sv, 1); 15002 if (sv) 15003 return sv; 15004 o = o->op_sibling; 15005 } 15006 break; 15007 } 15008 return NULL; 15009 } 15010 15011 15012 /* 15013 =for apidoc report_uninit 15014 15015 Print appropriate "Use of uninitialized variable" warning. 15016 15017 =cut 15018 */ 15019 15020 void 15021 Perl_report_uninit(pTHX_ const SV *uninit_sv) 15022 { 15023 dVAR; 15024 if (PL_op) { 15025 SV* varname = NULL; 15026 if (uninit_sv && PL_curpad) { 15027 varname = find_uninit_var(PL_op, uninit_sv,0); 15028 if (varname) 15029 sv_insert(varname, 0, 0, " ", 1); 15030 } 15031 /* PL_warn_uninit_sv is constant */ 15032 GCC_DIAG_IGNORE(-Wformat-nonliteral); 15033 /* diag_listed_as: Use of uninitialized value%s */ 15034 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit_sv, 15035 SVfARG(varname ? varname : &PL_sv_no), 15036 " in ", OP_DESC(PL_op)); 15037 GCC_DIAG_RESTORE; 15038 } 15039 else { 15040 /* PL_warn_uninit is constant */ 15041 GCC_DIAG_IGNORE(-Wformat-nonliteral); 15042 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit, 15043 "", "", ""); 15044 GCC_DIAG_RESTORE; 15045 } 15046 } 15047 15048 /* 15049 * Local variables: 15050 * c-indentation-style: bsd 15051 * c-basic-offset: 4 15052 * indent-tabs-mode: nil 15053 * End: 15054 * 15055 * ex: set ts=8 sts=4 sw=4 et: 15056 */ 15057