1 /* sv_inline.h 2 * 3 * Copyright (C) 2022 by Larry Wall and others 4 * 5 * You may distribute under the terms of either the GNU General Public 6 * License or the Artistic License, as specified in the README file. 7 * 8 */ 9 10 /* This file contains the newSV_type and newSV_type_mortal functions, as well as 11 * the various struct and macro definitions they require. In the main, these 12 * definitions were moved from sv.c, where many of them continue to also be used. 13 * (In Perl_more_bodies, Perl_sv_upgrade and Perl_sv_clear, for example.) Code 14 * comments associated with definitions and functions were also copied across 15 * verbatim. 16 * 17 * The rationale for having these as inline functions, rather than in sv.c, is 18 * that the target type is very often known at compile time, and therefore 19 * optimum code can be emitted by the compiler, rather than having all calls 20 * traverse the many branches of Perl_sv_upgrade at runtime. 21 */ 22 23 /* This definition came from perl.h*/ 24 25 /* The old value was hard coded at 1008. (4096-16) seems to be a bit faster, 26 at least on FreeBSD. YMMV, so experiment. */ 27 #ifndef PERL_ARENA_SIZE 28 #define PERL_ARENA_SIZE 4080 29 #endif 30 31 /* All other pre-existing definitions and functions that were moved into this 32 * file originally came from sv.c. */ 33 34 #ifdef PERL_POISON 35 # define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv) 36 # define SvARENA_CHAIN_SET(sv,val) (sv)->sv_u.svu_rv = MUTABLE_SV((val)) 37 /* Whilst I'd love to do this, it seems that things like to check on 38 unreferenced scalars 39 # define POISON_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV) 40 */ 41 # define POISON_SV_HEAD(sv) PoisonNew(&SvANY(sv), 1, void *), \ 42 PoisonNew(&SvREFCNT(sv), 1, U32) 43 #else 44 # define SvARENA_CHAIN(sv) SvANY(sv) 45 # define SvARENA_CHAIN_SET(sv,val) SvANY(sv) = (void *)(val) 46 # define POISON_SV_HEAD(sv) 47 #endif 48 49 #ifdef PERL_MEM_LOG 50 # define MEM_LOG_NEW_SV(sv, file, line, func) \ 51 Perl_mem_log_new_sv(sv, file, line, func) 52 # define MEM_LOG_DEL_SV(sv, file, line, func) \ 53 Perl_mem_log_del_sv(sv, file, line, func) 54 #else 55 # define MEM_LOG_NEW_SV(sv, file, line, func) NOOP 56 # define MEM_LOG_DEL_SV(sv, file, line, func) NOOP 57 #endif 58 59 #define uproot_SV(p) \ 60 STMT_START { \ 61 (p) = PL_sv_root; \ 62 PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p)); \ 63 ++PL_sv_count; \ 64 } STMT_END 65 66 /* Perl_more_sv lives in sv.c, we don't want to inline it. 67 * but the function declaration seems to be needed. */ 68 SV* Perl_more_sv(pTHX); 69 70 /* new_SV(): return a new, empty SV head */ 71 72 #ifdef DEBUG_LEAKING_SCALARS 73 /* provide a real function for a debugger to play with */ 74 STATIC SV* 75 S_new_SV(pTHX_ const char *file, int line, const char *func) 76 { 77 SV* sv; 78 79 if (PL_sv_root) 80 uproot_SV(sv); 81 else 82 sv = Perl_more_sv(aTHX); 83 SvANY(sv) = 0; 84 SvREFCNT(sv) = 1; 85 SvFLAGS(sv) = 0; 86 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0; 87 sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE 88 ? PL_parser->copline 89 : PL_curcop 90 ? CopLINE(PL_curcop) 91 : 0 92 ); 93 sv->sv_debug_inpad = 0; 94 sv->sv_debug_parent = NULL; 95 sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL; 96 97 sv->sv_debug_serial = PL_sv_serial++; 98 99 MEM_LOG_NEW_SV(sv, file, line, func); 100 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) new_SV (from %s:%d [%s])\n", 101 PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func)); 102 103 return sv; 104 } 105 # define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__) 106 107 #else 108 # define new_SV(p) \ 109 STMT_START { \ 110 if (PL_sv_root) \ 111 uproot_SV(p); \ 112 else \ 113 (p) = Perl_more_sv(aTHX); \ 114 SvANY(p) = 0; \ 115 SvREFCNT(p) = 1; \ 116 SvFLAGS(p) = 0; \ 117 MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__); \ 118 } STMT_END 119 #endif 120 121 122 typedef struct xpvhv_with_aux XPVHV_WITH_AUX; 123 124 struct body_details { 125 U8 body_size; /* Size to allocate */ 126 U8 copy; /* Size of structure to copy (may be shorter) */ 127 U8 offset; /* Size of unalloced ghost fields to first alloced field*/ 128 PERL_BITFIELD8 type : 5; /* We have space for a sanity check. */ 129 PERL_BITFIELD8 cant_upgrade : 1;/* Cannot upgrade this type */ 130 PERL_BITFIELD8 zero_nv : 1; /* zero the NV when upgrading from this */ 131 PERL_BITFIELD8 arena : 1; /* Allocated from an arena */ 132 U32 arena_size; /* Size of arena to allocate */ 133 }; 134 135 #define ALIGNED_TYPE_NAME(name) name##_aligned 136 #define ALIGNED_TYPE(name) \ 137 typedef union { \ 138 name align_me; \ 139 NV nv; \ 140 IV iv; \ 141 } ALIGNED_TYPE_NAME(name) 142 143 ALIGNED_TYPE(regexp); 144 ALIGNED_TYPE(XPVGV); 145 ALIGNED_TYPE(XPVLV); 146 ALIGNED_TYPE(XPVAV); 147 ALIGNED_TYPE(XPVHV); 148 ALIGNED_TYPE(XPVHV_WITH_AUX); 149 ALIGNED_TYPE(XPVCV); 150 ALIGNED_TYPE(XPVFM); 151 ALIGNED_TYPE(XPVIO); 152 ALIGNED_TYPE(XPVOBJ); 153 154 #define HADNV FALSE 155 #define NONV TRUE 156 157 158 #ifdef PURIFY 159 /* With -DPURFIY we allocate everything directly, and don't use arenas. 160 This seems a rather elegant way to simplify some of the code below. */ 161 #define HASARENA FALSE 162 #else 163 #define HASARENA TRUE 164 #endif 165 #define NOARENA FALSE 166 167 /* Size the arenas to exactly fit a given number of bodies. A count 168 of 0 fits the max number bodies into a PERL_ARENA_SIZE.block, 169 simplifying the default. If count > 0, the arena is sized to fit 170 only that many bodies, allowing arenas to be used for large, rare 171 bodies (XPVFM, XPVIO) without undue waste. The arena size is 172 limited by PERL_ARENA_SIZE, so we can safely oversize the 173 declarations. 174 */ 175 #define FIT_ARENA0(body_size) \ 176 ((size_t)(PERL_ARENA_SIZE / body_size) * body_size) 177 #define FIT_ARENAn(count,body_size) \ 178 ( count * body_size <= PERL_ARENA_SIZE) \ 179 ? count * body_size \ 180 : FIT_ARENA0 (body_size) 181 #define FIT_ARENA(count,body_size) \ 182 (U32)(count \ 183 ? FIT_ARENAn (count, body_size) \ 184 : FIT_ARENA0 (body_size)) 185 186 /* Calculate the length to copy. Specifically work out the length less any 187 final padding the compiler needed to add. See the comment in sv_upgrade 188 for why copying the padding proved to be a bug. */ 189 190 #define copy_length(type, last_member) \ 191 STRUCT_OFFSET(type, last_member) \ 192 + sizeof (((type*)SvANY((const SV *)0))->last_member) 193 194 static const struct body_details bodies_by_type[] = { 195 /* HEs use this offset for their arena. */ 196 { 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 }, 197 198 /* IVs are in the head, so the allocation size is 0. */ 199 { 0, 200 sizeof(IV), /* This is used to copy out the IV body. */ 201 STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV, 202 NOARENA /* IVS don't need an arena */, 0 203 }, 204 205 #if NVSIZE <= IVSIZE 206 { 0, sizeof(NV), 207 STRUCT_OFFSET(XPVNV, xnv_u), 208 SVt_NV, FALSE, HADNV, NOARENA, 0 }, 209 #else 210 { sizeof(NV), sizeof(NV), 211 STRUCT_OFFSET(XPVNV, xnv_u), 212 SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) }, 213 #endif 214 215 { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur), 216 copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur), 217 + STRUCT_OFFSET(XPV, xpv_cur), 218 SVt_PV, FALSE, NONV, HASARENA, 219 FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) }, 220 221 { sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur), 222 copy_length(XINVLIST, is_offset) - STRUCT_OFFSET(XPV, xpv_cur), 223 + STRUCT_OFFSET(XPV, xpv_cur), 224 SVt_INVLIST, TRUE, NONV, HASARENA, 225 FIT_ARENA(0, sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur)) }, 226 227 { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur), 228 copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur), 229 + STRUCT_OFFSET(XPV, xpv_cur), 230 SVt_PVIV, FALSE, NONV, HASARENA, 231 FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) }, 232 233 #if NVSIZE > 8 && PTRSIZE < 8 && MEM_ALIGNBYTES > 8 234 /* NV may need strict 16 byte alignment. 235 236 On 64-bit systems the NV ends up aligned despite the hack 237 avoiding allocation of xmg_stash and xmg_u, so only do this 238 for 32-bit systems. 239 */ 240 { sizeof(XPVNV), 241 sizeof(XPVNV), 242 0, 243 SVt_PVNV, FALSE, HADNV, HASARENA, 244 FIT_ARENA(0, sizeof(XPVNV)) }, 245 #else 246 { sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur), 247 copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur), 248 + STRUCT_OFFSET(XPV, xpv_cur), 249 SVt_PVNV, FALSE, HADNV, HASARENA, 250 FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) }, 251 #endif 252 { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV, 253 HASARENA, FIT_ARENA(0, sizeof(XPVMG)) }, 254 255 { sizeof(ALIGNED_TYPE_NAME(regexp)), 256 sizeof(regexp), 257 0, 258 SVt_REGEXP, TRUE, NONV, HASARENA, 259 FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(regexp))) 260 }, 261 262 { sizeof(ALIGNED_TYPE_NAME(XPVGV)), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV, 263 HASARENA, FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVGV))) }, 264 265 { sizeof(ALIGNED_TYPE_NAME(XPVLV)), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV, 266 HASARENA, FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVLV))) }, 267 268 { sizeof(ALIGNED_TYPE_NAME(XPVAV)), 269 copy_length(XPVAV, xav_alloc), 270 0, 271 SVt_PVAV, TRUE, NONV, HASARENA, 272 FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVAV))) }, 273 274 { sizeof(ALIGNED_TYPE_NAME(XPVHV)), 275 copy_length(XPVHV, xhv_max), 276 0, 277 SVt_PVHV, TRUE, NONV, HASARENA, 278 FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVHV))) }, 279 280 { sizeof(ALIGNED_TYPE_NAME(XPVCV)), 281 sizeof(XPVCV), 282 0, 283 SVt_PVCV, TRUE, NONV, HASARENA, 284 FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVCV))) }, 285 286 { sizeof(ALIGNED_TYPE_NAME(XPVFM)), 287 sizeof(XPVFM), 288 0, 289 SVt_PVFM, TRUE, NONV, NOARENA, 290 FIT_ARENA(20, sizeof(ALIGNED_TYPE_NAME(XPVFM))) }, 291 292 { sizeof(ALIGNED_TYPE_NAME(XPVIO)), 293 sizeof(XPVIO), 294 0, 295 SVt_PVIO, TRUE, NONV, HASARENA, 296 FIT_ARENA(24, sizeof(ALIGNED_TYPE_NAME(XPVIO))) }, 297 298 { sizeof(ALIGNED_TYPE_NAME(XPVOBJ)), 299 copy_length(XPVOBJ, xobject_fields), 300 0, 301 SVt_PVOBJ, TRUE, NONV, HASARENA, 302 FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVOBJ))) }, 303 }; 304 305 #define new_body_allocated(sv_type) \ 306 (void *)((char *)S_new_body(aTHX_ sv_type) \ 307 - bodies_by_type[sv_type].offset) 308 309 #ifdef PURIFY 310 #if !(NVSIZE <= IVSIZE) 311 # define new_XNV() safemalloc(sizeof(XPVNV)) 312 #endif 313 #define new_XPVNV() safemalloc(sizeof(XPVNV)) 314 #define new_XPVMG() safemalloc(sizeof(XPVMG)) 315 316 #define del_body_by_type(p, type) safefree(p) 317 318 #else /* !PURIFY */ 319 320 #if !(NVSIZE <= IVSIZE) 321 # define new_XNV() new_body_allocated(SVt_NV) 322 #endif 323 #define new_XPVNV() new_body_allocated(SVt_PVNV) 324 #define new_XPVMG() new_body_allocated(SVt_PVMG) 325 326 #define del_body_by_type(p, type) \ 327 del_body(p + bodies_by_type[(type)].offset, \ 328 &PL_body_roots[(type)]) 329 330 #endif /* PURIFY */ 331 332 /* no arena for you! */ 333 334 #define new_NOARENA(details) \ 335 safemalloc((details)->body_size + (details)->offset) 336 #define new_NOARENAZ(details) \ 337 safecalloc((details)->body_size + (details)->offset, 1) 338 339 #ifndef PURIFY 340 341 /* grab a new thing from the arena's free list, allocating more if necessary. */ 342 #define new_body_from_arena(xpv, root_index, type_meta) \ 343 STMT_START { \ 344 void ** const r3wt = &PL_body_roots[root_index]; \ 345 xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \ 346 ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ root_index, \ 347 type_meta.body_size,\ 348 type_meta.arena_size)); \ 349 *(r3wt) = *(void**)(xpv); \ 350 } STMT_END 351 352 PERL_STATIC_INLINE void * 353 S_new_body(pTHX_ const svtype sv_type) 354 { 355 void *xpv; 356 new_body_from_arena(xpv, sv_type, bodies_by_type[sv_type]); 357 return xpv; 358 } 359 360 #endif 361 362 static const struct body_details fake_rv = 363 { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 }; 364 365 static const struct body_details fake_hv_with_aux = 366 /* The SVt_IV arena is used for (larger) PVHV bodies. */ 367 { sizeof(ALIGNED_TYPE_NAME(XPVHV_WITH_AUX)), 368 copy_length(XPVHV, xhv_max), 369 0, 370 SVt_PVHV, TRUE, NONV, HASARENA, 371 FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVHV_WITH_AUX))) }; 372 373 /* 374 =for apidoc newSV_type 375 376 Creates a new SV, of the type specified. The reference count for the new SV 377 is set to 1. 378 379 =cut 380 */ 381 382 PERL_STATIC_INLINE SV * 383 Perl_newSV_type(pTHX_ const svtype type) 384 { 385 SV *sv; 386 void* new_body; 387 const struct body_details *type_details; 388 389 new_SV(sv); 390 391 type_details = bodies_by_type + type; 392 393 SvFLAGS(sv) &= ~SVTYPEMASK; 394 SvFLAGS(sv) |= type; 395 396 switch (type) { 397 case SVt_NULL: 398 break; 399 case SVt_IV: 400 SET_SVANY_FOR_BODYLESS_IV(sv); 401 SvIV_set(sv, 0); 402 break; 403 case SVt_NV: 404 #if NVSIZE <= IVSIZE 405 SET_SVANY_FOR_BODYLESS_NV(sv); 406 #else 407 SvANY(sv) = new_XNV(); 408 #endif 409 SvNV_set(sv, 0); 410 break; 411 case SVt_PVHV: 412 case SVt_PVAV: 413 case SVt_PVOBJ: 414 assert(type_details->body_size); 415 416 #ifndef PURIFY 417 assert(type_details->arena); 418 assert(type_details->arena_size); 419 /* This points to the start of the allocated area. */ 420 new_body = S_new_body(aTHX_ type); 421 /* xpvav and xpvhv have no offset, so no need to adjust new_body */ 422 assert(!(type_details->offset)); 423 #else 424 /* We always allocated the full length item with PURIFY. To do this 425 we fake things so that arena is false for all 16 types.. */ 426 new_body = new_NOARENAZ(type_details); 427 #endif 428 SvANY(sv) = new_body; 429 430 SvSTASH_set(sv, NULL); 431 SvMAGIC_set(sv, NULL); 432 433 switch(type) { 434 case SVt_PVAV: 435 AvFILLp(sv) = -1; 436 AvMAX(sv) = -1; 437 AvALLOC(sv) = NULL; 438 439 AvREAL_only(sv); 440 break; 441 case SVt_PVHV: 442 HvTOTALKEYS(sv) = 0; 443 /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */ 444 HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX; 445 446 assert(!SvOK(sv)); 447 SvOK_off(sv); 448 #ifndef NODEFAULT_SHAREKEYS 449 HvSHAREKEYS_on(sv); /* key-sharing on by default */ 450 #endif 451 /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */ 452 HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX; 453 break; 454 case SVt_PVOBJ: 455 ObjectMAXFIELD(sv) = -1; 456 ObjectFIELDS(sv) = NULL; 457 break; 458 default: 459 NOT_REACHED; 460 } 461 462 sv->sv_u.svu_array = NULL; /* or svu_hash */ 463 break; 464 465 case SVt_PVIV: 466 case SVt_PVIO: 467 case SVt_PVGV: 468 case SVt_PVCV: 469 case SVt_PVLV: 470 case SVt_INVLIST: 471 case SVt_REGEXP: 472 case SVt_PVMG: 473 case SVt_PVNV: 474 case SVt_PV: 475 /* For a type known at compile time, it should be possible for the 476 * compiler to deduce the value of (type_details->arena), resolve 477 * that branch below, and inline the relevant values from 478 * bodies_by_type. Except, at least for gcc, it seems not to do that. 479 * We help it out here with two deviations from sv_upgrade: 480 * (1) Minor rearrangement here, so that PVFM - the only type at this 481 * point not to be allocated from an array appears last, not PV. 482 * (2) The ASSUME() statement here for everything that isn't PVFM. 483 * Obviously this all only holds as long as it's a true reflection of 484 * the bodies_by_type lookup table. */ 485 #ifndef PURIFY 486 ASSUME(type_details->arena); 487 #endif 488 /* FALLTHROUGH */ 489 case SVt_PVFM: 490 491 assert(type_details->body_size); 492 /* We always allocated the full length item with PURIFY. To do this 493 we fake things so that arena is false for all 16 types.. */ 494 #ifndef PURIFY 495 if(type_details->arena) { 496 /* This points to the start of the allocated area. */ 497 new_body = S_new_body(aTHX_ type); 498 Zero(new_body, type_details->body_size, char); 499 new_body = ((char *)new_body) - type_details->offset; 500 } else 501 #endif 502 { 503 new_body = new_NOARENAZ(type_details); 504 } 505 SvANY(sv) = new_body; 506 507 if (UNLIKELY(type == SVt_PVIO)) { 508 IO * const io = MUTABLE_IO(sv); 509 GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV); 510 511 SvOBJECT_on(io); 512 /* Clear the stashcache because a new IO could overrule a package 513 name */ 514 DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n")); 515 hv_clear(PL_stashcache); 516 517 SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv)))); 518 IoPAGE_LEN(sv) = 60; 519 } 520 521 sv->sv_u.svu_rv = NULL; 522 break; 523 default: 524 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", 525 (unsigned long)type); 526 } 527 528 return sv; 529 } 530 531 /* 532 =for apidoc newSV_type_mortal 533 534 Creates a new mortal SV, of the type specified. The reference count for the 535 new SV is set to 1. 536 537 This is equivalent to 538 SV* sv = sv_2mortal(newSV_type(<some type>)) 539 and 540 SV* sv = sv_newmortal(); 541 sv_upgrade(sv, <some_type>) 542 but should be more efficient than both of them. (Unless sv_2mortal is inlined 543 at some point in the future.) 544 545 =cut 546 */ 547 548 PERL_STATIC_INLINE SV * 549 Perl_newSV_type_mortal(pTHX_ const svtype type) 550 { 551 SV *sv = newSV_type(type); 552 SSize_t ix = ++PL_tmps_ix; 553 if (UNLIKELY(ix >= PL_tmps_max)) 554 ix = Perl_tmps_grow_p(aTHX_ ix); 555 PL_tmps_stack[ix] = (sv); 556 SvTEMP_on(sv); 557 return sv; 558 } 559 560 /* The following functions started out in sv.h and then moved to inline.h. They 561 * moved again into this file during the 5.37.x development cycle. */ 562 563 /* 564 =for apidoc_section $SV 565 =for apidoc SvPVXtrue 566 567 Returns a boolean as to whether or not C<sv> contains a PV that is considered 568 TRUE. FALSE is returned if C<sv> doesn't contain a PV, or if the PV it does 569 contain is zero length, or consists of just the single character '0'. Every 570 other PV value is considered TRUE. 571 572 As of Perl v5.37.1, C<sv> is evaluated exactly once; in earlier releases, it 573 could be evaluated more than once. 574 575 =cut 576 */ 577 578 PERL_STATIC_INLINE bool 579 Perl_SvPVXtrue(pTHX_ SV *sv) 580 { 581 PERL_ARGS_ASSERT_SVPVXTRUE; 582 583 PERL_UNUSED_CONTEXT; 584 585 if (! (XPV *) SvANY(sv)) { 586 return false; 587 } 588 589 if ( ((XPV *) SvANY(sv))->xpv_cur > 1) { /* length > 1 */ 590 return true; 591 } 592 593 if (( (XPV *) SvANY(sv))->xpv_cur == 0) { 594 return false; 595 } 596 597 return *sv->sv_u.svu_pv != '0'; 598 } 599 600 /* 601 =for apidoc SvGETMAGIC 602 Invokes C<L</mg_get>> on an SV if it has 'get' magic. For example, this 603 will call C<FETCH> on a tied variable. As of 5.37.1, this function is 604 guaranteed to evaluate its argument exactly once. 605 606 =cut 607 */ 608 609 PERL_STATIC_INLINE void 610 Perl_SvGETMAGIC(pTHX_ SV *sv) 611 { 612 PERL_ARGS_ASSERT_SVGETMAGIC; 613 614 if (UNLIKELY(SvGMAGICAL(sv))) { 615 mg_get(sv); 616 } 617 } 618 619 PERL_STATIC_INLINE bool 620 Perl_SvTRUE(pTHX_ SV *sv) 621 { 622 PERL_ARGS_ASSERT_SVTRUE; 623 624 if (UNLIKELY(sv == NULL)) 625 return FALSE; 626 SvGETMAGIC(sv); 627 return SvTRUE_nomg_NN(sv); 628 } 629 630 PERL_STATIC_INLINE bool 631 Perl_SvTRUE_nomg(pTHX_ SV *sv) 632 { 633 PERL_ARGS_ASSERT_SVTRUE_NOMG; 634 635 if (UNLIKELY(sv == NULL)) 636 return FALSE; 637 return SvTRUE_nomg_NN(sv); 638 } 639 640 PERL_STATIC_INLINE bool 641 Perl_SvTRUE_NN(pTHX_ SV *sv) 642 { 643 PERL_ARGS_ASSERT_SVTRUE_NN; 644 645 SvGETMAGIC(sv); 646 return SvTRUE_nomg_NN(sv); 647 } 648 649 PERL_STATIC_INLINE bool 650 Perl_SvTRUE_common(pTHX_ SV * sv, const bool sv_2bool_is_fallback) 651 { 652 PERL_ARGS_ASSERT_SVTRUE_COMMON; 653 654 if (UNLIKELY(SvIMMORTAL_INTERP(sv))) 655 return SvIMMORTAL_TRUE(sv); 656 657 if (! SvOK(sv)) 658 return FALSE; 659 660 if (SvPOK(sv)) 661 return SvPVXtrue(sv); 662 663 if (SvIOK(sv)) 664 return SvIVX(sv) != 0; /* casts to bool */ 665 666 if (SvROK(sv) && !(SvOBJECT(SvRV(sv)) && HvAMAGIC(SvSTASH(SvRV(sv))))) 667 return TRUE; 668 669 if (sv_2bool_is_fallback) 670 return sv_2bool_nomg(sv); 671 672 return isGV_with_GP(sv); 673 } 674 675 PERL_STATIC_INLINE SV * 676 Perl_SvREFCNT_inc(SV *sv) 677 { 678 if (LIKELY(sv != NULL)) 679 SvREFCNT(sv)++; 680 return sv; 681 } 682 683 PERL_STATIC_INLINE SV * 684 Perl_SvREFCNT_inc_NN(SV *sv) 685 { 686 PERL_ARGS_ASSERT_SVREFCNT_INC_NN; 687 688 SvREFCNT(sv)++; 689 return sv; 690 } 691 692 PERL_STATIC_INLINE void 693 Perl_SvREFCNT_inc_void(SV *sv) 694 { 695 if (LIKELY(sv != NULL)) 696 SvREFCNT(sv)++; 697 } 698 699 PERL_STATIC_INLINE void 700 Perl_SvREFCNT_dec(pTHX_ SV *sv) 701 { 702 if (LIKELY(sv != NULL)) { 703 U32 rc = SvREFCNT(sv); 704 if (LIKELY(rc > 1)) 705 SvREFCNT(sv) = rc - 1; 706 else 707 Perl_sv_free2(aTHX_ sv, rc); 708 } 709 } 710 711 PERL_STATIC_INLINE SV * 712 Perl_SvREFCNT_dec_ret_NULL(pTHX_ SV *sv) 713 { 714 PERL_ARGS_ASSERT_SVREFCNT_DEC_RET_NULL; 715 Perl_SvREFCNT_dec(aTHX_ sv); 716 return NULL; 717 } 718 719 720 PERL_STATIC_INLINE void 721 Perl_SvREFCNT_dec_NN(pTHX_ SV *sv) 722 { 723 U32 rc = SvREFCNT(sv); 724 725 PERL_ARGS_ASSERT_SVREFCNT_DEC_NN; 726 727 if (LIKELY(rc > 1)) 728 SvREFCNT(sv) = rc - 1; 729 else 730 Perl_sv_free2(aTHX_ sv, rc); 731 } 732 733 /* 734 =for apidoc SvAMAGIC_on 735 736 Indicate that C<sv> has overloading (active magic) enabled. 737 738 =cut 739 */ 740 741 PERL_STATIC_INLINE void 742 Perl_SvAMAGIC_on(SV *sv) 743 { 744 PERL_ARGS_ASSERT_SVAMAGIC_ON; 745 assert(SvROK(sv)); 746 747 if (SvOBJECT(SvRV(sv))) HvAMAGIC_on(SvSTASH(SvRV(sv))); 748 } 749 750 /* 751 =for apidoc SvAMAGIC_off 752 753 Indicate that C<sv> has overloading (active magic) disabled. 754 755 =cut 756 */ 757 758 PERL_STATIC_INLINE void 759 Perl_SvAMAGIC_off(SV *sv) 760 { 761 PERL_ARGS_ASSERT_SVAMAGIC_OFF; 762 763 if (SvROK(sv) && SvOBJECT(SvRV(sv))) 764 HvAMAGIC_off(SvSTASH(SvRV(sv))); 765 } 766 767 PERL_STATIC_INLINE U32 768 Perl_SvPADSTALE_on(SV *sv) 769 { 770 assert(!(SvFLAGS(sv) & SVs_PADTMP)); 771 return SvFLAGS(sv) |= SVs_PADSTALE; 772 } 773 PERL_STATIC_INLINE U32 774 Perl_SvPADSTALE_off(SV *sv) 775 { 776 assert(!(SvFLAGS(sv) & SVs_PADTMP)); 777 return SvFLAGS(sv) &= ~SVs_PADSTALE; 778 } 779 780 /* 781 =for apidoc_section $SV 782 =for apidoc SvIV 783 =for apidoc_item SvIV_nomg 784 =for apidoc_item SvIVx 785 786 These each coerce the given SV to IV and return it. The returned value in many 787 circumstances will get stored in C<sv>'s IV slot, but not in all cases. (Use 788 C<L</sv_setiv>> to make sure it does). 789 790 As of 5.37.1, all are guaranteed to evaluate C<sv> only once. 791 792 C<SvIVx> is now identical to C<SvIV>, but prior to 5.37.1, it was the only form 793 guaranteed to evaluate C<sv> only once. 794 795 C<SvIV_nomg> is the same as C<SvIV>, but does not perform 'get' magic. 796 797 =for apidoc SvNV 798 =for apidoc_item SvNV_nomg 799 =for apidoc_item SvNVx 800 801 These each coerce the given SV to NV and return it. The returned value in many 802 circumstances will get stored in C<sv>'s NV slot, but not in all cases. (Use 803 C<L</sv_setnv>> to make sure it does). 804 805 As of 5.37.1, all are guaranteed to evaluate C<sv> only once. 806 807 C<SvNVx> is now identical to C<SvNV>, but prior to 5.37.1, it was the only form 808 guaranteed to evaluate C<sv> only once. 809 810 C<SvNV_nomg> is the same as C<SvNV>, but does not perform 'get' magic. 811 812 =for apidoc SvUV 813 =for apidoc_item SvUV_nomg 814 =for apidoc_item SvUVx 815 816 These each coerce the given SV to UV and return it. The returned value in many 817 circumstances will get stored in C<sv>'s UV slot, but not in all cases. (Use 818 C<L</sv_setuv>> to make sure it does). 819 820 As of 5.37.1, all are guaranteed to evaluate C<sv> only once. 821 822 C<SvUVx> is now identical to C<SvUV>, but prior to 5.37.1, it was the only form 823 guaranteed to evaluate C<sv> only once. 824 825 =cut 826 */ 827 828 PERL_STATIC_INLINE IV 829 Perl_SvIV(pTHX_ SV *sv) { 830 PERL_ARGS_ASSERT_SVIV; 831 832 if (SvIOK_nog(sv)) 833 return SvIVX(sv); 834 return sv_2iv(sv); 835 } 836 837 PERL_STATIC_INLINE UV 838 Perl_SvUV(pTHX_ SV *sv) { 839 PERL_ARGS_ASSERT_SVUV; 840 841 if (SvUOK_nog(sv)) 842 return SvUVX(sv); 843 return sv_2uv(sv); 844 } 845 846 PERL_STATIC_INLINE NV 847 Perl_SvNV(pTHX_ SV *sv) { 848 PERL_ARGS_ASSERT_SVNV; 849 850 if (SvNOK_nog(sv)) 851 return SvNVX(sv); 852 return sv_2nv(sv); 853 } 854 855 PERL_STATIC_INLINE IV 856 Perl_SvIV_nomg(pTHX_ SV *sv) { 857 PERL_ARGS_ASSERT_SVIV_NOMG; 858 859 if (SvIOK(sv)) 860 return SvIVX(sv); 861 return sv_2iv_flags(sv, 0); 862 } 863 864 PERL_STATIC_INLINE UV 865 Perl_SvUV_nomg(pTHX_ SV *sv) { 866 PERL_ARGS_ASSERT_SVUV_NOMG; 867 868 if (SvUOK(sv)) 869 return SvUVX(sv); 870 return sv_2uv_flags(sv, 0); 871 } 872 873 PERL_STATIC_INLINE NV 874 Perl_SvNV_nomg(pTHX_ SV *sv) { 875 PERL_ARGS_ASSERT_SVNV_NOMG; 876 877 if (SvNOK(sv)) 878 return SvNVX(sv); 879 return sv_2nv_flags(sv, 0); 880 } 881 882 #if defined(PERL_CORE) || defined (PERL_EXT) 883 PERL_STATIC_INLINE STRLEN 884 S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp) 885 { 886 PERL_ARGS_ASSERT_SV_OR_PV_POS_U2B; 887 if (SvGAMAGIC(sv)) { 888 U8 *hopped = utf8_hop((U8 *)pv, pos); 889 if (lenp) *lenp = (STRLEN)(utf8_hop(hopped, *lenp) - hopped); 890 return (STRLEN)(hopped - (U8 *)pv); 891 } 892 return sv_pos_u2b_flags(sv,pos,lenp,SV_CONST_RETURN); 893 } 894 #endif 895 896 PERL_STATIC_INLINE char * 897 Perl_sv_pvutf8n_force_wrapper(pTHX_ SV * const sv, STRLEN * const lp, const U32 dummy) 898 { 899 /* This is just so can be passed to Perl_SvPV_helper() as a function 900 * pointer with the same signature as all the other such pointers, and 901 * having hence an unused parameter */ 902 PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE_WRAPPER; 903 PERL_UNUSED_ARG(dummy); 904 905 return sv_pvutf8n_force(sv, lp); 906 } 907 908 PERL_STATIC_INLINE char * 909 Perl_sv_pvbyten_force_wrapper(pTHX_ SV * const sv, STRLEN * const lp, const U32 dummy) 910 { 911 /* This is just so can be passed to Perl_SvPV_helper() as a function 912 * pointer with the same signature as all the other such pointers, and 913 * having hence an unused parameter */ 914 PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE_WRAPPER; 915 PERL_UNUSED_ARG(dummy); 916 917 return sv_pvbyten_force(sv, lp); 918 } 919 920 PERL_STATIC_INLINE char * 921 Perl_SvPV_helper(pTHX_ 922 SV * const sv, 923 STRLEN * const lp, 924 const U32 flags, 925 const PL_SvPVtype type, 926 char * (*non_trivial)(pTHX_ SV *, STRLEN * const, const U32), 927 const bool or_null, 928 const U32 return_flags 929 ) 930 { 931 /* 'type' should be known at compile time, so this is reduced to a single 932 * conditional at runtime */ 933 if ( (type == SvPVbyte_type_ && SvPOK_byte_nog(sv)) 934 || (type == SvPVforce_type_ && SvPOK_pure_nogthink(sv)) 935 || (type == SvPVutf8_type_ && SvPOK_utf8_nog(sv)) 936 || (type == SvPVnormal_type_ && SvPOK_nog(sv)) 937 || (type == SvPVutf8_pure_type_ && SvPOK_utf8_pure_nogthink(sv)) 938 || (type == SvPVbyte_pure_type_ && SvPOK_byte_pure_nogthink(sv)) 939 ) { 940 if (lp) { 941 *lp = SvCUR(sv); 942 } 943 944 /* Similarly 'return_flags is known at compile time, so this becomes 945 * branchless */ 946 if (return_flags & SV_MUTABLE_RETURN) { 947 return SvPVX_mutable(sv); 948 } 949 else if(return_flags & SV_CONST_RETURN) { 950 return (char *) SvPVX_const(sv); 951 } 952 else { 953 return SvPVX(sv); 954 } 955 } 956 957 if (or_null) { /* This is also known at compile time */ 958 if (flags & SV_GMAGIC) { /* As is this */ 959 SvGETMAGIC(sv); 960 } 961 962 if (! SvOK(sv)) { 963 if (lp) { /* As is this */ 964 *lp = 0; 965 } 966 967 return NULL; 968 } 969 } 970 971 /* Can't trivially handle this, call the function */ 972 return non_trivial(aTHX_ sv, lp, (flags|return_flags)); 973 } 974 975 /* 976 =for apidoc newRV_noinc 977 978 Creates an RV wrapper for an SV. The reference count for the original 979 SV is B<not> incremented. 980 981 =cut 982 */ 983 984 PERL_STATIC_INLINE SV * 985 Perl_newRV_noinc(pTHX_ SV *const tmpRef) 986 { 987 SV *sv = newSV_type(SVt_IV); 988 989 PERL_ARGS_ASSERT_NEWRV_NOINC; 990 991 SvTEMP_off(tmpRef); 992 993 /* inlined, simplified sv_setrv_noinc(sv, tmpRef); */ 994 SvRV_set(sv, tmpRef); 995 SvROK_on(sv); 996 997 return sv; 998 } 999 1000 PERL_STATIC_INLINE char * 1001 Perl_sv_setpv_freshbuf(pTHX_ SV *const sv) 1002 { 1003 PERL_ARGS_ASSERT_SV_SETPV_FRESHBUF; 1004 assert(SvTYPE(sv) >= SVt_PV); 1005 assert(SvTYPE(sv) <= SVt_PVMG); 1006 assert(!SvTHINKFIRST(sv)); 1007 assert(SvPVX(sv)); 1008 SvCUR_set(sv, 0); 1009 *(SvEND(sv))= '\0'; 1010 (void)SvPOK_only_UTF8(sv); /* UTF-8 flag will be 0; This is used instead 1011 of 'SvPOK_only' because the other sv_setpv 1012 functions use it */ 1013 SvTAINT(sv); 1014 return SvPVX(sv); 1015 } 1016 1017 /* 1018 * ex: set ts=8 sts=4 sw=4 et: 1019 */ 1020